Better logging
This commit is contained in:
Erèbe
parent
c8caf6457d
commit
ca70b8b318
2 changed files with 152 additions and 98 deletions
220
src/Tunnel.hs
220
src/Tunnel.hs
|
|
@ -1,9 +1,10 @@
|
|||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
|
||||
module Tunnel
|
||||
( runClient
|
||||
|
|
@ -68,8 +69,13 @@ data Connection = Connection
|
|||
}
|
||||
|
||||
|
||||
data Error = ProxyConnectError String
|
||||
data Error = ProxyConnectionError String
|
||||
| ProxyForwardError String
|
||||
| LocalServerError String
|
||||
| TunnelError String
|
||||
| WebsocketError String
|
||||
| TlsError String
|
||||
| Other String
|
||||
deriving (Show, Read)
|
||||
|
||||
class ToConnection a where
|
||||
|
|
@ -106,24 +112,62 @@ instance ToConnection NC.Connection where
|
|||
connectionToStream :: Connection -> IO WS.Stream
|
||||
connectionToStream Connection{..} = WS.makeStream read (write . toStrict . fromJust)
|
||||
|
||||
runTunnelingClientWith :: TunnelSettings -> (Connection -> IO ()) -> (Connection -> IO ())
|
||||
runTunnelingClientWith info@TunnelSettings{..} app conn = do
|
||||
--
|
||||
-- Pipes
|
||||
--
|
||||
tunnelingClientP :: TunnelSettings -> (Connection -> IO (Either Error ())) -> (Connection -> IO (Either Error ()))
|
||||
tunnelingClientP info@TunnelSettings{..} app conn = do
|
||||
stream <- connectionToStream conn
|
||||
void $ WS.runClientWithStream stream serverHost (toPath info) WS.defaultConnectionOptions [] $ \conn' ->
|
||||
app (toConnection conn')
|
||||
putStrLn $ "CLOSE tunnel " <> tshow info
|
||||
onError $ WS.runClientWithStream stream serverHost (toPath info) WS.defaultConnectionOptions [] (app . toConnection)
|
||||
|
||||
where
|
||||
onError = flip catch (\(e :: SomeException) -> return . Left . WebsocketError $ show e)
|
||||
|
||||
|
||||
httpProxyConnection :: (HostName, PortNumber) -> TunnelSettings -> (Connection -> IO ()) -> IO ()
|
||||
|
||||
tlsClientP :: TunnelSettings -> (Connection -> IO (Either Error ())) -> (Connection -> IO (Either Error ()))
|
||||
tlsClientP TunnelSettings{..} app conn = do
|
||||
let tlsSettings = NC.TLSSettingsSimple { NC.settingDisableCertificateValidation = True
|
||||
, NC.settingDisableSession = False
|
||||
, NC.settingUseServerName = False
|
||||
}
|
||||
let connectionParams = NC.ConnectionParams { NC.connectionHostname = serverHost
|
||||
, NC.connectionPort = serverPort
|
||||
, NC.connectionUseSecure = Just tlsSettings
|
||||
, NC.connectionUseSocks = Nothing
|
||||
}
|
||||
|
||||
onError $ do
|
||||
context <- NC.initConnectionContext
|
||||
let socket = fromJust . N.appRawSocket . fromJust $ rawConnection conn
|
||||
h <- N.socketToHandle socket ReadWriteMode
|
||||
|
||||
connection <- NC.connectFromHandle context h connectionParams
|
||||
finally (app (toConnection connection)) (hClose h)
|
||||
|
||||
where
|
||||
onError = flip catch (\(e :: SomeException) -> return . Left . TlsError $ show e)
|
||||
|
||||
|
||||
--
|
||||
-- Connectors
|
||||
--
|
||||
tcpConnection :: TunnelSettings -> (Connection -> IO (Either Error ())) -> IO (Either Error ())
|
||||
tcpConnection TunnelSettings{..} app =
|
||||
N.runTCPClient (N.clientSettingsTCP (fromIntegral serverPort) (fromString serverHost)) (app . toConnection)
|
||||
`catch`
|
||||
(\(e :: SomeException) -> return $ if take 10 (show e) == "user error" then Right () else Left $ TunnelError $ show e)
|
||||
|
||||
httpProxyConnection :: (HostName, PortNumber) -> TunnelSettings -> (Connection -> IO (Either Error ())) -> IO (Either Error ())
|
||||
httpProxyConnection (host, port) TunnelSettings{..} app =
|
||||
mcatch $ N.runTCPClient (N.clientSettingsTCP (fromIntegral port) (fromString host)) $ \conn -> myTry $ do
|
||||
onError $ N.runTCPClient (N.clientSettingsTCP (fromIntegral port) (fromString host)) $ \conn -> do
|
||||
_ <- sendConnectRequest conn
|
||||
responseM <- timeout (1000000 * 10) $ readConnectResponse mempty conn
|
||||
let response = fromMaybe "No response of the proxy after 10s" responseM
|
||||
|
||||
if isAuthorized response
|
||||
then app $ toConnection conn
|
||||
else LOG.errorM "wstunnel" $ "Proxy refused the connection :: \n===\n" <> fromString (BC.unpack response) <> "\n==="
|
||||
then app (toConnection conn)
|
||||
else return . Left . ProxyForwardError $ BC.unpack response
|
||||
|
||||
where
|
||||
sendConnectRequest h = N.appWrite h $ "CONNECT " <> fromString serverHost <> ":" <> fromString (show serverPort) <> " HTTP/1.0\r\n"
|
||||
|
|
@ -137,40 +181,72 @@ httpProxyConnection (host, port) TunnelSettings{..} app =
|
|||
|
||||
isAuthorized response = " 200 " `BC.isInfixOf` response
|
||||
|
||||
mcatch action = action `catch` (\(e :: SomeException) -> LOG.errorM "wstunnel" $ "Cannot connect to the proxy :: " <> show e)
|
||||
onError = flip catch (\(e :: SomeException) -> return $ if take 10 (show e) == "user error"
|
||||
then Right ()
|
||||
else Left $ ProxyConnectionError $ show e)
|
||||
|
||||
tcpConnection :: TunnelSettings -> (Connection -> IO ()) -> IO ()
|
||||
tcpConnection TunnelSettings{..} app =
|
||||
myTry $ N.runTCPClient (N.clientSettingsTCP (fromIntegral serverPort) (fromString serverHost)) (app . toConnection)
|
||||
--
|
||||
-- Client
|
||||
--
|
||||
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 tlsClientP cfg app else app
|
||||
let tunnelClient = tunnelingClientP cfg
|
||||
let tunnelServer app = withTcp (doTlsIf useTls . tunnelClient $ app)
|
||||
|
||||
let app localH = do
|
||||
info $ "CREATE tunnel :: " <> show cfg
|
||||
ret <- tunnelServer (`propagateRW` toConnection localH)
|
||||
handleError ret
|
||||
info $ "CLOSE tunnel :: " <> show cfg
|
||||
|
||||
case protocol of
|
||||
UDP -> runUDPServer (localBind, localPort) app
|
||||
TCP -> runTCPServer (localBind, localPort) app
|
||||
|
||||
handleError :: Either Error () -> IO ()
|
||||
handleError (Right ()) = return ()
|
||||
handleError (Left err) =
|
||||
case err of
|
||||
ProxyConnectionError msg -> info "Cannot connect to the proxy" >> debug msg
|
||||
ProxyForwardError msg -> info "Connection not allowed by the proxy" >> debug msg
|
||||
TunnelError msg -> info "Cannot establish the connection to the server" >> debug msg
|
||||
LocalServerError msg -> info "Cannot create the localServer, port already binded ?" >> debug msg
|
||||
WebsocketError msg -> info "Cannot establish websocket connection with the server" >> debug msg
|
||||
TlsError msg -> info "Cannot do tls handshake with the server" >> debug msg
|
||||
Other msg -> debug msg
|
||||
|
||||
|
||||
runTLSClient :: TunnelSettings -> (Connection -> IO ()) -> (Connection -> IO ())
|
||||
runTLSClient TunnelSettings{..} app conn = do
|
||||
let tlsSettings = NC.TLSSettingsSimple { NC.settingDisableCertificateValidation = True
|
||||
, NC.settingDisableSession = False
|
||||
, NC.settingUseServerName = False
|
||||
}
|
||||
let connectionParams = NC.ConnectionParams { NC.connectionHostname = serverHost
|
||||
, NC.connectionPort = serverPort
|
||||
, NC.connectionUseSecure = Just tlsSettings
|
||||
, NC.connectionUseSocks = Nothing
|
||||
}
|
||||
propagateRW :: Connection -> Connection -> IO (Either Error ())
|
||||
propagateRW hTunnel hOther =
|
||||
myTry $ race_ (propagateReads hTunnel hOther) (propagateWrites hTunnel hOther)
|
||||
|
||||
context <- NC.initConnectionContext
|
||||
let socket = fromJust . N.appRawSocket . fromJust $ rawConnection conn
|
||||
h <- N.socketToHandle socket ReadWriteMode
|
||||
propagateReads :: Connection -> Connection -> IO ()
|
||||
propagateReads hTunnel hOther = forever $ read hTunnel >>= write hOther . fromJust
|
||||
|
||||
connection <- NC.connectFromHandle context h connectionParams
|
||||
finally (app (toConnection connection)) (hClose h)
|
||||
propagateWrites :: Connection -> Connection -> IO ()
|
||||
propagateWrites hTunnel hOther = do
|
||||
payload <- fromJust <$> read hOther
|
||||
unless (null payload) (write hTunnel payload >> propagateWrites hTunnel hOther)
|
||||
|
||||
|
||||
myTry :: IO a -> IO (Either Error ())
|
||||
myTry f = either (\(e :: SomeException) -> Left . Other $ show e) (const $ Right ()) <$> try f
|
||||
|
||||
|
||||
--
|
||||
-- Server
|
||||
--
|
||||
|
||||
runTlsTunnelingServer :: (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
|
||||
runTlsTunnelingServer (bindTo, portNumber) isAllowed = do
|
||||
putStrLn $ "WAIT for TLS connection on " <> fromString bindTo <> ":" <> tshow portNumber
|
||||
info $ "WAIT for TLS connection on " <> fromString bindTo <> ":" <> show portNumber
|
||||
|
||||
N.runTCPServerTLS (N.tlsConfigBS (fromString bindTo) (fromIntegral portNumber) serverCertificate serverKey) $ \sClient ->
|
||||
runApp sClient WS.defaultConnectionOptions (serverEventLoop isAllowed)
|
||||
|
||||
putStrLn "CLOSE server"
|
||||
info "SHUTDOWN server"
|
||||
|
||||
where
|
||||
runApp :: N.AppData -> WS.ConnectionOptions -> WS.ServerApp -> IO ()
|
||||
|
|
@ -182,12 +258,12 @@ runTlsTunnelingServer (bindTo, portNumber) isAllowed = do
|
|||
|
||||
runTunnelingServer :: (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
|
||||
runTunnelingServer (host, port) isAllowed = do
|
||||
putStrLn $ "WAIT for connection on " <> fromString host <> ":" <> tshow port
|
||||
info $ "WAIT for connection on " <> fromString host <> ":" <> show port
|
||||
|
||||
void $ N.runTCPServer (N.serverSettingsTCP (fromIntegral port) (fromString host)) $ \sClient ->
|
||||
runApp (fromJust $ N.appRawSocket sClient) WS.defaultConnectionOptions (serverEventLoop isAllowed)
|
||||
|
||||
putStrLn "CLOSE server"
|
||||
info "CLOSE server"
|
||||
|
||||
where
|
||||
runApp :: N.Socket -> WS.ConnectionOptions -> WS.ServerApp -> IO ()
|
||||
|
|
@ -198,48 +274,17 @@ serverEventLoop :: ((ByteString, Int) -> Bool) -> WS.PendingConnection -> IO ()
|
|||
serverEventLoop isAllowed pendingConn = do
|
||||
let path = fromPath . WS.requestPath $ WS.pendingRequest pendingConn
|
||||
case path of
|
||||
Nothing -> putStrLn "Rejecting connection" >> WS.rejectRequest pendingConn "Invalid tunneling information"
|
||||
Nothing -> info "Rejecting connection" >> WS.rejectRequest pendingConn "Invalid tunneling information"
|
||||
Just (!proto, !rhost, !rport) ->
|
||||
if not $ isAllowed (rhost, rport)
|
||||
then do
|
||||
putStrLn "Rejecting tunneling"
|
||||
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 -> toConnection conn `propagateRW` toConnection cnx)
|
||||
TCP -> runTCPClient (BC.unpack rhost, fromIntegral rport) (\cnx -> toConnection conn `propagateRW` toConnection cnx)
|
||||
|
||||
|
||||
|
||||
|
||||
propagateRW :: Connection -> Connection -> IO ()
|
||||
propagateRW hTunnel hOther =
|
||||
myTry $ race_ (propagateReads hTunnel hOther) (propagateWrites hTunnel hOther)
|
||||
|
||||
propagateReads :: Connection -> Connection -> IO ()
|
||||
propagateReads hTunnel hOther = myTry (forever $ read hTunnel >>= write hOther . fromJust)
|
||||
|
||||
propagateWrites :: Connection -> Connection -> IO ()
|
||||
propagateWrites hTunnel hOther = myTry $ do
|
||||
payload <- fromJust <$> read hOther
|
||||
unless (null payload) (write hTunnel payload >> propagateWrites hTunnel hOther)
|
||||
|
||||
|
||||
myTry :: IO () -> IO ()
|
||||
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 app
|
||||
let tunnelClient = runTunnelingClientWith cfg
|
||||
let tunnelServer app = withTcp (doTlsIf useTls . tunnelClient $ app)
|
||||
|
||||
|
||||
case protocol of
|
||||
UDP -> runUDPServer (localBind, localPort) (\localH -> tunnelServer (`propagateRW` toConnection localH))
|
||||
TCP -> runTCPServer (localBind, localPort) (\localH -> tunnelServer (`propagateRW` toConnection localH))
|
||||
UDP -> runUDPClient (BC.unpack rhost, fromIntegral rport) (\cnx -> void $ toConnection conn `propagateRW` toConnection cnx)
|
||||
TCP -> runTCPClient (BC.unpack rhost, fromIntegral rport) (\cnx -> void $ toConnection conn `propagateRW` toConnection cnx)
|
||||
|
||||
|
||||
runServer :: Bool -> (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
|
||||
|
|
@ -247,19 +292,6 @@ runServer useTLS = if useTLS then runTlsTunnelingServer else runTunnelingServer
|
|||
|
||||
|
||||
|
||||
toPath :: TunnelSettings -> String
|
||||
toPath TunnelSettings{..} = "/" <> toLower (show protocol) <> "/" <> destHost <> "/" <> show destPort
|
||||
|
||||
fromPath :: ByteString -> Maybe (Protocol, ByteString, Int)
|
||||
fromPath path = let rets = BC.split '/' . BC.drop 1 $ path
|
||||
in do
|
||||
guard (length rets == 3)
|
||||
let [protocol, h, prt] = rets
|
||||
prt' <- readMay . BC.unpack $ prt :: Maybe Int
|
||||
proto <- readMay . toUpper . BC.unpack $ protocol :: Maybe Protocol
|
||||
return (proto, h, prt')
|
||||
|
||||
|
||||
|
||||
-- openssl genrsa 512 > host.key
|
||||
-- openssl req -new -x509 -nodes -sha1 -days 9999 -key host.key > host.cert
|
||||
|
|
@ -290,3 +322,25 @@ serverCertificate = "-----BEGIN CERTIFICATE-----\n" <>
|
|||
"DQYJKoZIhvcNAQEFBQADQQCP4oYOIrX7xvmQih3hvF4kUnbKjtttImdGruonsLAz\n" <>
|
||||
"OL2VExC6OqlDP2yu14BlsjTt+X2v6mhHnSM16c6AkpM/\n" <>
|
||||
"-----END CERTIFICATE-----"
|
||||
|
||||
|
||||
|
||||
--
|
||||
-- Commons
|
||||
--
|
||||
|
||||
|
||||
toPath :: TunnelSettings -> String
|
||||
toPath TunnelSettings{..} = "/" <> toLower (show protocol) <> "/" <> destHost <> "/" <> show destPort
|
||||
|
||||
fromPath :: ByteString -> Maybe (Protocol, ByteString, Int)
|
||||
fromPath path = let rets = BC.split '/' . BC.drop 1 $ path
|
||||
in do
|
||||
guard (length rets == 3)
|
||||
let [protocol, h, prt] = rets
|
||||
prt' <- readMay . BC.unpack $ prt :: Maybe Int
|
||||
proto <- readMay . toUpper . BC.unpack $ protocol :: Maybe Protocol
|
||||
return (proto, h, prt')
|
||||
|
||||
info = LOG.infoM "wstunnel"
|
||||
debug = LOG.debugM "wstunnel"
|
||||
|
|
|
|||
Loading…
Reference in a new issue