Test
This commit is contained in:
parent
8d33cf9698
commit
750aeedd6b
2 changed files with 18 additions and 7 deletions
|
@ -11,6 +11,7 @@ import qualified Data.ByteString.Char8 as BC
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import System.Console.CmdArgs
|
import System.Console.CmdArgs
|
||||||
import System.Environment (getArgs, withArgs)
|
import System.Environment (getArgs, withArgs)
|
||||||
|
import qualified System.Log.Logger as LOG
|
||||||
|
|
||||||
data WsTunnel = WsTunnel
|
data WsTunnel = WsTunnel
|
||||||
{ localToRemote :: String
|
{ localToRemote :: String
|
||||||
|
@ -105,6 +106,8 @@ main = do
|
||||||
cfg <- if null args then withArgs ["--help"] (cmdArgs cmdLine) else cmdArgs cmdLine
|
cfg <- if null args then withArgs ["--help"] (cmdArgs cmdLine) else cmdArgs cmdLine
|
||||||
|
|
||||||
let serverInfo = parseServerInfo (WsServerInfo False "" 0) (wsTunnelServer cfg)
|
let serverInfo = parseServerInfo (WsServerInfo False "" 0) (wsTunnelServer cfg)
|
||||||
|
LOG.updateGlobalLogger "wstunnel" (LOG.setLevel LOG.INFO)
|
||||||
|
|
||||||
|
|
||||||
if serverMode cfg
|
if serverMode cfg
|
||||||
then putStrLn ("Starting server with opts " ++ show serverInfo )
|
then putStrLn ("Starting server with opts " ++ show serverInfo )
|
||||||
|
|
|
@ -3,6 +3,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
|
||||||
module Tunnel
|
module Tunnel
|
||||||
( runClient
|
( runClient
|
||||||
|
@ -33,6 +34,7 @@ import Protocols
|
||||||
import System.IO (IOMode (ReadWriteMode))
|
import System.IO (IOMode (ReadWriteMode))
|
||||||
import System.Timeout
|
import System.Timeout
|
||||||
|
|
||||||
|
import qualified System.Log.Logger as LOG
|
||||||
|
|
||||||
|
|
||||||
data TunnelSettings = TunnelSettings
|
data TunnelSettings = TunnelSettings
|
||||||
|
@ -66,6 +68,10 @@ data Connection = Connection
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
data Error = ProxyConnectError String
|
||||||
|
| ProxyForwardError String
|
||||||
|
deriving (Show, Read)
|
||||||
|
|
||||||
class ToConnection a where
|
class ToConnection a where
|
||||||
toConnection :: a -> Connection
|
toConnection :: a -> Connection
|
||||||
|
|
||||||
|
@ -110,27 +116,29 @@ runTunnelingClientWith info@TunnelSettings{..} app conn = do
|
||||||
|
|
||||||
httpProxyConnection :: (HostName, PortNumber) -> TunnelSettings -> (Connection -> IO ()) -> IO ()
|
httpProxyConnection :: (HostName, PortNumber) -> TunnelSettings -> (Connection -> IO ()) -> IO ()
|
||||||
httpProxyConnection (host, port) TunnelSettings{..} app =
|
httpProxyConnection (host, port) TunnelSettings{..} app =
|
||||||
myTry $ N.runTCPClient (N.clientSettingsTCP (fromIntegral port) (fromString host)) $ \conn -> do
|
mcatch $ N.runTCPClient (N.clientSettingsTCP (fromIntegral port) (fromString host)) $ \conn -> myTry $ do
|
||||||
_ <- sendConnectRequest conn
|
_ <- sendConnectRequest conn
|
||||||
responseM <- timeout (1000000 * 10) $ readProxyResponse mempty conn
|
responseM <- timeout (1000000 * 10) $ readConnectResponse mempty conn
|
||||||
let response = fromMaybe "No response of the proxy aftre 10s" responseM
|
let response = fromMaybe "No response of the proxy after 10s" responseM
|
||||||
|
|
||||||
if isAuthorized response
|
if isAuthorized response
|
||||||
then app $ toConnection conn
|
then app $ toConnection conn
|
||||||
else putStrLn $ "Proxy refused the connection :: \n" <> fromString (BC.unpack response)
|
else LOG.errorM "wstunnel" $ "Proxy refused the connection :: \n===\n" <> fromString (BC.unpack response) <> "\n==="
|
||||||
|
|
||||||
where
|
where
|
||||||
sendConnectRequest h = N.appWrite h $ "CONNECT " <> fromString serverHost <> ":" <> fromString (show serverPort) <> " HTTP/1.0\r\n"
|
sendConnectRequest h = N.appWrite h $ "CONNECT " <> fromString serverHost <> ":" <> fromString (show serverPort) <> " HTTP/1.0\r\n"
|
||||||
<> "Host: " <> fromString serverHost <> ":" <> fromString (show serverPort) <> "\r\n\r\n"
|
<> "Host: " <> fromString serverHost <> ":" <> fromString (show serverPort) <> "\r\n\r\n"
|
||||||
|
|
||||||
readProxyResponse buff conn = do
|
readConnectResponse buff conn = do
|
||||||
response <- N.appRead conn
|
response <- N.appRead conn
|
||||||
if "\r\n\r\n" `BC.isInfixOf` response
|
if "\r\n\r\n" `BC.isInfixOf` response
|
||||||
then return $ buff <> response
|
then return $ buff <> response
|
||||||
else readProxyResponse (buff <> response) conn
|
else readConnectResponse (buff <> response) conn
|
||||||
|
|
||||||
isAuthorized response = " 200 " `BC.isInfixOf` response
|
isAuthorized response = " 200 " `BC.isInfixOf` response
|
||||||
|
|
||||||
|
mcatch action = action `catch` (\(e :: SomeException) -> LOG.errorM "wstunnel" $ "Cannot connect to the proxy :: " <> show e)
|
||||||
|
|
||||||
tcpConnection :: TunnelSettings -> (Connection -> IO ()) -> IO ()
|
tcpConnection :: TunnelSettings -> (Connection -> IO ()) -> IO ()
|
||||||
tcpConnection TunnelSettings{..} app =
|
tcpConnection TunnelSettings{..} app =
|
||||||
myTry $ N.runTCPClient (N.clientSettingsTCP (fromIntegral serverPort) (fromString serverHost)) (app . toConnection)
|
myTry $ N.runTCPClient (N.clientSettingsTCP (fromIntegral serverPort) (fromString serverHost)) (app . toConnection)
|
||||||
|
|
Loading…
Reference in a new issue