hex/wstunnel
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add timeout to tcp cnx

Browse source 
Former-commit-id: 5adb049b14d9380e46c4f80c10a1d8062fe83904 [formerly b10cc7b46bda496234557f7b61ad7aa3ca988527] [formerly 557a8511fa2d9470bbd1a544d8b7e509103314d5 [formerly e1d1f02a69b56adf64d3aa0fef35f5e47e08039f [formerly e1d1f02a69b56adf64d3aa0fef35f5e47e08039f [formerly e1d1f02a69b56adf64d3aa0fef35f5e47e08039f [formerly 0fc191817c92b9b62300bec0acd8fb64c148cbc7]]]]]
Former-commit-id: da13228c115750898b6cfbd4c4c91ce63b08b509 [formerly 4feac2317e1efbf60134e585c96cdaa6ee3b18ff]
Former-commit-id: 5bf83c3e60bcdffc02c05f5fc826659b607188dc
Former-commit-id: b38569743f40ab3dc1c7a8792fafaa143b5d39b8
Former-commit-id: de5fd5b6a52f8c5d8fdc224dcfde2f7b35cf9c4f
Former-commit-id: a14726dacbedeab41fdde692399a282d1f784dfe [formerly 2ac7520615a3a508c4c1905433d7e2b5887c1a59]
Former-commit-id: 7996f71d276326ea9e698d5ae63f465070e73b50
This commit is contained in:
Σrebe - Romain GERARD 2023-07-29 12:28:59 +02:00
parent d0868f6630
commit 51752ed191
1 changed files with 13 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
src/Tunnel.hs
View file

@ -17,7 +17,7 @@ import qualified Data.Conduit.Network.TLS as N
import qualified Data.Streaming.Network as N
import Network.Socket (HostName, PortNumber)
import qualified Network.Socket as N
import qualified Network.Socket as N
import qualified Network.Socket.ByteString as N
import qualified Network.Socket.ByteString.Lazy as NL
@ -37,10 +37,15 @@ import Logger
rrunTCPClient :: N.ClientSettings -> (Connection -> IO a) -> IO a
rrunTCPClient cfg app = bracket
rrunTCPClient :: MonadError Error m => N.ClientSettings -> (Connection -> IO (m a)) -> IO (m a)
rrunTCPClient cfg app = onError $ bracket
(do
(s,addr) <- N.getSocketFamilyTCP (N.getHost cfg) (N.getPort cfg) (N.getAddrFamily cfg)
let _10sec = 1000000 * 10
ret <- timeout _10sec $ N.getSocketFamilyTCP (N.getHost cfg) (N.getPort cfg) (N.getAddrFamily cfg)
(s, addr) <- pure $ case ret of
Just (s, addr) -> (s, addr)
Nothing -> error $ "Cannot open tcp socket within 10 sec to " <> show (N.getHost cfg) <> ":" <> show (N.getPort cfg)
so_mark_val <- readIORef sO_MARK_Value
when (so_mark_val /= 0 && N.isSupportedSocketOption sO_MARK) (N.setSocketOption s sO_MARK so_mark_val)
return (s,addr)
@ -52,6 +57,8 @@ rrunTCPClient cfg app = bracket
, close = N.close s
, rawConnection = Just s
})
where
onError = flip catch (\(e :: SomeException) -> return . throwError . TunnelError $ show e)
--
-- Pipes
@ -73,9 +80,7 @@ tunnelingClientP cfg@TunnelSettings{..} app conn = onError $ do
where
connectionToStream Connection{..} = WS.makeStream read (write . toStrict . fromJust)
onError = flip catch (\(e :: SomeException) -> return . throwError . WebsocketError $ show e)
run cnx = do
WS.forkPingThread cnx websocketPingFrequencySec
app (toConnection cnx)
run cnx = WS.withPingThread cnx websocketPingFrequencySec mempty (app (toConnection cnx))
tlsClientP :: MonadError Error m => TunnelSettings -> (Connection -> IO (m ())) -> (Connection -> IO (m ()))
@ -118,7 +123,7 @@ tcpConnection TunnelSettings{..} app = onError $ do
return ret
where
onError = flip catch (\(e :: SomeException) -> return $ when (take 10 (show e) == "user error") (throwError $ TunnelError $ show e))
onError = flip catch (\(e :: SomeException) -> return $ (throwError $ TunnelError $ show e))