wstunnel 0.3.1.0 → 0.4.1.0
raw patch · 5 files changed
+29/−11 lines, 5 filesdep +case-insensitive
Dependencies added: case-insensitive
Files
- app/Main.hs +12/−0
- src/Tunnel.hs +5/−6
- src/Types.hs +2/−3
- test/Spec.hs +5/−0
- wstunnel.cabal +5/−2
app/Main.hs view
@@ -6,6 +6,8 @@ module Main where import ClassyPrelude hiding (getArgs, head)+import Data.CaseInsensitive ( CI )+import qualified Data.CaseInsensitive as CI import qualified Data.ByteString.Char8 as BC import Data.List (head, (!!)) import Data.Maybe (fromMaybe)@@ -35,6 +37,7 @@ , tlsSNI :: String , websocketPingFrequencySec :: Int , wsTunnelCredentials :: String+ , customHeaders :: [String] } deriving (Show, Data, Typeable) data WsServerInfo = WsServerInfo@@ -62,6 +65,8 @@ , 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"+ , customHeaders = def &= explicit &= name "H" &= name "customHeaders" &= help "Send custom headers in the upgrade request. Can be used multiple time"+ &= typ "\"HeaderName: HeaderValue\"" &= 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"@@ -173,7 +178,10 @@ return $ ProxySettings (BC.unpack $ head ret) (fromIntegral portNumber) Nothing else Nothing +parseCustomHeader :: String -> (CI ByteString, ByteString)+parseCustomHeader header = (CI.mk . BC.pack $ takeWhile (/= ':') header, BC.pack . dropWhile (\c -> c == ' ' || c == ':') $ (dropWhile (/= ':') header)) + main :: IO () main = do args <- getArgs@@ -242,6 +250,7 @@ , tlsSNI = BC.pack $ Main.tlsSNI cfg , hostHeader = BC.pack $ Main.hostHeader cfg , websocketPingFrequencySec = Main.websocketPingFrequencySec cfg+ , customHeaders = parseCustomHeader <$> Main.customHeaders cfg } toTcpLocalToRemoteTunnelSetting cfg serverInfo (TunnelInfo lHost lPort rHost rPort) =@@ -262,6 +271,7 @@ , tlsSNI = BC.pack $ Main.tlsSNI cfg , hostHeader = BC.pack $ Main.hostHeader cfg , websocketPingFrequencySec = Main.websocketPingFrequencySec cfg+ , customHeaders = parseCustomHeader <$> Main.customHeaders cfg } toUdpLocalToRemoteTunnelSetting cfg serverInfo (TunnelInfo lHost lPort rHost rPort) =@@ -282,6 +292,7 @@ , tlsSNI = BC.pack $ Main.tlsSNI cfg , hostHeader = BC.pack $ Main.hostHeader cfg , websocketPingFrequencySec = Main.websocketPingFrequencySec cfg+ , customHeaders = parseCustomHeader <$> Main.customHeaders cfg } toDynamicTunnelSetting cfg serverInfo (TunnelInfo lHost lPort _ _) =@@ -302,4 +313,5 @@ , tlsSNI = BC.pack $ Main.tlsSNI cfg , hostHeader = BC.pack $ Main.hostHeader cfg , websocketPingFrequencySec = Main.websocketPingFrequencySec cfg+ , customHeaders = parseCustomHeader <$> Main.customHeaders cfg }
src/Tunnel.hs view
@@ -43,8 +43,6 @@ 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)@@ -62,10 +60,11 @@ -- tunnelingClientP :: MonadError Error m => TunnelSettings -> (Connection -> IO (m ())) -> (Connection -> IO (m ())) tunnelingClientP cfg@TunnelSettings{..} app conn = onError $ do- debug "Oppening Websocket stream"+ debug "Opening Websocket stream" stream <- connectionToStream conn- let headers = if not (null upgradeCredentials) then [("Authorization", "Basic " <> B64.encode upgradeCredentials)] else []+ let authorization = if not (null upgradeCredentials) then [("Authorization", "Basic " <> B64.encode upgradeCredentials)] else []+ let headers = authorization <> customHeaders let hostname = if not (null hostHeader) then (BC.unpack hostHeader) else serverHost ret <- WS.runClientWithStream stream hostname (toPath cfg) WS.defaultConnectionOptions headers run@@ -113,7 +112,7 @@ -- 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)+ debug $ "Opening tcp connection to " <> fromString serverHost <> ":" <> show (fromIntegral serverPort :: Int) ret <- rrunTCPClient (N.clientSettingsTCP (fromIntegral serverPort) (fromString serverHost)) app @@ -128,7 +127,7 @@ 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+ debug $ "Opening tcp connection to proxy " <> show settings ret <- rrunTCPClient (N.clientSettingsTCP (fromIntegral (port settings)) (BC.pack $ host settings)) $ \conn -> do _ <- sendConnectRequest settings conn
src/Types.hs view
@@ -11,6 +11,7 @@ import System.IO (stdin, stdout) import Data.ByteString (hGetSome, hPutStr) +import Data.CaseInsensitive ( CI ) import qualified Data.Streaming.Network as N import qualified Network.Connection as NC import Network.Socket (HostName, PortNumber)@@ -34,9 +35,6 @@ 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 @@ -83,6 +81,7 @@ , hostHeader :: ByteString , udpTimeout :: Int , websocketPingFrequencySec :: Int+ , customHeaders :: [(CI ByteString, ByteString)] } instance Show TunnelSettings where
test/Spec.hs view
@@ -9,6 +9,8 @@ import qualified Data.Conduit.Network.TLS as N import qualified Data.Streaming.Network as N +import Data.CaseInsensitive ( CI )+import qualified Data.CaseInsensitive as CI import Control.Concurrent.Async as Async import Data.ByteString (hPutStr) import Control.Concurrent (threadDelay)@@ -51,6 +53,7 @@ , hostHeader = "toto.com" , tlsSNI = "toto.com" , websocketPingFrequencySec = 30+ , customHeaders = [(CI.mk "toto", "tata"), (CI.mk "titi", "tutu")] } let client = runClient tunnelSetting @@ -112,6 +115,7 @@ , hostHeader = "toto.com" , tlsSNI = "toto.com" , websocketPingFrequencySec = 30+ , customHeaders = [(CI.mk "toto", "tata"), (CI.mk "titi", "tutu")] } let client = runClient tunnelSetting @@ -172,6 +176,7 @@ , hostHeader = "toto.com" , tlsSNI = "toto.com" , websocketPingFrequencySec = 30+ , customHeaders = [(CI.mk "toto", "tata"), (CI.mk "titi", "tutu")] } let client = runClient tunnelSetting
wstunnel.cabal view
@@ -1,5 +1,5 @@ name: wstunnel-version: 0.3.1.0+version: 0.4.1.0 synopsis: Tunneling program over websocket protocol description: For more information regarding wstunnel, please refer to README.md homepage: https://github.com/githubuser/wstunnel#readme@@ -33,6 +33,7 @@ , unordered-containers , websockets >= 0.12.4.0 , iproute+ , case-insensitive default-language: Haskell2010 @@ -42,7 +43,7 @@ main-is: Spec.hs default-extensions: NoImplicitPrelude, ScopedTypeVariables, BangPatterns, RecordWildCards build-depends: base >= 4.5 && < 5- , async + , async , text >= 1.2.2.1 , classy-prelude , bytestring@@ -52,6 +53,7 @@ , wstunnel , hspec , binary+ , case-insensitive ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 @@ -74,5 +76,6 @@ , text >= 1.2.2.1 , async , wstunnel+ , case-insensitive default-language: Haskell2010