diff --git a/app/Main.hs b/app/Main.hs index 94661b3..6eacae9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -16,12 +16,14 @@ import qualified System.Log.Logger as LOG data WsTunnel = WsTunnel { localToRemote :: String -- , remoteToLocal :: String + -- , dynamicToRemote :: String , wsTunnelServer :: String , udpMode :: Bool , proxy :: String , serverMode :: Bool , restrictTo :: String , verbose :: Bool + , quiet :: Bool } deriving (Show, Data, Typeable) data WsServerInfo = WsServerInfo @@ -54,6 +56,7 @@ cmdLine = WsTunnel , restrictTo = def &= explicit &= name "r" &= name "restrictTo" &= help "Accept traffic to be forwarded only to this service" &= typ "HOST:PORT" , verbose = def &= groupname "Common options" &= help "Print debug information" + , quiet = def &= help "Print only errors" } &= summary ( "Use the websockets protocol to tunnel {TCP,UDP} traffic\n" ++ "wsTunnelClient <---> wsTunnelServer <---> RemoteHost\n" ++ "Use secure connection (wss://) to bypass proxies" @@ -106,7 +109,11 @@ 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" (if verbose cfg then LOG.setLevel LOG.DEBUG else LOG.setLevel LOG.INFO) + LOG.updateGlobalLogger "wstunnel" (if quiet cfg + then LOG.setLevel LOG.ERROR + else if verbose cfg + then LOG.setLevel LOG.DEBUG + else LOG.setLevel LOG.INFO) if serverMode cfg diff --git a/src/Protocols.hs b/src/Protocols.hs index cc6f5b0..02ff0e7 100644 --- a/src/Protocols.hs +++ b/src/Protocols.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -21,6 +22,7 @@ import qualified Network.Socket as N hiding (recv, recvFrom, send, sendTo) import qualified Network.Socket.ByteString as N +import qualified System.Log.Logger as LOG deriving instance Generic PortNumber deriving instance Hashable PortNumber @@ -41,24 +43,29 @@ instance N.HasReadWrite UdpAppData where readLens f appData = fmap (\getData -> appData { appRead = getData}) (f $ appRead appData) writeLens f appData = fmap (\writeData -> appData { appWrite = writeData}) (f $ appWrite appData) +toStr :: (HostName, PortNumber) -> String +toStr (host, port) = fromString host <> ":" <> show port +err msg = LOG.errorM "wstunnel" $ "ERROR :: " <> msg +info = LOG.infoM "wstunnel" +debug msg = LOG.debugM "wstunnel" $ "DEBUG :: " <> msg runTCPServer :: (HostName, PortNumber) -> (N.AppData -> IO ()) -> IO () -runTCPServer (host, port) app = do - putStrLn $ "WAIT for connection on " <> fromString host <> ":" <> tshow port +runTCPServer endPoint@(host, port) app = do + info $ "WAIT for tcp connection on " <> toStr endPoint void $ N.runTCPServer (N.serverSettingsTCP (fromIntegral port) (fromString host)) app - putStrLn "CLOSE tunnel" + info $ "CLOSE tcp server on " <> toStr endPoint runTCPClient :: (HostName, PortNumber) -> (N.AppData -> IO ()) -> IO () -runTCPClient (host, port) app = do - putStrLn $ "CONNECTING to " <> fromString host <> ":" <> tshow port +runTCPClient endPoint@(host, port) app = do + info $ "CONNECTING to " <> toStr endPoint void $ N.runTCPClient (N.clientSettingsTCP (fromIntegral port) (BC.pack host)) app - putStrLn $ "CLOSE connection to " <> fromString host <> ":" <> tshow port + info $ "CLOSE connection to " <> toStr endPoint runUDPClient :: (HostName, PortNumber) -> (UdpAppData -> IO ()) -> IO () -runUDPClient (host, port) app = do - putStrLn $ "CONNECTING to " <> fromString host <> ":" <> tshow port +runUDPClient endPoint@(host, port) app = do + info $ "SENDING datagrammes to " <> toStr endPoint bracket (N.getSocketUDP host (fromIntegral port)) (N.close . fst) $ \(socket, addrInfo) -> do sem <- newEmptyMVar app UdpAppData { appAddr = N.addrAddress addrInfo @@ -67,15 +74,15 @@ runUDPClient (host, port) app = do , appWrite = \payload -> void $ N.sendTo socket payload (N.addrAddress addrInfo) } - putStrLn $ "CLOSE connection to " <> fromString host <> ":" <> tshow port + info $ "CLOSE udp connection to " <> toStr endPoint runUDPServer :: (HostName, PortNumber) -> (UdpAppData -> IO ()) -> IO () -runUDPServer (host, port) app = do - putStrLn $ "WAIT for datagrames on " <> fromString host <> ":" <> tshow port +runUDPServer endPoint@(host, port) app = do + info $ "WAIT for datagrames on " <> toStr endPoint clientsCtx <- newIORef mempty void $ bracket (N.bindPortUDP (fromIntegral port) (fromString host)) N.close (runEventLoop clientsCtx) - putStrLn "CLOSE tunnel" + info $ "CLOSE udp server" <> toStr endPoint where addNewClient :: IORef (H.HashMap N.SockAddr UdpAppData) -> N.Socket -> N.SockAddr -> ByteString -> IO UdpAppData @@ -92,7 +99,7 @@ runUDPServer (host, port) app = do removeClient :: IORef (H.HashMap N.SockAddr UdpAppData) -> UdpAppData -> IO () removeClient clientsCtx clientCtx = do void $ atomicModifyIORef' clientsCtx (\clients -> (H.delete (appAddr clientCtx) clients, ())) - putStrLn "TIMEOUT connection" + debug "TIMEOUT connection" pushDataToClient :: UdpAppData -> ByteString -> IO () pushDataToClient clientCtx = putMVar (appSem clientCtx) diff --git a/src/Tunnel.hs b/src/Tunnel.hs index 694892b..5936ab9 100644 --- a/src/Tunnel.hs +++ b/src/Tunnel.hs @@ -23,9 +23,9 @@ import qualified Data.Conduit.Network.TLS as N import qualified Data.Streaming.Network as N import Network.Socket (HostName, PortNumber) -import qualified Network.Socket.ByteString as N import qualified Network.Socket as N hiding (recv, recvFrom, send, sendTo) +import qualified Network.Socket.ByteString as N import qualified Network.WebSockets as WS import qualified Network.WebSockets.Connection as WS @@ -113,7 +113,7 @@ instance ToConnection NC.Connection where rrunTCPClient :: N.ClientSettings -> (Connection -> IO a) -> IO a rrunTCPClient cfg app = bracket (N.getSocketFamilyTCP (N.getHost cfg) (N.getPort cfg) (N.getAddrFamily cfg)) - (\r -> catch (N.sClose $ fst r) (\(e :: SomeException) -> return ())) + (\r -> catch (N.sClose $ fst r) (\(_ :: SomeException) -> return ())) (\(s, _) -> app Connection { read = Just <$> N.safeRecv s (N.getReadBufferSize cfg) , write = N.sendAll s @@ -140,7 +140,6 @@ tunnelingClientP cfg@TunnelSettings{..} app conn = do onError = flip catch (\(e :: SomeException) -> return . Left . WebsocketError $ show e) - tlsClientP :: TunnelSettings -> (Connection -> IO (Either Error ())) -> (Connection -> IO (Either Error ())) tlsClientP TunnelSettings{..} app conn = do let tlsSettings = NC.TLSSettingsSimple { NC.settingDisableCertificateValidation = True @@ -245,14 +244,14 @@ runClient cfg@TunnelSettings{..} = do handleError :: Either Error () -> IO () handleError (Right ()) = return () -handleError (Left err) = - case err of - 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 +handleError (Left errMsg) = + case errMsg of + ProxyConnectionError msg -> err "Cannot connect to the proxy" >> debugPP msg + ProxyForwardError msg -> err "Connection not allowed by the proxy" >> debugPP msg + TunnelError msg -> err "Cannot establish the connection to the server" >> debugPP msg + LocalServerError msg -> err "Cannot create the localServer, port already binded ?" >> debugPP msg + WebsocketError msg -> err "Cannot establish websocket connection with the server" >> debugPP msg + TlsError msg -> err "Cannot do tls handshake with the server" >> debugPP msg Other msg -> debugPP msg where @@ -382,6 +381,3 @@ fromPath path = let rets = BC.split '/' . BC.drop 1 $ path prt' <- readMay . BC.unpack $ prt :: Maybe Int proto <- readMay . toUpper . BC.unpack $ protocol :: Maybe Protocol return (proto, h, prt') - -info = LOG.infoM "wstunnel" -debug = LOG.debugM "wstunnel"