wstunnel (empty) → 0.1.0.0
raw patch · 11 files changed
+1547/−0 lines, 11 filesdep +asyncdep +basedep +base64-bytestring
Dependencies added: async, base, base64-bytestring, binary, bytestring, classy-prelude, cmdargs, connection, hslogger, hspec, iproute, mtl, network, network-conduit-tls, streaming-commons, text, unordered-containers, websockets, wstunnel
Files
- LICENSE +30/−0
- app/Main.hs +272/−0
- src/Credentials.hs +44/−0
- src/HttpProxy.hs +80/−0
- src/Logger.hs +26/−0
- src/Protocols.hs +134/−0
- src/Socks5.hs +230/−0
- src/Tunnel.hs +292/−0
- src/Types.hs +144/−0
- test/Spec.hs +217/−0
- wstunnel.cabal +78/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ app/Main.hs view
@@ -0,0 +1,272 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-cse #-}++module Main where++import ClassyPrelude hiding (getArgs, head)+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 Control.Concurrent.Async as Async++data WsTunnel = WsTunnel+ { localToRemote :: [String]+ -- , remoteToLocal :: String+ , dynamicToRemote :: String+ , wsTunnelServer :: String+ , udpMode :: Bool+ , udpTimeout :: Int+ , proxy :: String+ , soMark :: Int+ , serverMode :: Bool+ , restrictTo :: String+ , verbose :: Bool+ , quiet :: Bool+ , pathPrefix :: String+ } deriving (Show, Data, Typeable)++data WsServerInfo = WsServerInfo+ { useTls :: !Bool+ , host :: !String+ , port :: !Int+ } deriving (Show)++data TunnelInfo = TunnelInfo+ { localHost :: !String+ , localPort :: !Int+ , remoteHost :: !String+ , remotePort :: !Int+ } deriving (Show)+++cmdLine :: WsTunnel+cmdLine = WsTunnel+ { localToRemote = def &= explicit &= name "L" &= name "localToRemote" &= typ "[BIND:]PORT:HOST:PORT"+ &= help "Listen on local and forwards traffic from remote. Can be used multiple time" &= groupname "Client options"+ -- , remoteToLocal = def &= explicit &= name "R" &= name "RemoteToLocal" &= typ "[BIND:]PORT:HOST:PORT"+ -- &= help "Listen on remote and forward traffic from local"+ , dynamicToRemote= def &= explicit &= name "D" &= name "dynamicToRemote" &= typ "[BIND:]PORT"+ &= help "Listen on local and dynamically (with socks5 proxy) forwards traffic from remote" &= groupname "Client options"+ , udpMode = def &= explicit &= name "u" &= name "udp" &= help "forward UDP traffic instead of TCP" &= groupname "Client options"+ , udpTimeout = def &= explicit &= name "udpTimeoutSec" &= help "When using udp forwarding, timeout in seconds after when the tunnel connection is closed. Default 30sec, -1 means no timeout"+ &= groupname "Client options"+ , pathPrefix = def &= explicit &= name "upgradePathPrefix"+ &= help "Use a specific prefix that will show up in the http path in the upgrade request. Useful if you need to route requests server side but don't have vhosts"+ &= typ "String" &= groupname "Client options"+ , proxy = def &= explicit &= name "p" &= name "httpProxy"+ &= help "If set, will use this proxy to connect to the server" &= typ "USER:PASS@HOST:PORT"+ , 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"+ , wsTunnelServer = def &= argPos 0 &= typ "ws[s]://wstunnelServer[:port]"++ , 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"+ &= 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"+ )+ &= helpArg [explicit, name "help", name "h"]+++toPort :: String -> Int+toPort "stdio" = 0+toPort str = case readMay str of+ Just por -> por+ Nothing -> error $ "Invalid port number `" ++ str ++ "`"++parseServerInfo :: WsServerInfo -> String -> WsServerInfo+parseServerInfo server [] = server+parseServerInfo server ('w':'s':':':'/':'/':xs) = parseServerInfo (server {Main.useTls = False, Main.port = 80}) xs+parseServerInfo server ('w':'s':'s':':':'/':'/':xs) = parseServerInfo (server {Main.useTls = True, Main.port = 443}) xs+parseServerInfo server (':':prt) = server {Main.port = toPort prt}+parseServerInfo server ('[':xs) = parseServerInfo (server {Main.host = BC.unpack . BC.init . fst $ BC.spanEnd (/= ']') (BC.pack xs)}) (BC.unpack . snd $ BC.spanEnd (/= ']') (BC.pack xs))+parseServerInfo server hostPath = parseServerInfo (server {Main.host = takeWhile (/= ':') hostPath}) (dropWhile (/= ':') hostPath)+++parseTunnelInfo :: String -> TunnelInfo+parseTunnelInfo strr = do+ let str = BC.pack strr+ if BC.count ']' str <= 0 then+ mkIPv4 $ BC.unpack <$> BC.split ':' str+ else+ mkIPv6 $ str++ where+ mkIPv4 [lPort, host, rPort] = TunnelInfo {localHost = "127.0.0.1", Main.localPort = toPort lPort, remoteHost = host, remotePort = toPort rPort}+ mkIPv4 [bind,lPort, host,rPort] = TunnelInfo {localHost = bind, Main.localPort = toPort lPort, remoteHost = host, remotePort = toPort rPort}+ mkIPv4 _ = error $ "Invalid tunneling information `" ++ strr ++ "`, please use format [BIND:]PORT:HOST:PORT"++ mkIPv6 str = do+ let !(localHost, remain) = if BC.head str == '[' then+ BC.drop 2 <$> BC.span (/= ']') (BC.drop 1 str)+ else if BC.head str < '0' || BC.head str > '9' then+ BC.drop 1 <$> BC.span (/= ':') str+ else+ ("", str)++ let (remain, rPort) = first BC.init . BC.spanEnd (/= ':') $ str+ let (remain2, remoteHost) = if BC.last remain == ']' then+ first (BC.init . BC.init) $ BC.spanEnd (/= '[') (BC.init remain)+ else+ first BC.init $ BC.spanEnd (/= ':') remain++ let (remain3, lPort) = BC.spanEnd (/= ':') $ remain2+ if remain3 == mempty then+ TunnelInfo {localHost = "::1", Main.localPort = toPort (BC.unpack lPort), remoteHost = (BC.unpack remoteHost), remotePort = toPort (BC.unpack rPort)}+ else+ let localHost = BC.filter (\c -> c /= '[' && c /= ']') (BC.init remain3) in+ TunnelInfo {localHost = BC.unpack localHost, Main.localPort = toPort (BC.unpack lPort), remoteHost = (BC.unpack remoteHost), remotePort = toPort (BC.unpack rPort)}++++parseRestrictTo :: String -> ((ByteString, Int) -> Bool)+parseRestrictTo "" = const True+parseRestrictTo str = let !(!h, !p) = fromMaybe (error "Invalid Parameter restart") parse+ in (\(!hst, !port) -> hst == h && port == p)+ where+ parse = do+ 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)++parseProxyInfo :: String -> Maybe ProxySettings+parseProxyInfo str = do+ let ret = BC.split ':' (BC.pack str)++ guard (length ret >= 2)+ if length ret == 3+ then do+ portNumber <- readMay $ BC.unpack $ ret !! 2 :: Maybe Int+ let cred = (head ret, head (BC.split '@' (ret !! 1)))+ let h = BC.split '@' (ret !! 1) !! 1+ return $ ProxySettings (BC.unpack h) (fromIntegral portNumber) (Just cred)+ else if length ret == 2+ then do+ portNumber <- readMay . BC.unpack $ ret !! 1 :: Maybe Int+ return $ ProxySettings (BC.unpack $ head ret) (fromIntegral portNumber) Nothing+ else Nothing+++main :: IO ()+main = do+ args <- getArgs+ cfg' <- if null args then withArgs ["--help"] (cmdArgs cmdLine) else cmdArgs cmdLine+ let cfg = cfg' { pathPrefix = if pathPrefix cfg' == mempty then "wstunnel" else pathPrefix cfg'+ , Main.udpTimeout = if Main.udpTimeout cfg' == 0 then 30 * 10^(6 :: Int)+ else if Main.udpTimeout cfg' == -1 then -1+ else Main.udpTimeout cfg' * 10^(6:: Int)+ }++ let serverInfo = parseServerInfo (WsServerInfo False "" 0) (wsTunnelServer cfg)+ Logger.init (if quiet cfg then Logger.QUIET+ else if verbose cfg+ then Logger.VERBOSE+ else Logger.NORMAL)++ _ <- writeIORef sO_MARK_Value (soMark cfg)+ runApp cfg serverInfo+ putStrLn "Goodbye !"+ return ()+++runApp :: WsTunnel -> WsServerInfo -> IO ()+runApp cfg serverInfo+ -- 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)++ -- -L localToRemote tunnels+ | not . null $ localToRemote cfg = do+ let tunnelInfos = parseTunnelInfo <$> localToRemote cfg+ let tunnelSettings = tunnelInfos >>= \tunnelInfo -> + if Main.localPort tunnelInfo == 0 then [toStdioLocalToRemoteTunnelSetting cfg serverInfo tunnelInfo] + else if udpMode cfg then [toUdpLocalToRemoteTunnelSetting cfg serverInfo tunnelInfo] + else [toTcpLocalToRemoteTunnelSetting cfg serverInfo tunnelInfo]+ Async.mapConcurrently_ runClient tunnelSettings++ -- -D dynamicToRemote tunnels+ | not . null $ dynamicToRemote cfg = do+ let tunnelSetting = toDynamicTunnelSetting cfg serverInfo . parseTunnelInfo $ (dynamicToRemote cfg) ++ ":127.0.0.1:1212"+ runClient tunnelSetting++ | otherwise = do+ putStrLn "Cannot parse correctly the command line. Please fill an issue"++ where+ toStdioLocalToRemoteTunnelSetting cfg serverInfo (TunnelInfo lHost lPort rHost rPort) =+ TunnelSettings {+ localBind = lHost+ , Types.localPort = fromIntegral lPort+ , serverHost = Main.host serverInfo+ , serverPort = fromIntegral $ Main.port serverInfo+ , destHost = rHost+ , destPort = fromIntegral rPort+ , Types.useTls = Main.useTls serverInfo+ , protocol = STDIO+ , proxySetting = parseProxyInfo (proxy cfg)+ , useSocks = False+ , upgradePrefix = pathPrefix cfg+ , udpTimeout = Main.udpTimeout cfg+ }++ toTcpLocalToRemoteTunnelSetting cfg serverInfo (TunnelInfo lHost lPort rHost rPort) =+ TunnelSettings {+ localBind = lHost+ , Types.localPort = fromIntegral lPort+ , serverHost = Main.host serverInfo+ , serverPort = fromIntegral $ Main.port serverInfo+ , destHost = rHost+ , destPort = fromIntegral rPort+ , Types.useTls = Main.useTls serverInfo+ , protocol = TCP+ , proxySetting = parseProxyInfo (proxy cfg)+ , useSocks = False+ , upgradePrefix = pathPrefix cfg+ , udpTimeout = Main.udpTimeout cfg+ }++ toUdpLocalToRemoteTunnelSetting cfg serverInfo (TunnelInfo lHost lPort rHost rPort) =+ TunnelSettings {+ localBind = lHost+ , Types.localPort = fromIntegral lPort+ , serverHost = Main.host serverInfo+ , serverPort = fromIntegral $ Main.port serverInfo+ , destHost = rHost+ , destPort = fromIntegral rPort+ , Types.useTls = Main.useTls serverInfo+ , protocol = UDP+ , proxySetting = parseProxyInfo (proxy cfg)+ , useSocks = False+ , upgradePrefix = pathPrefix cfg+ , udpTimeout = Main.udpTimeout cfg+ }++ toDynamicTunnelSetting cfg serverInfo (TunnelInfo lHost lPort _ _) =+ TunnelSettings {+ localBind = lHost+ , Types.localPort = fromIntegral lPort+ , serverHost = Main.host serverInfo+ , serverPort = fromIntegral $ Main.port serverInfo+ , destHost = ""+ , destPort = 0+ , Types.useTls = Main.useTls serverInfo+ , protocol = SOCKS5+ , proxySetting = parseProxyInfo (proxy cfg)+ , useSocks = True+ , upgradePrefix = pathPrefix cfg+ , udpTimeout = Main.udpTimeout cfg+ }
+ src/Credentials.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}++module Credentials where++import ClassyPrelude++-- openssl genrsa 1024 > host.key+-- openssl req -new -x509 -nodes -sha1 -days 9999 -key host.key > host.cert+key :: ByteString+key = "-----BEGIN RSA PRIVATE KEY-----\n" <>+ "MIICXAIBAAKBgQCzP4dg89HDyWfe2k5KD8RdFNh7G9Rla8cjMtE6ccBx84B1WbG5\n" <>+ "ziRpaCvsTdYSVRwcbR07+4oqR302vyCBZ+r/djpYuTyUTNRYC9+h4wdPGXKhKpeR\n" <>+ "z1BNVKCsQ6qcBFLDb7l6ra+g36DMQuLcJvLx7LX7elW5w9M/I4FFfV+aeQIDAQAB\n" <>+ "AoGAD744qa9AcS2zTcNmtOKFoJdAHC/pi67XoqPH9JYhDOESGzxxe5w7XnajxPFh\n" <>+ "J+MJwQVkV+xTyjrVKIXI2RTDct6tdG2jDcH6P0Xf3I6BPBhvw9pLlisUHTqVxFpV\n" <>+ "nAoUiyWYZcEiF37IT/uwdRAlhqgitjK7rhZfkM2XNpMb3gECQQDp1qpVk4y5smFE\n" <>+ "IfZPr94paBZLRD9EwHnxZVM27oR0C95YIgcc12mNchYxIOW4szKwyaUCZLafiojA\n" <>+ "+anojR/RAkEAxDxnn/3qWmHGYrs/1wrT9FEoC6XZGBHboQIcYYGihK/64P8E19WF\n" <>+ "BmexzLZdlilieT0ATM5I9zOULSiZ4H/iKQJAC46PdpFHSDo3sm1XRhL0EOnTCD9E\n" <>+ "PTqiDDssxK8/HpkjkQmFfnhrABGeZSkyEVHR9IjSve6KVBI9tgPg0NyAsQJAEZB+\n" <>+ "jfmCQnjB8xBjlHHpqtKgzPoZRmhCylSQCcI6s7m0sPLikhcQgxRA+9vO4KPvpn5p\n" <>+ "SnakXUwGlUwvCcMokQJBAKw9U5H88GyB4qWhnwhustnVnVg/bzkYGpryjDx6mLYh\n" <>+ "eMPlv6aH546XMJbQ6fRe3tgMBBgOD1QN9WvKuFQo2K4=\n" <>+ "-----END RSA PRIVATE KEY-----"++certificate :: ByteString+certificate = "-----BEGIN CERTIFICATE-----\n" <>+ "MIIC5DCCAk2gAwIBAgIUBjMRJwxK4qoz64RFZcHQorbfrucwDQYJKoZIhvcNAQEF\n" <>+ "BQAwgYMxCzAJBgNVBAYTAkZSMRIwEAYDVQQIDAlBcXVpdGFpbmUxETAPBgNVBAcM\n" <>+ "CEd1ZXRoYXJ5MRMwEQYDVQQKDApFcmViZSBDb3JwMRIwEAYDVQQLDAlIYWNrIEhh\n" <>+ "Y2sxDjAMBgNVBAMMBWVyZWJlMRQwEgYJKoZIhvcNAQkBFgVlcmViZTAeFw0xOTEw\n" <>+ "MjQxMTM5NDVaFw00NzAzMTAxMTM5NDVaMIGDMQswCQYDVQQGEwJGUjESMBAGA1UE\n" <>+ "CAwJQXF1aXRhaW5lMREwDwYDVQQHDAhHdWV0aGFyeTETMBEGA1UECgwKRXJlYmUg\n" <>+ "Q29ycDESMBAGA1UECwwJSGFjayBIYWNrMQ4wDAYDVQQDDAVlcmViZTEUMBIGCSqG\n" <>+ "SIb3DQEJARYFZXJlYmUwgZ8wDQYJKoZIhvcNAQEBBQADgY0AMIGJAoGBALM/h2Dz\n" <>+ "0cPJZ97aTkoPxF0U2Hsb1GVrxyMy0TpxwHHzgHVZsbnOJGloK+xN1hJVHBxtHTv7\n" <>+ "iipHfTa/IIFn6v92Oli5PJRM1FgL36HjB08ZcqEql5HPUE1UoKxDqpwEUsNvuXqt\n" <>+ "r6DfoMxC4twm8vHstft6VbnD0z8jgUV9X5p5AgMBAAGjUzBRMB0GA1UdDgQWBBRC\n" <>+ "8mpWQdiOTYy+GBxUQ9vssIloMTAfBgNVHSMEGDAWgBRC8mpWQdiOTYy+GBxUQ9vs\n" <>+ "sIloMTAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBBQUAA4GBAGkUgoDLmb5e\n" <>+ "SWPR61QEByPkIji4DytJfzUeJBZKyRQSMGC08yUAPAmFbIt1jqBO6nTum3TjlV6S\n" <>+ "7bv3kEhkgTdoKHyWtBitnR2wg90Ybm4K6OKLnoKZgvl1IZ6x8LCqI1RVIQMHaUkL\n" <>+ "L3+otPXxpH1LXGnikOlwLkF2LPhRmX9X\n" <>+ "-----END CERTIFICATE-----"
+ src/HttpProxy.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE ViewPatterns #-}++module HttpProxy () where++++import ClassyPrelude+import qualified Data.ByteString.Char8 as BC++import Control.Monad.Except+import qualified Data.Conduit.Network.TLS as N+import qualified Data.Streaming.Network as N++import qualified Data.ByteString.Base64 as B64+import Network.Socket (HostName, PortNumber)+import qualified Network.Socket as N hiding (recv, recvFrom, send,+ sendTo)+import qualified Network.Socket.ByteString as N++import Logger+import Types+++data HttpProxySettings = HttpProxySettings+ { proxyHost :: HostName+ , proxyPort :: PortNumber+ , credentials :: Maybe (ByteString, ByteString)+ } deriving (Show)+++httpProxyConnection :: MonadError Error m => HttpProxySettings -> (HostName, PortNumber) -> (Connection -> IO (m a)) -> IO (m a)+httpProxyConnection HttpProxySettings{..} (host, port) app = onError $ do+ debug $ "Opening tcp connection to proxy " <> show proxyHost <> ":" <> show proxyPort++ ret <- N.runTCPClient (N.clientSettingsTCP (fromIntegral proxyPort) (fromString proxyHost)) $ \conn' -> do+ let conn = toConnection conn'+ _ <- sendConnectRequest conn++ -- wait 10sec for a reply before giving up+ let _10sec = 1000000 * 10+ responseM <- timeout _10sec $ readConnectResponse mempty conn++ case responseM of+ Just (isAuthorized -> True) -> app conn+ Just response -> return . throwError $ ProxyForwardError (BC.unpack response)+ Nothing -> return . throwError $ ProxyForwardError ("No response from the proxy after "+ <> show (_10sec `div` 1000000) <> "sec" )++ debug $ "Closing tcp connection to proxy " <> show proxyHost <> ":" <> show proxyPort+ return ret++ where+ credentialsToHeader :: (ByteString, ByteString) -> ByteString+ credentialsToHeader (user, password) = "Proxy-Authorization: Basic " <> B64.encode (user <> ":" <> password) <> "\r\n"++ 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"+ <> maybe mempty credentialsToHeader credentials+ <> "\r\n"++ readConnectResponse :: ByteString -> Connection -> IO ByteString+ readConnectResponse buff conn = do+ responseM <- read conn+ case responseM of+ Nothing -> return buff+ Just response -> if "\r\n\r\n" `isInfixOf` response+ then return $ buff <> response+ else readConnectResponse (buff <> response) conn++ isAuthorized :: ByteString -> Bool+ isAuthorized response = " 200 " `isInfixOf` response++ onError f = catch f $ \(e :: SomeException) -> return $+ if (take 10 (show e) == "user error")+ then throwError $ ProxyConnectionError (show e)+ else throwError $ ProxyConnectionError ("Unknown Error :: " <> show e)
+ src/Logger.hs view
@@ -0,0 +1,26 @@+module Logger where++import ClassyPrelude+import Network.Socket (HostName, PortNumber)+import qualified System.Log.Logger as LOG+++data Verbosity = QUIET | VERBOSE | NORMAL++init :: Verbosity -> IO ()+init lvl = LOG.updateGlobalLogger "wstunnel" $ case lvl of+ QUIET -> LOG.setLevel LOG.ERROR+ VERBOSE -> LOG.setLevel LOG.DEBUG+ NORMAL -> LOG.setLevel LOG.INFO++toStr :: (HostName, PortNumber) -> String+toStr (host, port) = fromString host <> ":" <> show port++err :: String -> IO()+err msg = LOG.errorM "wstunnel" $ "ERROR :: " <> msg++info :: String -> IO()+info = LOG.infoM "wstunnel"++debug :: String -> IO()+debug msg = LOG.debugM "wstunnel" $ "DEBUG :: " <> msg
+ src/Protocols.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Protocols where++import ClassyPrelude+import Control.Concurrent (forkIO)+import qualified Data.HashMap.Strict as H+import System.IO hiding (hSetBuffering, hGetBuffering)++import qualified Data.ByteString.Char8 as BC++import qualified Data.Streaming.Network as N++import Network.Socket (HostName, PortNumber)+import qualified Network.Socket as N hiding (recv, recvFrom, send,+ sendTo)+import qualified Network.Socket.ByteString as N++import Data.Binary (decode, encode)++import Logger+import qualified Socks5+import Types+++runSTDIOServer :: (StdioAppData -> IO ()) -> IO ()+runSTDIOServer app = do+ stdin_old_buffering <- hGetBuffering stdin+ stdout_old_buffering <- hGetBuffering stdout++ hSetBuffering stdin (BlockBuffering (Just 512))+ hSetBuffering stdout NoBuffering++ void $ forever $ app StdioAppData++ hSetBuffering stdin stdin_old_buffering+ hSetBuffering stdout stdout_old_buffering+ info $ "CLOSE stdio server"++runTCPServer :: (HostName, PortNumber) -> (N.AppData -> IO ()) -> IO ()+runTCPServer endPoint@(host, port) app = do+ info $ "WAIT for tcp connection on " <> toStr endPoint+ let srvSet = N.setReadBufferSize defaultRecvBufferSize $ N.serverSettingsTCP (fromIntegral port) (fromString host)+ void $ N.runTCPServer srvSet app+ info $ "CLOSE tcp server on " <> toStr endPoint++runTCPClient :: (HostName, PortNumber) -> (N.AppData -> IO ()) -> IO ()+runTCPClient endPoint@(host, port) app = do+ info $ "CONNECTING to " <> toStr endPoint+ let srvSet = N.setReadBufferSize defaultRecvBufferSize $ N.clientSettingsTCP (fromIntegral port) (BC.pack host)+ void $ N.runTCPClient srvSet app+ info $ "CLOSE connection to " <> toStr endPoint+++runUDPClient :: (HostName, PortNumber) -> (UdpAppData -> IO ()) -> IO ()+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+ , appSem = sem+ , appRead = fst <$> N.recvFrom socket 4096+ , appWrite = \payload -> void $ N.sendAllTo socket payload (N.addrAddress addrInfo)+ }++ info $ "CLOSE udp connection to " <> toStr endPoint+++runUDPServer :: (HostName, PortNumber) -> Int -> (UdpAppData -> IO ()) -> IO ()+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)+ info $ "CLOSE udp server" <> toStr endPoint++ where+ addNewClient :: IORef (H.HashMap N.SockAddr UdpAppData) -> N.Socket -> N.SockAddr -> ByteString -> IO UdpAppData+ addNewClient clientsCtx socket addr payload = do+ sem <- newMVar payload+ let appData = UdpAppData { appAddr = addr+ , appSem = sem+ , appRead = takeMVar sem+ , appWrite = \payload' -> void $ N.sendAllTo socket payload' addr+ }+ void $ atomicModifyIORef' clientsCtx (\clients -> (H.insert addr appData clients, ()))+ return appData++ removeClient :: IORef (H.HashMap N.SockAddr UdpAppData) -> UdpAppData -> IO ()+ removeClient clientsCtx clientCtx = do+ void $ atomicModifyIORef' clientsCtx (\clients -> (H.delete (appAddr clientCtx) clients, ()))+ debug "TIMEOUT connection"++ pushDataToClient :: UdpAppData -> ByteString -> IO ()+ pushDataToClient clientCtx payload = putMVar (appSem clientCtx) payload+ `catch` (\(_ :: SomeException) -> debug $ "DROP udp packet, client thread dead")+ -- If we are unlucky the client's thread died before we had the time to push the data on a already full mutex+ -- 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++ runEventLoop :: IORef (H.HashMap N.SockAddr UdpAppData) -> N.Socket -> IO ()+ runEventLoop clientsCtx socket = forever $ do+ (payload, addr) <- N.recvFrom socket 4096+ clientCtx <- H.lookup addr <$> readIORef clientsCtx++ case clientCtx of+ Just clientCtx' -> pushDataToClient clientCtx' payload+ _ -> void . forkIO $ bracket+ (addNewClient clientsCtx socket addr payload)+ (removeClient clientsCtx)+ (void . timeout cnxTimeout . app)+++runSocks5Server :: Socks5.ServerSettings -> TunnelSettings -> (TunnelSettings -> N.AppData -> IO()) -> IO ()+runSocks5Server socksSettings@Socks5.ServerSettings{..} cfg inner = do+ info $ "Starting socks5 proxy " <> show socksSettings++ N.runTCPServer (N.serverSettingsTCP (fromIntegral listenOn) (fromString bindOn)) $ \cnx -> do+ -- Get the auth request and response with a no Auth+ authRequest <- decode . fromStrict <$> N.appRead cnx :: IO Socks5.RequestAuth+ debug $ "Socks5 authentification request " <> show authRequest+ let responseAuth = encode $ Socks5.ResponseAuth (fromIntegral Socks5.socksVersion) Socks5.NoAuth+ N.appWrite cnx (toStrict responseAuth)++ -- Get the request and update dynamically the tunnel config+ request <- decode . fromStrict <$> N.appRead cnx :: IO Socks5.Request+ debug $ "Socks5 forward request " <> show request+ let responseRequest = encode $ Socks5.Response (fromIntegral Socks5.socksVersion) Socks5.SUCCEEDED (Socks5.addr request) (Socks5.port request)+ let cfg' = cfg { destHost = Socks5.addr request, destPort = Socks5.port request }+ N.appWrite cnx (toStrict responseRequest)++ inner cfg' cnx++ info $ "Closing socks5 proxy " <> show socksSettings
+ src/Socks5.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StrictData #-}++module Socks5 where+++import ClassyPrelude+import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import qualified Data.ByteString as BC+import qualified Data.ByteString.Char8 as BC8+import Data.Either+import qualified Data.Text as T+import qualified Data.Text.Encoding as E+import Network.Socket (HostAddress, HostName, PortNumber)+import Numeric (showHex)++import Control.Monad.Except (MonadError)+import qualified Data.Streaming.Network as N+++socksVersion :: Word8+socksVersion = 0x05++data AuthMethod = NoAuth+ | GSSAPI+ | Login+ | Reserved+ | NotAllowed+ deriving (Show, Read)++data RequestAuth = RequestAuth+ { version :: Int+ , methods :: Vector AuthMethod+ } deriving (Show, Read)++data ResponseAuth = ResponseAuth+ { version :: Int+ , method :: AuthMethod+ } deriving (Show, Read)++instance Binary ResponseAuth where+ put ResponseAuth{..} = putWord8 (fromIntegral version) >> put method+ get = ResponseAuth <$> (fromIntegral <$> getWord8)+ <*> get+++instance Binary AuthMethod where+ put val = case val of+ NoAuth -> putWord8 0x00+ GSSAPI -> putWord8 0x01+ Login -> putWord8 0x02+ NotAllowed -> putWord8 0xFF+ _ {- Reserverd -} -> putWord8 0x03++ get = do+ method <- getWord8+ return $ case method of+ 0x00 -> NoAuth+ 0x01 -> GSSAPI+ 0x02 -> Login+ 0xFF -> NotAllowed+ _ -> Reserved+++instance Binary RequestAuth where+ put RequestAuth{..} = do+ putWord8 (fromIntegral version)+ putWord8 (fromIntegral $ length methods)+ sequence_ (put <$> methods)+ -- Check length <= 255++ get = do+ version <- fromIntegral <$> getWord8+ guard (version == 0x05)+ nbMethods <- fromIntegral <$> getWord8+ guard (nbMethods > 0 && nbMethods <= 0xFF)+ methods <- replicateM nbMethods get+ return $ RequestAuth version methods++++data Request = Request+ { version :: Int+ , command :: Command+ , addr :: HostName+ , port :: PortNumber+ } deriving (Show)++data Command = Connect+ | Bind+ | UdpAssociate+ deriving (Show, Eq, Enum, Bounded)+++instance Binary Command where+ put = putWord8 . (+1) . fromIntegral . fromEnum++ get = do+ cmd <- (\val -> fromIntegral val - 1) <$> getWord8+ guard $ cmd >= fromEnum (minBound :: Command) && cmd <= fromEnum (maxBound :: Command)++ return .toEnum $ cmd+++instance Binary Request where+ put Request{..} = do+ putWord8 (fromIntegral version)+ put command+ putWord8 0x00 -- RESERVED+ putWord8 0x03 -- DOMAINNAME+ let host = BC8.pack addr+ putWord8 (fromIntegral . length $ host)+ traverse_ put host+ putWord16be (fromIntegral port)++++ get = do+ version <- fromIntegral <$> getWord8+ guard (version == 5)+ cmd <- get :: Get Command+ _ <- getWord8 -- RESERVED++ opCode <- fromIntegral <$> getWord8 -- Addr type, we support only ipv4 and domainame+ guard (opCode == 0x03 || opCode == 0x01) -- DOMAINNAME OR IPV4++ host <- if opCode == 0x03+ then do+ length <- fromIntegral <$> getWord8+ host <- either (const T.empty) id . E.decodeUtf8' <$> replicateM length getWord8+ return host+ else do+ ipv4 <- replicateM 4 getWord8 :: Get [Word8]+ let ipv4Str = T.intercalate "." $ fmap (tshow . fromEnum) ipv4+ return ipv4Str++ guard (not $ null host)+ port <- fromIntegral <$> getWord16be++ return Request+ { version = version+ , command = cmd+ , addr = unpack host+ , port = port+ }++++toHex :: LByteString -> String+toHex = foldr showHex "" . unpack++data Response = Response+ { version :: Int+ , returnCode :: RetCode+ , serverAddr :: HostName+ , serverPort :: PortNumber+ } deriving (Show)++data RetCode = SUCCEEDED+ | GENERAL_FAILURE+ | NOT_ALLOWED+ | NO_NETWORK+ | HOST_UNREACHABLE+ | CONNECTION_REFUSED+ | TTL_EXPIRED+ | UNSUPPORTED_COMMAND+ | UNSUPPORTED_ADDRESS_TYPE+ | UNASSIGNED+ deriving (Show, Eq, Enum, Bounded)++instance Binary RetCode where+ put = putWord8 . fromIntegral . fromEnum+ get = toEnum . min maxBound . fromIntegral <$> getWord8+++instance Binary Response where+ put Response{..} = do+ putWord8 socksVersion+ put returnCode+ putWord8 0x00 -- Reserved+ putWord8 0x03 -- DOMAINNAME+ let host = BC8.pack serverAddr+ putWord8 (fromIntegral . length $ host)+ traverse_ put host+ putWord16be (fromIntegral serverPort)+++ get = do+ version <- fromIntegral <$> getWord8+ guard(version == fromIntegral socksVersion)+ ret <- toEnum . min maxBound . fromIntegral <$> getWord8+ getWord8 -- RESERVED+ opCode <- fromIntegral <$> getWord8 -- Type+ guard(opCode == 0x03)+ length <- fromIntegral <$> getWord8+ host <- either (const T.empty) id . E.decodeUtf8' <$> replicateM length getWord8+ guard (not $ null host)++ port <- getWord16be++ return Response+ { version = version+ , returnCode = ret+ , serverAddr = unpack host+ , serverPort = fromIntegral port+ }++++data ServerSettings = ServerSettings+ { listenOn :: PortNumber+ , bindOn :: HostName+ -- , onAuthentification :: (MonadIO m, MonadError IOException m) => RequestAuth -> m ResponseAuth+ -- , onRequest :: (MonadIO m, MonadError IOException m) => Request -> m Response+ } deriving (Show)++++++++ --
+ src/Tunnel.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+++module Tunnel+ ( runClient+ , runServer+ , rrunTCPClient+ ) where++import ClassyPrelude+import Data.Maybe (fromJust)++import qualified Data.ByteString.Char8 as BC++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 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+import qualified Network.WebSockets.Stream as WS++import Control.Monad.Except+import qualified Network.Connection as NC+import System.IO (IOMode (ReadWriteMode))++import qualified Data.ByteString.Base64 as B64++import Types+import Protocols+import qualified Socks5+import Logger+import qualified Credentials++++rrunTCPClient :: N.ClientSettings -> (Connection -> IO a) -> IO a+rrunTCPClient cfg app = bracket+ (do+ (s,addr) <- N.getSocketFamilyTCP (N.getHost cfg) (N.getPort cfg) (N.getAddrFamily cfg)+ N.setSocketOption s N.RecvBuffer defaultRecvBufferSize+ N.setSocketOption s N.SendBuffer defaultSendBufferSize+ 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)+ )+ (\r -> catch (N.close $ fst r) (\(_ :: SomeException) -> return ()))+ (\(s, _) -> app Connection+ { read = Just <$> N.safeRecv s defaultRecvBufferSize+ , write = N.sendAll s+ , close = N.close s+ , rawConnection = Just s+ })++--+-- Pipes+--+tunnelingClientP :: MonadError Error m => TunnelSettings -> (Connection -> IO (m ())) -> (Connection -> IO (m ()))+tunnelingClientP cfg@TunnelSettings{..} app conn = onError $ do+ debug "Oppening Websocket stream"++ stream <- connectionToStream conn+ ret <- WS.runClientWithStream stream serverHost (toPath cfg) WS.defaultConnectionOptions [] run++ debug "Closing Websocket stream"+ return ret++ 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 30+ app (toConnection cnx)+++tlsClientP :: MonadError Error m => TunnelSettings -> (Connection -> IO (m ())) -> (Connection -> IO (m ()))+tlsClientP TunnelSettings{..} app conn = onError $ do+ debug "Doing tls Handshake"++ context <- NC.initConnectionContext+ let socket = fromJust $ rawConnection conn+ h <- N.socketToHandle socket ReadWriteMode++ connection <- NC.connectFromHandle context h connectionParams+ ret <- app (toConnection connection) `finally` hClose h++ debug "Closing TLS"+ return ret++ where+ onError = flip catch (\(e :: SomeException) -> return . throwError . TlsError $ show e)+ tlsSettings = NC.TLSSettingsSimple { NC.settingDisableCertificateValidation = True+ , NC.settingDisableSession = False+ , NC.settingUseServerName = False+ }+ connectionParams = NC.ConnectionParams { NC.connectionHostname = serverHost+ , NC.connectionPort = serverPort+ , NC.connectionUseSecure = Just tlsSettings+ , NC.connectionUseSocks = Nothing+ }+++--+-- Connectors+--+tcpConnection :: MonadError Error m => TunnelSettings -> (Connection -> IO (m ())) -> IO (m ())+tcpConnection TunnelSettings{..} app = onError $ do+ debug $ "Oppening tcp connection to " <> fromString serverHost <> ":" <> show (fromIntegral serverPort :: Int)++ ret <- rrunTCPClient (N.clientSettingsTCP (fromIntegral serverPort) (fromString serverHost)) app++ debug $ "Closing tcp connection to " <> fromString serverHost <> ":" <> show (fromIntegral serverPort :: Int)+ return ret++ where+ onError = flip catch (\(e :: SomeException) -> return $ when (take 10 (show e) == "user error") (throwError $ TunnelError $ show e))++++httpProxyConnection :: MonadError Error m => TunnelSettings -> (Connection -> IO (m ())) -> IO (m ())+httpProxyConnection TunnelSettings{..} app = onError $ do+ let settings = fromJust proxySetting+ debug $ "Oppening tcp connection to proxy " <> show settings++ ret <- rrunTCPClient (N.clientSettingsTCP (fromIntegral (port settings)) (BC.pack $ host settings)) $ \conn -> do+ _ <- sendConnectRequest settings conn+ responseM <- timeout (1000000 * 10) $ readConnectResponse mempty conn+ let response = fromMaybe "No response of the proxy after 10s" responseM++ if isAuthorized response+ then app conn+ else return . throwError . ProxyForwardError $ BC.unpack response++ debug $ "Closing tcp connection to proxy " <> show settings+ return ret++ where+ credentialsToHeader (user, password) = "Proxy-Authorization: Basic " <> B64.encode (user <> ":" <> password) <> "\r\n"+ sendConnectRequest settings h = write h $ "CONNECT " <> fromString serverHost <> ":" <> fromString (show serverPort) <> " HTTP/1.0\r\n"+ <> "Host: " <> fromString serverHost <> ":" <> fromString (show serverPort) <> "\r\n"+ <> maybe mempty credentialsToHeader (credentials settings)+ <> "\r\n"++ readConnectResponse buff conn = do+ response <- fromJust <$> read conn+ if "\r\n\r\n" `BC.isInfixOf` response+ then return $ buff <> response+ else readConnectResponse (buff <> response) conn++ isAuthorized response = " 200 " `BC.isInfixOf` response++ onError = flip catch (\(e :: SomeException) -> return $ when (take 10 (show e) == "user error") (throwError $ ProxyConnectionError $ show e))++--+-- Client+--+runClient :: TunnelSettings -> IO ()+runClient cfg@TunnelSettings{..} = do+ let withEndPoint = if isJust proxySetting then httpProxyConnection cfg else tcpConnection cfg+ let doTlsIf tlsNeeded app = if tlsNeeded then tlsClientP cfg app else app+ let withTunnel cfg' app = withEndPoint (doTlsIf useTls . tunnelingClientP cfg' $ app)++ let app cfg' localH = do+ ret <- withTunnel cfg' $ \remoteH -> do+ ret <- remoteH <==> toConnection localH+ info $ "CLOSE tunnel :: " <> show cfg'+ return ret++ handleError ret++ case protocol of+ UDP -> runUDPServer (localBind, localPort) udpTimeout (app cfg)+ TCP -> runTCPServer (localBind, localPort) (app cfg)+ STDIO -> runSTDIOServer (app cfg)+ SOCKS5 -> runSocks5Server (Socks5.ServerSettings localPort localBind) cfg app+++++--+-- Server+--+runTlsTunnelingServer :: (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()+runTlsTunnelingServer 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 ->+ runApp sClient WS.defaultConnectionOptions (serverEventLoop (N.appSockAddr sClient) isAllowed)++ info "SHUTDOWN server"++ 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)+ bracket (WS.makePendingConnectionFromStream stream opts)+ (\conn -> catch (WS.close $ WS.pendingStream conn) (\(_ :: SomeException) -> return ()))+ app++runTunnelingServer :: (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()+runTunnelingServer endPoint@(host, port) isAllowed = do+ info $ "WAIT for connection on " <> toStr endPoint++ 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)+ runApp stream WS.defaultConnectionOptions (serverEventLoop (N.appSockAddr sClient) isAllowed)++ info "CLOSE server"++ where+ runApp :: WS.Stream -> WS.ConnectionOptions -> WS.ServerApp -> IO ()+ runApp socket opts = bracket (WS.makePendingConnectionFromStream socket opts)+ (\conn -> catch (WS.close $ WS.pendingStream conn) (\(_ :: SomeException) -> return ()))++serverEventLoop :: N.SockAddr -> ((ByteString, Int) -> Bool) -> WS.PendingConnection -> IO ()+serverEventLoop sClient isAllowed pendingConn = do+ let path = fromPath . WS.requestPath $ WS.pendingRequest pendingConn+ let forwardedFor = filter (\(header,val) -> header == "x-forwarded-for") $ WS.requestHeaders $ WS.pendingRequest pendingConn+ info $ "NEW incoming connection from " <> show sClient <> " " <> show forwardedFor+ case path of+ Nothing -> info "Rejecting connection" >> WS.rejectRequest pendingConn "Invalid tunneling information"+ Just (!proto, !rhost, !rport) ->+ if not $ isAllowed (rhost, rport)+ then do+ info "Rejecting tunneling"+ WS.rejectRequest pendingConn "Restriction is on, You cannot request this tunneling"+ else do+ conn <- WS.acceptRequest pendingConn+ 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)+++runServer :: Bool -> (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()+runServer useTLS = if useTLS then runTlsTunnelingServer else runTunnelingServer+++++--+-- Commons+--+toPath :: TunnelSettings -> String+toPath TunnelSettings{..} = "/" <> upgradePrefix <> "/"+ <> toLower (show $ if protocol == UDP then UDP else TCP)+ <> "/" <> destHost <> "/" <> show destPort++fromPath :: ByteString -> Maybe (Protocol, ByteString, Int)+fromPath path = let rets = BC.split '/' . BC.drop 1 $ path+ in do+ guard (length rets == 4)+ let [_, protocol, h, prt] = rets+ prt' <- readMay . BC.unpack $ prt :: Maybe Int+ proto <- readMay . toUpper . BC.unpack $ protocol :: Maybe Protocol+ return (proto, h, prt')++handleError :: Either Error () -> IO ()+handleError (Right ()) = return ()+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+ debugPP msg = debug $ "====\n" <> msg <> "\n===="++myTry :: MonadError Error m => IO a -> IO (m ())+myTry f = either (\(e :: SomeException) -> throwError . Other $ show e) (const $ return ()) <$> try f++(<==>) :: Connection -> Connection -> IO (Either Error ())+(<==>) hTunnel hOther =+ myTry $ race_ (propagateReads hTunnel hOther) (propagateWrites hTunnel hOther)++propagateReads :: Connection -> Connection -> IO ()+propagateReads hTunnel hOther = forever $ read hTunnel >>= write hOther . fromJust+++propagateWrites :: Connection -> Connection -> IO ()+propagateWrites hTunnel hOther = do+ payload <- fromJust <$> read hOther+ unless (null payload) (write hTunnel payload >> propagateWrites hTunnel hOther)
+ src/Types.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StrictData #-}++module Types where+++import ClassyPrelude+import Data.Maybe+import System.IO (stdin, stdout)+import Data.ByteString (hGetSome, hPutStr)++import qualified Data.Streaming.Network as N+import qualified Network.Connection as NC+import Network.Socket (HostName, PortNumber(..))+import Network.Socket.Internal (PortNumber(..))+import qualified Network.Socket as N hiding (recv, recvFrom,+ send, sendTo)+import qualified Network.Socket.ByteString as N++import qualified Network.WebSockets.Connection as WS+import System.IO.Unsafe (unsafeDupablePerformIO)++deriving instance Generic PortNumber+deriving instance Hashable PortNumber+deriving instance Generic N.SockAddr+deriving instance Hashable N.SockAddr++{-# NOINLINE defaultRecvBufferSize #-} +defaultRecvBufferSize :: Int+defaultRecvBufferSize = unsafeDupablePerformIO $+ bracket (N.socket N.AF_INET N.Stream 0) N.close (\sock -> N.getSocketOption sock N.RecvBuffer)++defaultSendBufferSize :: Int+defaultSendBufferSize = defaultRecvBufferSize++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++{-# NOINLINE sO_MARK_Value #-}+sO_MARK_Value :: IORef Int+sO_MARK_Value = unsafeDupablePerformIO $ (newIORef 0)++data Protocol = UDP | TCP | STDIO | SOCKS5 deriving (Show, Read, Eq)++data StdioAppData = StdioAppData++data UdpAppData = UdpAppData+ { appAddr :: N.SockAddr+ , appSem :: MVar ByteString+ , appRead :: IO ByteString+ , appWrite :: ByteString -> IO ()+ }++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)++data ProxySettings = ProxySettings+ { host :: HostName+ , port :: PortNumber+ , credentials :: Maybe (ByteString, ByteString)+ } deriving (Show)++data TunnelSettings = TunnelSettings+ { proxySetting :: Maybe ProxySettings+ , localBind :: HostName+ , localPort :: PortNumber+ , serverHost :: HostName+ , serverPort :: PortNumber+ , destHost :: HostName+ , destPort :: PortNumber+ , protocol :: Protocol+ , useTls :: Bool+ , useSocks :: Bool+ , upgradePrefix :: String+ , udpTimeout :: Int+ }++instance Show TunnelSettings where+ show TunnelSettings{..} = localBind <> ":" <> show localPort+ <> (if isNothing proxySetting+ then mempty+ else " <==PROXY==> " <> host (fromJust proxySetting) <> ":" <> (show . port $ fromJust proxySetting)+ )+ <> " <==" <> (if useTls then "WSS" else "WS") <> "==> "+ <> serverHost <> ":" <> show serverPort+ <> " <==" <> show (if protocol == SOCKS5 then TCP else protocol) <> "==> " <> destHost <> ":" <> show destPort+++data Connection = Connection+ { read :: IO (Maybe ByteString)+ , write :: ByteString -> IO ()+ , close :: IO ()+ , rawConnection :: Maybe N.Socket+ }++class ToConnection a where+ toConnection :: a -> Connection++instance ToConnection StdioAppData where+ toConnection conn = Connection { read = Just <$> hGetSome stdin 512+ , write = hPutStr stdout+ , close = return ()+ , rawConnection = Nothing+ }++instance ToConnection WS.Connection where+ toConnection conn = Connection { read = Just <$> WS.receiveData conn+ , write = WS.sendBinaryData conn+ , close = WS.sendClose conn (mempty :: LByteString)+ , rawConnection = Nothing+ }++instance ToConnection N.AppData where+ toConnection conn = Connection { read = Just <$> N.appRead conn+ , write = N.appWrite conn+ , close = N.appCloseConnection conn+ , rawConnection = Nothing+ }++instance ToConnection UdpAppData where+ toConnection conn = Connection { read = Just <$> appRead conn+ , write = appWrite conn+ , close = return ()+ , rawConnection = Nothing+ }++instance ToConnection NC.Connection where+ toConnection conn = Connection { read = Just <$> NC.connectionGetChunk conn+ , write = NC.connectionPut conn+ , close = NC.connectionClose conn+ , rawConnection = Nothing+ }++data Error = ProxyConnectionError String+ | ProxyForwardError String+ | LocalServerError String+ | TunnelError String+ | WebsocketError String+ | TlsError String+ | Other String+ deriving (Show)
+ test/Spec.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++import ClassyPrelude hiding (getArgs, head)+import qualified Logger+import qualified Network.Socket as N hiding (recv, recvFrom,+ send, sendTo)+import qualified Network.Socket.ByteString as N+import qualified Data.Conduit.Network.TLS as N+import qualified Data.Streaming.Network as N++import Control.Concurrent.Async as Async+import Data.ByteString (hPutStr)+import Control.Concurrent (threadDelay)+import Test.Hspec+import Data.Binary (decode, encode)+++import Tunnel+import Types+import Protocols+import qualified Socks5 as Socks5++testTCPLocalToRemote :: Bool -> IO ()+testTCPLocalToRemote useTLS = do++ Logger.init Logger.VERBOSE++ success <- newIORef False+ let needle = "toto"++ -- SERVER+ let serverPort = 8080+ let serverWithoutTLS = runServer useTLS ("0.0.0.0", serverPort) (const True)++ -- CLIENT+ let tunnelSetting = TunnelSettings {+ localBind = "localhost"+ , Types.localPort = fromIntegral 8081+ , serverHost = "localhost"+ , serverPort = fromIntegral serverPort+ , destHost = "localhost"+ , destPort = fromIntegral 8082+ , Types.useTls = useTLS+ , protocol = TCP+ , proxySetting = Nothing+ , useSocks = False+ , upgradePrefix = "wstunnel"+ , udpTimeout = 0+ }+ let client = runClient tunnelSetting++ -- Remote STUB ENDPOINT+ let remoteSetting = N.serverSettingsTCP (fromIntegral 8082) "localhost"+ let remoteServerEndpoint = N.runTCPServer remoteSetting $ (\sClient -> do N.appRead sClient >>= \payload -> if payload == needle then writeIORef success True else writeIORef success False)++ -- local STUB ENDPOINT+ let localClient = rrunTCPClient (N.clientSettingsTCP (fromIntegral 8081) "localhost") (\cnx -> write cnx needle)++ putStrLn "Starting remote endpoint"+ Async.async $ timeout (10 * 10^6) remoteServerEndpoint+ threadDelay (1 * 10^6)++ putStrLn "Starting wstunnel server"+ Async.async $ timeout (10 * 10^6) serverWithoutTLS+ threadDelay (1 * 10^6)++ putStrLn "Starting wstunnel client"+ Async.async $ timeout (10 * 10^6) client+ threadDelay (1 * 10^6)++ putStrLn "Writing data to the pipeline"+ _ <- localClient+ threadDelay (7 * 10^6)++ isSuccess <- readIORef success+ if not isSuccess + then throwString "Tunnel is not working"+ else putStrLn "Success"++testUDPLocalToRemote :: Bool -> IO ()+testUDPLocalToRemote useTLS = do++ Logger.init Logger.VERBOSE++ success <- newIORef False+ let needle = "toto"++ -- SERVER+ let serverPort = 8080+ let serverWithoutTLS = runServer useTLS ("0.0.0.0", serverPort) (const True)++ -- CLIENT+ let tunnelSetting = TunnelSettings {+ localBind = "localhost"+ , Types.localPort = fromIntegral 8081+ , serverHost = "localhost"+ , serverPort = fromIntegral serverPort+ , destHost = "localhost"+ , destPort = fromIntegral 8082+ , Types.useTls = useTLS+ , protocol = UDP+ , proxySetting = Nothing+ , useSocks = False+ , upgradePrefix = "wstunnel"+ , udpTimeout = -1+ }+ let client = runClient tunnelSetting++ -- Remote STUB ENDPOINT+ let remoteServerEndpoint = runUDPServer ("localhost", fromIntegral 8082) (-1) $ (\sClient -> do read (toConnection sClient) >>= \(Just payload) -> if payload == needle then writeIORef success True else writeIORef success False)++ -- local STUB ENDPOINT+ let localClient = runUDPClient ("localhost", fromIntegral 8081) (\cnx -> write (toConnection cnx) needle)++ putStrLn "Starting remote endpoint"+ Async.async $ timeout (10 * 10^6) remoteServerEndpoint+ threadDelay (1 * 10^6)++ putStrLn "Starting wstunnel server"+ Async.async $ timeout (10 * 10^6) serverWithoutTLS+ threadDelay (1 * 10^6)++ putStrLn "Starting wstunnel client"+ Async.async $ timeout (10 * 10^6) client+ threadDelay (1 * 10^6)++ putStrLn "Writing data to the pipeline"+ _ <- localClient+ threadDelay (7 * 10^6)++ isSuccess <- readIORef success+ if not isSuccess + then throwString "Tunnel is not working"+ else putStrLn "Success"++testSocks5Tunneling :: Bool -> IO ()+testSocks5Tunneling useTLS = do++ Logger.init Logger.VERBOSE++ success <- newIORef False+ let needle = "toto"++ -- SERVER+ let serverPort = 8080+ let serverWithoutTLS = runServer useTLS ("0.0.0.0", serverPort) (const True)++ -- CLIENT+ let tunnelSetting = TunnelSettings {+ localBind = "localhost"+ , Types.localPort = fromIntegral 8081+ , serverHost = "localhost"+ , serverPort = fromIntegral serverPort+ , destHost = ""+ , destPort = 0+ , Types.useTls = useTLS+ , protocol = SOCKS5+ , proxySetting = Nothing+ , useSocks = False+ , upgradePrefix = "wstunnel"+ , udpTimeout = -1+ }+ let client = runClient tunnelSetting++ -- Remote STUB ENDPOINT+ let remoteSetting = N.serverSettingsTCP (fromIntegral 8082) "localhost"+ let remoteServerEndpoint = N.runTCPServer remoteSetting $ (\sClient -> do N.appRead sClient >>= \payload -> if payload == needle then writeIORef success True else writeIORef success False)+++ putStrLn "Starting remote endpoint"+ Async.async $ timeout (10 * 10^6) remoteServerEndpoint+ threadDelay (1 * 10^6)++ putStrLn "Starting wstunnel server"+ Async.async $ timeout (10 * 10^6) serverWithoutTLS+ threadDelay (1 * 10^6)++ putStrLn "Starting wstunnel client"+ Async.async $ timeout (10 * 10^6) client+ threadDelay (1 * 10^6)++ putStrLn "Writing data to the pipeline"+ rrunTCPClient (N.clientSettingsTCP (fromIntegral 8081) "localhost") $ \cnx -> do + write cnx (toStrict . encode $ Socks5.RequestAuth (fromIntegral Socks5.socksVersion) (fromList [Socks5.NoAuth]))+ _ <- read cnx + write cnx (toStrict . encode $ Socks5.Request (fromIntegral Socks5.socksVersion) Socks5.Connect "localhost" 8082)+ _ <- read cnx + write cnx needle++ threadDelay (7 * 10^6)++ isSuccess <- readIORef success+ if not isSuccess + then throwString "Tunnel is not working"+ else putStrLn "Success"++main :: IO ()+main = hspec $ do+ describe "Socks5 tunneling" $ do+ it "Testing socks5 -D without TLS" $ do+ testSocks5Tunneling False+ it "Testing socks5 -D with TLS" $ do+ testSocks5Tunneling True++ describe "TCP tunneling" $ do+ it "Testing TCP -L without TLS" $ do+ testTCPLocalToRemote False + it "Testing TCP -L with TLS" $ do+ testTCPLocalToRemote True++ describe "UDP tunneling" $ do+ it "Testing UDP -L without TLS" $ do+ testUDPLocalToRemote False+ it "Testing UDP -L with TLS" $ do+ testUDPLocalToRemote True+
+ wstunnel.cabal view
@@ -0,0 +1,78 @@+name: wstunnel+version: 0.1.0.0+synopsis: Initial project template from stack+description: For more information regarding wstunnel, please refer to README.md+homepage: https://github.com/githubuser/wstunnel#readme+license: BSD3+license-file: LICENSE+author: Author name here+maintainer: example@example.com+copyright: 2016 Author name here+category: Web+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Tunnel, Protocols, Types, Logger, Socks5, Credentials, HttpProxy+ default-extensions: NoImplicitPrelude, ScopedTypeVariables, BangPatterns, RecordWildCards+ build-depends: async+ , base >= 4.5 && < 5+ , base64-bytestring >= 1.0+ , binary >= 0.7+ , bytestring+ , classy-prelude+ , connection+ , hslogger+ , mtl+ , network+ , network-conduit-tls+ , streaming-commons+ , text >= 1.2.2.1+ , unordered-containers+ , websockets >= 0.12.4.0+ , iproute++ default-language: Haskell2010++test-suite wstunnel-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ default-extensions: NoImplicitPrelude, ScopedTypeVariables, BangPatterns, RecordWildCards+ build-depends: base >= 4.5 && < 5+ , async + , text >= 1.2.2.1+ , classy-prelude+ , bytestring+ , network+ , network-conduit-tls+ , streaming-commons+ , wstunnel+ , hspec+ , binary+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/githubuser/wstunnel++executable wstunnel+ hs-source-dirs: app+ main-is: Main.hs+ default-extensions: NoImplicitPrelude, ScopedTypeVariables, BangPatterns, RecordWildCards+ ghc-options: -threaded+ -O3+ -rtsopts "-with-rtsopts=-N -qb -qg"+ build-depends: base >= 4.5 && < 5+ , bytestring+ , classy-prelude+ , cmdargs+ , hslogger+ , text >= 1.2.2.1+ , async+ , wstunnel++ default-language: Haskell2010