wstunnel 0.4.1.0 → 0.5.0.0
raw patch · 7 files changed
+66/−48 lines, 7 filesdep ~network
Dependency ranges changed: network
Files
- app/Main.hs +25/−9
- src/HttpProxy.hs +2/−2
- src/Protocols.hs +14/−6
- src/Socks5.hs +3/−13
- src/Tunnel.hs +16/−10
- src/Types.hs +4/−6
- wstunnel.cabal +2/−2
app/Main.hs view
@@ -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
src/HttpProxy.hs view
@@ -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)
src/Protocols.hs view
@@ -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 ()
src/Socks5.hs view
@@ -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)-------- --
src/Tunnel.hs view
@@ -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)
src/Types.hs view
@@ -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
wstunnel.cabal view
@@ -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