diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -10,13 +10,13 @@ import qualified Data.CaseInsensitive as CI import qualified Data.ByteString.Char8 as BC import Data.List (head, (!!)) -import Data.Maybe (fromMaybe) import System.Console.CmdArgs import System.Environment (getArgs, withArgs) import qualified Logger import Tunnel import Types +import Credentials import Control.Concurrent.Async as Async data WsTunnel = WsTunnel @@ -28,16 +28,19 @@ , udpTimeout :: Int , proxy :: String , soMark :: Int - , serverMode :: Bool - , restrictTo :: String , verbose :: Bool , quiet :: Bool , pathPrefix :: String , hostHeader :: String , tlsSNI :: String + , tlsVerifyCertificate :: Bool , websocketPingFrequencySec :: Int , wsTunnelCredentials :: String , customHeaders :: [String] + , serverMode :: Bool + , restrictTo :: String + , tlsCertificate :: FilePath + , tlsKey :: FilePath } deriving (Show, Data, Typeable) data WsServerInfo = WsServerInfo @@ -80,6 +83,8 @@ &= help "If set, add the custom string as host http header" &= typ "String" &= groupname "Client options" , tlsSNI = def &= explicit &= name "tlsSNI" &= groupname "Client options" &= help "If set, use custom string in the SNI during TLS handshake" &= typ "String" &= groupname "Client options" + , tlsVerifyCertificate = def &= explicit &= name "tlsVerifyCertificate" &= groupname "Client options" + &= help "Verify tls server certificate. Default to false" , soMark = def &= explicit &= name "soMark" &= help "(linux only) Mark network packet with SO_MARK sockoption with the specified value. You need to use {root, sudo, capabilities} to run wstunnel when using this option" &= typ "int" , websocketPingFrequencySec = def &= explicit &= name "websocketPingFrequencySec" @@ -88,15 +93,19 @@ , serverMode = def &= explicit &= name "server" &= help "Start a server that will forward traffic for you" &= groupname "Server options" - , restrictTo = def &= explicit &= name "r" &= name "restrictTo" + , restrictTo = def &= explicit &= name "r" &= name "restrictTo" &= groupname "Server options" &= help "Accept traffic to be forwarded only to this service" &= typ "HOST:PORT" + , tlsCertificate = def &= explicit &= name "tlsCertificate" &= groupname "Server options" + &= help "[optional] provide a custom tls certificate (.crt) that the server will use instead of the embeded one" &= typFile + , tlsKey = def &= explicit &= name "tlsKey" &= groupname "Server options" + &= help "[optional] provide a custom tls key (.key) that the server will use instead of the embeded one" &= typFile , verbose = def &= groupname "Common options" &= help "Print debug information" - , quiet = def &= help "Print only errors" + , quiet = def &= help "Print only errors" &= groupname "Common options" } &= summary ( "Use the websockets protocol to tunnel {TCP,UDP} traffic\n" ++ "wsTunnelClient <---> wsTunnelServer <---> RemoteHost\n" ++ "Use secure connection (wss://) to bypass proxies" ) - &= helpArg [explicit, name "help", name "h"] + &= helpArg [explicit, name "help", name "h", groupname "Common options"] toPort :: String -> Int @@ -159,7 +168,7 @@ let (host, port) = BC.spanEnd (/= ':') (BC.pack str) guard (host /= mempty) portNumber <- readMay . BC.unpack $ port :: Maybe Int - return $! (BC.filter (\c -> c /= '[' && c /= ']') (BC.init host), portNumber) + return (BC.filter (\c -> c /= '[' && c /= ']') (BC.init host), portNumber) parseProxyInfo :: String -> Maybe ProxySettings parseProxyInfo str = do @@ -212,7 +221,10 @@ -- server mode | serverMode cfg = do putStrLn $ "Starting server with opts " <> tshow serverInfo - runServer (Main.useTls serverInfo) (Main.host serverInfo, fromIntegral $ Main.port serverInfo) (parseRestrictTo $ restrictTo cfg) + key <- if Main.tlsKey cfg /= mempty then readFile (Main.tlsKey cfg) else return Credentials.key + certificate <- if Main.tlsCertificate cfg /= mempty then readFile (Main.tlsCertificate cfg) else return Credentials.certificate + let tls = if Main.useTls serverInfo then Just (certificate, key) else Nothing + runServer tls (Main.host serverInfo, fromIntegral $ Main.port serverInfo) (parseRestrictTo $ restrictTo cfg) -- -L localToRemote tunnels | not . null $ localToRemote cfg = do @@ -225,7 +237,7 @@ -- -D dynamicToRemote tunnels | not . null $ dynamicToRemote cfg = do - let tunnelSetting = toDynamicTunnelSetting cfg serverInfo . parseTunnelInfo $ (dynamicToRemote cfg) ++ ":127.0.0.1:1212" + let tunnelSetting = toDynamicTunnelSetting cfg serverInfo . parseTunnelInfo $ dynamicToRemote cfg ++ ":127.0.0.1:1212" runClient tunnelSetting | otherwise = do @@ -248,6 +260,7 @@ , upgradeCredentials = BC.pack $ wsTunnelCredentials cfg , udpTimeout = Main.udpTimeout cfg , tlsSNI = BC.pack $ Main.tlsSNI cfg + , tlsVerifyCertificate = Main.tlsVerifyCertificate cfg , hostHeader = BC.pack $ Main.hostHeader cfg , websocketPingFrequencySec = Main.websocketPingFrequencySec cfg , customHeaders = parseCustomHeader <$> Main.customHeaders cfg @@ -269,6 +282,7 @@ , upgradeCredentials = BC.pack $ wsTunnelCredentials cfg , udpTimeout = Main.udpTimeout cfg , tlsSNI = BC.pack $ Main.tlsSNI cfg + , tlsVerifyCertificate = Main.tlsVerifyCertificate cfg , hostHeader = BC.pack $ Main.hostHeader cfg , websocketPingFrequencySec = Main.websocketPingFrequencySec cfg , customHeaders = parseCustomHeader <$> Main.customHeaders cfg @@ -290,6 +304,7 @@ , upgradeCredentials = BC.pack $ wsTunnelCredentials cfg , udpTimeout = Main.udpTimeout cfg , tlsSNI = BC.pack $ Main.tlsSNI cfg + , tlsVerifyCertificate = Main.tlsVerifyCertificate cfg , hostHeader = BC.pack $ Main.hostHeader cfg , websocketPingFrequencySec = Main.websocketPingFrequencySec cfg , customHeaders = parseCustomHeader <$> Main.customHeaders cfg @@ -311,6 +326,7 @@ , upgradeCredentials = BC.pack $ wsTunnelCredentials cfg , udpTimeout = Main.udpTimeout cfg , tlsSNI = BC.pack $ Main.tlsSNI cfg + , tlsVerifyCertificate = Main.tlsVerifyCertificate cfg , hostHeader = BC.pack $ Main.hostHeader cfg , websocketPingFrequencySec = Main.websocketPingFrequencySec cfg , customHeaders = parseCustomHeader <$> Main.customHeaders cfg diff --git a/src/HttpProxy.hs b/src/HttpProxy.hs --- a/src/HttpProxy.hs +++ b/src/HttpProxy.hs @@ -58,7 +58,7 @@ sendConnectRequest :: Connection -> IO () sendConnectRequest h = write h $ "CONNECT " <> fromString host <> ":" <> fromString (show port) <> " HTTP/1.0\r\n" - <> "Host: " <> fromString host <> ":" <> (fromString $ show port) <> "\r\n" + <> "Host: " <> fromString host <> ":" <> fromString (show port) <> "\r\n" <> maybe mempty credentialsToHeader credentials <> "\r\n" @@ -75,6 +75,6 @@ isAuthorized response = " 200 " `isInfixOf` response onError f = catch f $ \(e :: SomeException) -> return $ - if (take 10 (show e) == "user error") + if take 10 (show e) == "user error" then throwError $ ProxyConnectionError (show e) else throwError $ ProxyConnectionError ("Unknown Error :: " <> show e) diff --git a/src/Protocols.hs b/src/Protocols.hs --- a/src/Protocols.hs +++ b/src/Protocols.hs @@ -4,7 +4,7 @@ module Protocols where import ClassyPrelude -import Control.Concurrent (forkIO) +import Control.Concurrent (forkFinally, threadDelay) import qualified Data.HashMap.Strict as H import System.IO hiding (hSetBuffering, hGetBuffering) @@ -71,7 +71,7 @@ runUDPServer endPoint@(host, port) cnxTimeout app = do info $ "WAIT for datagrames on " <> toStr endPoint clientsCtx <- newIORef mempty - void $ bracket (N.bindPortUDP (fromIntegral port) (fromString host)) N.close (runEventLoop clientsCtx) + void $ bracket (N.bindPortUDP (fromIntegral port) (fromString host)) N.close (forever . run clientsCtx) info $ "CLOSE udp server" <> toStr endPoint where @@ -98,6 +98,14 @@ -- and will leave us waiting forever for the mutex to empty. So catch the exeception and drop the message. -- Udp is not a reliable protocol so transmission failure should be handled by the application layer + -- We run the server inside another thread in order to avoid Haskell runtime sending to the main thread + -- the exception BlockedIndefinitelyOnMVar + -- We dont use also MVar to wait for the end of the thread to avoid also receiving this exception + run :: IORef (H.HashMap N.SockAddr UdpAppData) -> N.Socket -> IO () + run clientsCtx socket = do + _ <- forkFinally (runEventLoop clientsCtx socket) (\_ -> debug "UdpServer died") + threadDelay (maxBound :: Int) + runEventLoop :: IORef (H.HashMap N.SockAddr UdpAppData) -> N.Socket -> IO () runEventLoop clientsCtx socket = forever $ do (payload, addr) <- N.recvFrom socket 4096 @@ -105,10 +113,10 @@ case clientCtx of Just clientCtx' -> pushDataToClient clientCtx' payload - _ -> void . forkIO $ bracket - (addNewClient clientsCtx socket addr payload) - (removeClient clientsCtx) - (void . timeout cnxTimeout . app) + _ -> do + clientCtx <- addNewClient clientsCtx socket addr payload + _ <- forkFinally (void . timeout cnxTimeout $ app clientCtx) (\_ -> removeClient clientsCtx clientCtx) + return () runSocks5Server :: Socks5.ServerSettings -> TunnelSettings -> (TunnelSettings -> N.AppData -> IO()) -> IO () diff --git a/src/Socks5.hs b/src/Socks5.hs --- a/src/Socks5.hs +++ b/src/Socks5.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} @@ -73,7 +72,7 @@ put RequestAuth{..} = do putWord8 (fromIntegral version) putWord8 (fromIntegral $ length methods) - sequence_ (put <$> methods) + mapM_ put methods -- Check length <= 255 get = do @@ -134,8 +133,7 @@ host <- if opCode == 0x03 then do length <- fromIntegral <$> getWord8 - host <- either (const T.empty) id . E.decodeUtf8' <$> replicateM length getWord8 - return host + fromRight T.empty . E.decodeUtf8' <$> replicateM length getWord8 else do ipv4 <- replicateM 4 getWord8 :: Get [Word8] let ipv4Str = T.intercalate "." $ fmap (tshow . fromEnum) ipv4 @@ -200,7 +198,7 @@ opCode <- fromIntegral <$> getWord8 -- Type guard(opCode == 0x03) length <- fromIntegral <$> getWord8 - host <- either (const T.empty) id . E.decodeUtf8' <$> replicateM length getWord8 + host <- fromRight T.empty . E.decodeUtf8' <$> replicateM length getWord8 guard (not $ null host) port <- getWord16be @@ -220,11 +218,3 @@ -- , onAuthentification :: (MonadIO m, MonadError IOException m) => RequestAuth -> m ResponseAuth -- , onRequest :: (MonadIO m, MonadError IOException m) => Request -> m Response } deriving (Show) - - - - - - - - -- diff --git a/src/Tunnel.hs b/src/Tunnel.hs --- a/src/Tunnel.hs +++ b/src/Tunnel.hs @@ -20,6 +20,7 @@ import qualified Network.Socket as N hiding (recv, recvFrom, send, sendTo) import qualified Network.Socket.ByteString as N +import qualified Network.Socket.ByteString.Lazy as NL import qualified Network.WebSockets as WS import qualified Network.WebSockets.Connection as WS @@ -63,9 +64,9 @@ debug "Opening Websocket stream" stream <- connectionToStream conn - let authorization = if not (null upgradeCredentials) then [("Authorization", "Basic " <> B64.encode upgradeCredentials)] else [] + let authorization = ([("Authorization", "Basic " <> B64.encode upgradeCredentials) | not (null upgradeCredentials)]) let headers = authorization <> customHeaders - let hostname = if not (null hostHeader) then (BC.unpack hostHeader) else serverHost + let hostname = if not (null hostHeader) then BC.unpack hostHeader else serverHost ret <- WS.runClientWithStream stream hostname (toPath cfg) WS.defaultConnectionOptions headers run @@ -96,7 +97,7 @@ where onError = flip catch (\(e :: SomeException) -> return . throwError . TlsError $ show e) - tlsSettings = NC.TLSSettingsSimple { NC.settingDisableCertificateValidation = True + tlsSettings = NC.TLSSettingsSimple { NC.settingDisableCertificateValidation = not tlsVerifyCertificate , NC.settingDisableSession = False , NC.settingUseServerName = False } @@ -187,11 +188,11 @@ -- -- Server -- -runTlsTunnelingServer :: (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO () -runTlsTunnelingServer endPoint@(bindTo, portNumber) isAllowed = do +runTlsTunnelingServer :: (ByteString, ByteString) -> (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO () +runTlsTunnelingServer (tlsCert, tlsKey) endPoint@(bindTo, portNumber) isAllowed = do info $ "WAIT for TLS connection on " <> toStr endPoint - N.runTCPServerTLS (N.tlsConfigBS (fromString bindTo) (fromIntegral portNumber) Credentials.certificate Credentials.key) $ \sClient -> + N.runTCPServerTLS (N.tlsConfigBS (fromString bindTo) (fromIntegral portNumber) tlsCert tlsKey) $ \sClient -> runApp sClient WS.defaultConnectionOptions (serverEventLoop (N.appSockAddr sClient) isAllowed) info "SHUTDOWN server" @@ -199,7 +200,8 @@ where runApp :: N.AppData -> WS.ConnectionOptions -> WS.ServerApp -> IO () runApp appData opts app = do - stream <- WS.makeStream (N.appRead appData <&> \payload -> if payload == mempty then Nothing else Just payload) (N.appWrite appData . toStrict . fromJust) + let socket = fromJust $ N.appRawSocket appData + stream <- WS.makeStream (N.recv socket defaultRecvBufferSize <&> \payload -> if payload == mempty then Nothing else Just payload) (NL.sendAll socket . fromJust) bracket (WS.makePendingConnectionFromStream stream opts) (\conn -> catch (WS.close $ WS.pendingStream conn) (\(_ :: SomeException) -> return ())) app @@ -210,7 +212,8 @@ let srvSet = N.setReadBufferSize defaultRecvBufferSize $ N.serverSettingsTCP (fromIntegral port) (fromString host) void $ N.runTCPServer srvSet $ \sClient -> do - stream <- WS.makeStream (N.appRead sClient <&> \payload -> if payload == mempty then Nothing else Just payload) (N.appWrite sClient . toStrict . fromJust) + let socket = fromJust $ N.appRawSocket sClient + stream <- WS.makeStream (N.recv socket defaultRecvBufferSize <&> \payload -> if payload == mempty then Nothing else Just payload) (NL.sendAll socket . fromJust) runApp stream WS.defaultConnectionOptions (serverEventLoop (N.appSockAddr sClient) isAllowed) info "CLOSE server" @@ -237,10 +240,13 @@ case proto of UDP -> runUDPClient (BC.unpack rhost, fromIntegral rport) (\cnx -> void $ toConnection conn <==> toConnection cnx) TCP -> runTCPClient (BC.unpack rhost, fromIntegral rport) (\cnx -> void $ toConnection conn <==> toConnection cnx) + STDIO -> mempty + SOCKS5 -> mempty -runServer :: Bool -> (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO () -runServer useTLS = if useTLS then runTlsTunnelingServer else runTunnelingServer +runServer :: Maybe (ByteString, ByteString) -> (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO () +runServer Nothing = runTunnelingServer +runServer (Just (tlsCert, tlsKey)) = runTlsTunnelingServer (tlsCert, tlsKey) diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -15,10 +15,7 @@ import qualified Data.Streaming.Network as N import qualified Network.Connection as NC import Network.Socket (HostName, PortNumber) -import qualified Network.Socket as N hiding (recv, recvFrom, - send, sendTo) -import qualified Network.Socket.ByteString as N - +import qualified Network.Socket as N hiding (recv, recvFrom, send, sendTo) import qualified Network.WebSockets.Connection as WS import System.IO.Unsafe (unsafeDupablePerformIO) @@ -33,10 +30,10 @@ {-# NOINLINE defaultRecvBufferSize #-} defaultRecvBufferSize :: Int defaultRecvBufferSize = unsafeDupablePerformIO $ - bracket (N.socket N.AF_INET N.Stream 0) N.close (\sock -> N.getSocketOption sock N.RecvBuffer) + bracket (N.socket N.AF_INET N.Stream 0) N.close (\sock -> N.getSocketOption sock N.RecvBuffer) sO_MARK :: N.SocketOption -sO_MARK = N.CustomSockOpt (1, 36) -- https://elixir.bootlin.com/linux/latest/source/arch/alpha/include/uapi/asm/socket.h#L64 +sO_MARK = N.SockOpt 1 36 -- https://elixir.bootlin.com/linux/latest/source/arch/alpha/include/uapi/asm/socket.h#L64 {-# NOINLINE sO_MARK_Value #-} sO_MARK_Value :: IORef Int @@ -78,6 +75,7 @@ , upgradeCredentials :: ByteString , tlsSNI :: ByteString + , tlsVerifyCertificate :: Bool , hostHeader :: ByteString , udpTimeout :: Int , websocketPingFrequencySec :: Int diff --git a/wstunnel.cabal b/wstunnel.cabal --- a/wstunnel.cabal +++ b/wstunnel.cabal @@ -1,5 +1,5 @@ name: wstunnel -version: 0.4.1.0 +version: 0.5.0.0 synopsis: Tunneling program over websocket protocol description: For more information regarding wstunnel, please refer to README.md homepage: https://github.com/githubuser/wstunnel#readme @@ -26,7 +26,7 @@ , connection , hslogger , mtl - , network + , network >= 3.1.2 , network-conduit-tls , streaming-commons , text >= 1.2.2.1