Add http proxy authorization
This commit is contained in:
Erèbe
parent
15016cf330
commit
dce0372c4b
3 changed files with 52 additions and 26 deletions
42
app/Main.hs
42
app/Main.hs
|
|
@ -6,7 +6,8 @@ module Main where
|
|||
|
||||
import Tunnel
|
||||
|
||||
import ClassyPrelude (ByteString, guard, readMay)
|
||||
import ClassyPrelude (ByteString, guard, readMay,
|
||||
traceShowId)
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import Data.Maybe (fromMaybe)
|
||||
import System.Console.CmdArgs
|
||||
|
|
@ -48,7 +49,7 @@ cmdLine = WsTunnel
|
|||
-- &= help "Listen on remote and forward traffic from local"
|
||||
, udpMode = def &= explicit &= name "u" &= name "udp" &= help "forward UDP traffic instead of TCP"
|
||||
, proxy = def &= explicit &= name "p" &= name "httpProxy"
|
||||
&= help "If set, will use this proxy to connect to the server" &= typ "HOST:PORT"
|
||||
&= help "If set, will use this proxy to connect to the server" &= typ "USER:PASS@HOST:PORT"
|
||||
, wsTunnelServer = def &= argPos 0 &= typ "ws[s]://wstunnelServer[:port]"
|
||||
|
||||
, serverMode = def &= explicit &= name "server"
|
||||
|
|
@ -71,10 +72,10 @@ toPort str = case readMay str of
|
|||
|
||||
parseServerInfo :: WsServerInfo -> String -> WsServerInfo
|
||||
parseServerInfo server [] = server
|
||||
parseServerInfo server ('w':'s':':':'/':'/':xs) = parseServerInfo (server {Main.useTls = False, port = 80}) xs
|
||||
parseServerInfo server ('w':'s':'s':':':'/':'/':xs) = parseServerInfo (server {Main.useTls = True, port = 443}) xs
|
||||
parseServerInfo server (':':prt) = server {port = toPort prt}
|
||||
parseServerInfo server hostPath = parseServerInfo (server {host = takeWhile (/= ':') hostPath}) (dropWhile (/= ':') hostPath)
|
||||
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 hostPath = parseServerInfo (server {Main.host = takeWhile (/= ':') hostPath}) (dropWhile (/= ':') hostPath)
|
||||
|
||||
|
||||
parseTunnelInfo :: String -> TunnelInfo
|
||||
|
|
@ -96,12 +97,23 @@ parseRestrictTo str = let (!h, !p) = fromMaybe (error "Invalid Parameter restart
|
|||
portNumber <- readMay $ ret !! 1 :: Maybe Int
|
||||
return (BC.pack (head ret), portNumber)
|
||||
|
||||
parseProxyInfo :: String -> Maybe (String, Int)
|
||||
parseProxyInfo :: String -> Maybe ProxySettings
|
||||
parseProxyInfo str = do
|
||||
let ret = BC.unpack <$> BC.split ':' (BC.pack str)
|
||||
guard (length ret == 2)
|
||||
portNumber <- readMay $ ret !! 1 :: Maybe Int
|
||||
return (head ret, portNumber)
|
||||
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
|
||||
|
|
@ -118,18 +130,18 @@ main = do
|
|||
|
||||
if serverMode cfg
|
||||
then putStrLn ("Starting server with opts " ++ show serverInfo )
|
||||
>> runServer (Main.useTls serverInfo) (host serverInfo, fromIntegral $ port serverInfo) (parseRestrictTo $ restrictTo cfg)
|
||||
>> runServer (Main.useTls serverInfo) (Main.host serverInfo, fromIntegral $ Main.port serverInfo) (parseRestrictTo $ restrictTo cfg)
|
||||
else if not $ null (localToRemote cfg)
|
||||
then let (TunnelInfo lHost lPort rHost rPort) = parseTunnelInfo (localToRemote cfg)
|
||||
in runClient TunnelSettings { localBind = lHost
|
||||
, Tunnel.localPort = fromIntegral lPort
|
||||
, serverHost = host serverInfo
|
||||
, serverPort = fromIntegral $ port serverInfo
|
||||
, serverHost = Main.host serverInfo
|
||||
, serverPort = fromIntegral $ Main.port serverInfo
|
||||
, destHost = rHost
|
||||
, destPort = fromIntegral rPort
|
||||
, Tunnel.useTls = Main.useTls serverInfo
|
||||
, protocol = if udpMode cfg then UDP else TCP
|
||||
, proxySetting = (\(h, p) -> (h, fromIntegral p)) <$> parseProxyInfo (proxy cfg)
|
||||
, proxySetting = parseProxyInfo (proxy cfg)
|
||||
}
|
||||
else return ()
|
||||
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@ module Tunnel
|
|||
, runServer
|
||||
, TunnelSettings(..)
|
||||
, Protocol(..)
|
||||
, ProxySettings(..)
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
|
@ -36,10 +37,18 @@ import Protocols
|
|||
import System.IO (IOMode (ReadWriteMode))
|
||||
import System.Timeout
|
||||
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
|
||||
import Utils
|
||||
|
||||
data ProxySettings = ProxySettings
|
||||
{ host :: HostName
|
||||
, port :: PortNumber
|
||||
, credentials :: Maybe (ByteString, ByteString)
|
||||
} deriving (Show)
|
||||
|
||||
data TunnelSettings = TunnelSettings
|
||||
{ proxySetting :: Maybe (HostName, PortNumber)
|
||||
{ proxySetting :: Maybe ProxySettings
|
||||
, localBind :: HostName
|
||||
, localPort :: PortNumber
|
||||
, serverHost :: HostName
|
||||
|
|
@ -54,7 +63,7 @@ instance Show TunnelSettings where
|
|||
show TunnelSettings{..} = localBind <> ":" <> show localPort
|
||||
<> (if isNothing proxySetting
|
||||
then mempty
|
||||
else " <==PROXY==> " <> fst (fromJust proxySetting) <> ":" <> (show . snd . fromJust $ proxySetting)
|
||||
else " <==PROXY==> " <> host (fromJust proxySetting) <> ":" <> (show . port $ fromJust proxySetting)
|
||||
)
|
||||
<> " <==" <> (if useTls then "WSS" else "WS") <> "==> "
|
||||
<> serverHost <> ":" <> show serverPort
|
||||
|
|
@ -182,12 +191,13 @@ tcpConnection TunnelSettings{..} app = onError $ do
|
|||
|
||||
|
||||
|
||||
httpProxyConnection :: (HostName, PortNumber) -> TunnelSettings -> (Connection -> IO (Either Error ())) -> IO (Either Error ())
|
||||
httpProxyConnection endPoint@(host, port) TunnelSettings{..} app = onError $ do
|
||||
debug $ "Oppening tcp connection to proxy " <> toStr endPoint
|
||||
httpProxyConnection :: TunnelSettings -> (Connection -> IO (Either Error ())) -> IO (Either Error ())
|
||||
httpProxyConnection TunnelSettings{..} app = onError $ do
|
||||
let settings = fromJust proxySetting
|
||||
debug $ "Oppening tcp connection to proxy " <> show settings
|
||||
|
||||
ret <- rrunTCPClient (N.clientSettingsTCP (fromIntegral port) (fromString host)) $ \conn -> do
|
||||
_ <- sendConnectRequest conn
|
||||
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
|
||||
|
||||
|
|
@ -195,12 +205,15 @@ httpProxyConnection endPoint@(host, port) TunnelSettings{..} app = onError $ do
|
|||
then app conn
|
||||
else return . Left . ProxyForwardError $ BC.unpack response
|
||||
|
||||
debug $ "Closing tcp connection to proxy " <> fromString host <> ":" <> show (fromIntegral port :: Int)
|
||||
debug $ "Closing tcp connection to proxy " <> show settings
|
||||
return ret
|
||||
|
||||
where
|
||||
sendConnectRequest h = write h $ "CONNECT " <> fromString serverHost <> ":" <> fromString (show serverPort) <> " HTTP/1.0\r\n"
|
||||
<> "Host: " <> fromString serverHost <> ":" <> fromString (show serverPort) <> "\r\n\r\n"
|
||||
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
|
||||
|
|
@ -219,7 +232,7 @@ httpProxyConnection endPoint@(host, port) TunnelSettings{..} app = onError $ do
|
|||
--
|
||||
runClient :: TunnelSettings -> IO ()
|
||||
runClient cfg@TunnelSettings{..} = do
|
||||
let withEndPoint = if isJust proxySetting then httpProxyConnection (fromJust proxySetting) cfg else tcpConnection cfg
|
||||
let withEndPoint = if isJust proxySetting then httpProxyConnection cfg else tcpConnection cfg
|
||||
let doTlsIf tlsNeeded app = if tlsNeeded then tlsClientP cfg app else app
|
||||
let runTunnelClient = tunnelingClientP cfg
|
||||
let withTunnel app = withEndPoint (doTlsIf useTls . runTunnelClient $ app)
|
||||
|
|
|
|||
|
|
@ -27,6 +27,7 @@ library
|
|||
, network-conduit-tls
|
||||
, connection
|
||||
, hslogger
|
||||
, base64-bytestring >= 1.0
|
||||
|
||||
default-language: Haskell2010
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue