hex/wstunnel
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Simpler interface

Browse source
This commit is contained in:
Erèbe 2016-05-30 17:20:47 +02:00
parent ed22e0db33
commit 6d0eea8328
1 changed files with 15 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
src/Tunnel.hs
View file

@ -99,10 +99,8 @@ instance ToConnection NC.Connection where
connectionToStream :: Connection -> IO WS.Stream
connectionToStream Connection{..} = WS.makeStream read (write . toStrict . fromJust)
runTunnelingClientWith :: TunnelSettings -> (Connection -> IO ()) -> IO (Connection -> IO ())
runTunnelingClientWith info@TunnelSettings{..} app = do
putStrLn $ "OPEN tunnel " <> tshow info
return $ \conn -> do
runTunnelingClientWith :: TunnelSettings -> (Connection -> IO ()) -> (Connection -> IO ())
runTunnelingClientWith info@TunnelSettings{..} app = \conn -> do
stream <- connectionToStream conn
void $ WS.runClientWithStream stream serverHost (toPath info) WS.defaultConnectionOptions [] $ \conn' ->
app (toConnection conn')
@ -117,12 +115,12 @@ httpProxyConnection (host, port) TunnelSettings{..} app =
response <- readProxyResponse mempty conn
if isConnected response
then app (toConnection conn)
else print $ "Proxy refused the connection :: \n" <> response
else putStrLn $ "Proxy refused the connection :: \n" <> fromString (BC.unpack response)
where
readProxyResponse buff conn = do
response <- N.appRead conn
if "\r\n\r\n" `BC.isSuffixOf` response
if "\r\n\r\n" `BC.isInfixOf` response
then return $ buff <> response
else readProxyResponse (buff <> response) conn
@ -133,8 +131,8 @@ tcpConnection TunnelSettings{..} app =
myTry $ N.runTCPClient (N.clientSettingsTCP (fromIntegral serverPort) (fromString serverHost)) (app . toConnection)
runTLSClient :: TunnelSettings -> (Connection -> IO ()) -> IO (Connection -> IO ())
runTLSClient TunnelSettings{..} app = do
runTLSClient :: TunnelSettings -> (Connection -> IO ()) -> (Connection -> IO ())
runTLSClient TunnelSettings{..} app conn = do
let tlsSettings = NC.TLSSettingsSimple { NC.settingDisableCertificateValidation = True
, NC.settingDisableSession = False
, NC.settingUseServerName = False
@ -145,13 +143,12 @@ runTLSClient TunnelSettings{..} app = do
, NC.connectionUseSocks = Nothing
}
return $ \conn -> do
context <- NC.initConnectionContext
let socket = fromJust . N.appRawSocket . fromJust $ rawConnection conn
h <- N.socketToHandle socket ReadWriteMode
connection <- NC.connectFromHandle context h connectionParams
app (toConnection connection)
finally (app (toConnection connection)) (hClose h)
runTlsTunnelingServer :: (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
@ -217,14 +214,14 @@ propagateWrites hTunnel hOther = myTry $ do
myTry :: IO () -> IO ()
myTry f = void $ catch f (\(_ :: SomeException) -> return ())
myTry f = void $ catch f (\(e :: SomeException) -> print e)
runClient :: TunnelSettings -> IO ()
runClient cfg@TunnelSettings{..} = do
let withTcp = if isJust proxySetting then httpProxyConnection (fromJust proxySetting) cfg else tcpConnection cfg
let doTlsIf tlsNeeded app = if tlsNeeded then runTLSClient cfg app else return app
let doTlsIf tlsNeeded app = if tlsNeeded then runTLSClient cfg app else app
let tunnelClient = runTunnelingClientWith cfg
let tunnelServer app = tunnelClient app >>= doTlsIf useTls >>= withTcp
let tunnelServer app = withTcp (doTlsIf useTls . tunnelClient $ app)
case protocol of