From 79e0afa224168208dad5a30a58355f968efa6af4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Er=C3=A8be?= Date: Wed, 1 Jun 2016 16:24:16 +0200 Subject: [PATCH] Better Logging --- app/Main.hs | 6 ++-- src/Tunnel.hs | 80 ++++++++++++++++++++++++++++++++++++--------------- 2 files changed, 60 insertions(+), 26 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 7fa130b..94661b3 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -21,7 +21,7 @@ data WsTunnel = WsTunnel , proxy :: String , serverMode :: Bool , restrictTo :: String - , _last :: Bool + , verbose :: Bool } deriving (Show, Data, Typeable) data WsServerInfo = WsServerInfo @@ -53,7 +53,7 @@ cmdLine = WsTunnel &= help "Start a server that will forward traffic for you" &= groupname "Server options" , restrictTo = def &= explicit &= name "r" &= name "restrictTo" &= help "Accept traffic to be forwarded only to this service" &= typ "HOST:PORT" - , _last = def &= explicit &= name "ツ" &= groupname "Common options" + , verbose = def &= groupname "Common options" &= help "Print debug information" } &= summary ( "Use the websockets protocol to tunnel {TCP,UDP} traffic\n" ++ "wsTunnelClient <---> wsTunnelServer <---> RemoteHost\n" ++ "Use secure connection (wss://) to bypass proxies" @@ -106,7 +106,7 @@ main = do cfg <- if null args then withArgs ["--help"] (cmdArgs cmdLine) else cmdArgs cmdLine let serverInfo = parseServerInfo (WsServerInfo False "" 0) (wsTunnelServer cfg) - LOG.updateGlobalLogger "wstunnel" (LOG.setLevel LOG.INFO) + LOG.updateGlobalLogger "wstunnel" (if verbose cfg then LOG.setLevel LOG.DEBUG else LOG.setLevel LOG.INFO) if serverMode cfg diff --git a/src/Tunnel.hs b/src/Tunnel.hs index de62679..fb179ec 100644 --- a/src/Tunnel.hs +++ b/src/Tunnel.hs @@ -116,9 +116,13 @@ connectionToStream Connection{..} = WS.makeStream read (write . toStrict . from -- Pipes -- tunnelingClientP :: TunnelSettings -> (Connection -> IO (Either Error ())) -> (Connection -> IO (Either Error ())) -tunnelingClientP info@TunnelSettings{..} app conn = do +tunnelingClientP cfg@TunnelSettings{..} app conn = do + debug "Oppening Websocket stream" stream <- connectionToStream conn - onError $ WS.runClientWithStream stream serverHost (toPath info) WS.defaultConnectionOptions [] (app . toConnection) + ret <- onError $ WS.runClientWithStream stream serverHost (toPath cfg) WS.defaultConnectionOptions [] (app . toConnection) + + debug "Closing Websocket stream" + return ret where onError = flip catch (\(e :: SomeException) -> return . Left . WebsocketError $ show e) @@ -137,7 +141,9 @@ tlsClientP TunnelSettings{..} app conn = do , NC.connectionUseSocks = Nothing } - onError $ do + debug "Doing tls Handshake" + + ret <- onError $ do context <- NC.initConnectionContext let socket = fromJust . N.appRawSocket . fromJust $ rawConnection conn h <- N.socketToHandle socket ReadWriteMode @@ -145,6 +151,9 @@ tlsClientP TunnelSettings{..} app conn = do connection <- NC.connectFromHandle context h connectionParams finally (app (toConnection connection)) (hClose h) + debug "Closing TLS" + return ret + where onError = flip catch (\(e :: SomeException) -> return . Left . TlsError $ show e) @@ -153,22 +162,41 @@ tlsClientP TunnelSettings{..} app conn = do -- Connectors -- tcpConnection :: TunnelSettings -> (Connection -> IO (Either Error ())) -> IO (Either Error ()) -tcpConnection TunnelSettings{..} app = - N.runTCPClient (N.clientSettingsTCP (fromIntegral serverPort) (fromString serverHost)) (app . toConnection) - `catch` - (\(e :: SomeException) -> return $ if take 10 (show e) == "user error" then Right () else Left $ TunnelError $ show e) +tcpConnection TunnelSettings{..} app = do + debug $ "Oppening tcp connection to " <> fromString serverHost <> ":" <> show (fromIntegral serverPort :: Int) + + ret <- onError $ N.runTCPClient (N.clientSettingsTCP (fromIntegral serverPort) (fromString serverHost)) $ \conn -> do + ret <- app (toConnection conn) + either (info . show) (const $ return ()) ret + return ret + + + debug $ "Closing tcp connection to " <> fromString serverHost <> ":" <> show (fromIntegral serverPort :: Int) + return ret + + where + onError = flip catch (\(e :: SomeException) -> return $ if take 10 (show e) == "user error" then Right () else Left $ TunnelError $ show e) + + httpProxyConnection :: (HostName, PortNumber) -> TunnelSettings -> (Connection -> IO (Either Error ())) -> IO (Either Error ()) -httpProxyConnection (host, port) TunnelSettings{..} app = - onError $ N.runTCPClient (N.clientSettingsTCP (fromIntegral port) (fromString host)) $ \conn -> do +httpProxyConnection (host, port) TunnelSettings{..} app = do + debug $ "Oppening tcp connection to proxy " <> fromString host <> ":" <> show (fromIntegral port :: Int) + + ret <- onError $ N.runTCPClient (N.clientSettingsTCP (fromIntegral port) (fromString host)) $ \conn -> do _ <- sendConnectRequest conn responseM <- timeout (1000000 * 10) $ readConnectResponse mempty conn let response = fromMaybe "No response of the proxy after 10s" responseM if isAuthorized response - then app (toConnection conn) + then do ret <- app (toConnection conn) + either (info . show) (const $ return ()) ret + return ret else return . Left . ProxyForwardError $ BC.unpack response + debug $ "Closing tcp connection to proxy " <> fromString host <> ":" <> show (fromIntegral port :: Int) + return ret + where sendConnectRequest h = N.appWrite h $ "CONNECT " <> fromString serverHost <> ":" <> fromString (show serverPort) <> " HTTP/1.0\r\n" <> "Host: " <> fromString serverHost <> ":" <> fromString (show serverPort) <> "\r\n\r\n" @@ -190,16 +218,19 @@ httpProxyConnection (host, port) TunnelSettings{..} app = -- runClient :: TunnelSettings -> IO () runClient cfg@TunnelSettings{..} = do - let withTcp = if isJust proxySetting then httpProxyConnection (fromJust proxySetting) cfg else tcpConnection cfg + let withEndPoint = if isJust proxySetting then httpProxyConnection (fromJust proxySetting) cfg else tcpConnection cfg let doTlsIf tlsNeeded app = if tlsNeeded then tlsClientP cfg app else app - let tunnelClient = tunnelingClientP cfg - let tunnelServer app = withTcp (doTlsIf useTls . tunnelClient $ app) + let runTunnelClient = tunnelingClientP cfg + let withTunnel app = withEndPoint (doTlsIf useTls . runTunnelClient $ app) let app localH = do - info $ "CREATE tunnel :: " <> show cfg - ret <- tunnelServer (`propagateRW` toConnection localH) + ret <- withTunnel $ \remoteH -> do + info $ "CREATE tunnel :: " <> show cfg + ret <- remoteH `propagateRW` toConnection localH + info $ "CLOSE tunnel :: " <> show cfg + return ret + handleError ret - info $ "CLOSE tunnel :: " <> show cfg case protocol of UDP -> runUDPServer (localBind, localPort) app @@ -209,13 +240,16 @@ handleError :: Either Error () -> IO () handleError (Right ()) = return () handleError (Left err) = case err of - ProxyConnectionError msg -> info "Cannot connect to the proxy" >> debug msg - ProxyForwardError msg -> info "Connection not allowed by the proxy" >> debug msg - TunnelError msg -> info "Cannot establish the connection to the server" >> debug msg - LocalServerError msg -> info "Cannot create the localServer, port already binded ?" >> debug msg - WebsocketError msg -> info "Cannot establish websocket connection with the server" >> debug msg - TlsError msg -> info "Cannot do tls handshake with the server" >> debug msg - Other msg -> debug msg + ProxyConnectionError msg -> info "Cannot connect to the proxy" >> debugPP msg + ProxyForwardError msg -> info "Connection not allowed by the proxy" >> debugPP msg + TunnelError msg -> info "Cannot establish the connection to the server" >> debugPP msg + LocalServerError msg -> info "Cannot create the localServer, port already binded ?" >> debugPP msg + WebsocketError msg -> info "Cannot establish websocket connection with the server" >> debugPP msg + TlsError msg -> info "Cannot do tls handshake with the server" >> debugPP msg + Other msg -> debugPP msg + + where + debugPP msg = debug $ "====\n" <> msg <> "\n====" propagateRW :: Connection -> Connection -> IO (Either Error ())