From 51752ed191cdea06b2e24cd8c58c0e36a4cfd9a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=CE=A3rebe=20-=20Romain=20GERARD?= Date: Sat, 29 Jul 2023 12:28:59 +0200 Subject: [PATCH] Add timeout to tcp cnx 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 --- src/Tunnel.hs | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/src/Tunnel.hs b/src/Tunnel.hs index d6002bb..ee292a8 100644 --- a/src/Tunnel.hs +++ b/src/Tunnel.hs @@ -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))