diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 + } diff --git a/src/Credentials.hs b/src/Credentials.hs new file mode 100644 --- /dev/null +++ b/src/Credentials.hs @@ -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-----" diff --git a/src/HttpProxy.hs b/src/HttpProxy.hs new file mode 100644 --- /dev/null +++ b/src/HttpProxy.hs @@ -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) diff --git a/src/Logger.hs b/src/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Logger.hs @@ -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 diff --git a/src/Protocols.hs b/src/Protocols.hs new file mode 100644 --- /dev/null +++ b/src/Protocols.hs @@ -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 diff --git a/src/Socks5.hs b/src/Socks5.hs new file mode 100644 --- /dev/null +++ b/src/Socks5.hs @@ -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) + + + + + + + + -- diff --git a/src/Tunnel.hs b/src/Tunnel.hs new file mode 100644 --- /dev/null +++ b/src/Tunnel.hs @@ -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) diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -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) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 + diff --git a/wstunnel.cabal b/wstunnel.cabal new file mode 100644 --- /dev/null +++ b/wstunnel.cabal @@ -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