421 lines
17 KiB
Haskell
421 lines
17 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
|
|
module Tunnel
|
|
( runClient
|
|
, runServer
|
|
, TunnelSettings(..)
|
|
, Protocol(..)
|
|
, ProxySettings(..)
|
|
) where
|
|
|
|
import ClassyPrelude
|
|
import Control.Concurrent.Async (race_)
|
|
import Data.Maybe (fromJust)
|
|
|
|
import qualified Data.ByteString.Char8 as BC
|
|
|
|
import qualified Data.Conduit.Network.TLS as N
|
|
import qualified Data.Streaming.Network as N
|
|
|
|
import Network.Socket (HostName, PortNumber)
|
|
import qualified Network.Socket as N hiding (recv, recvFrom,
|
|
send, sendTo)
|
|
import qualified Network.Socket.ByteString as N
|
|
|
|
import qualified Network.WebSockets as WS
|
|
import qualified Network.WebSockets.Connection as WS
|
|
import qualified Network.WebSockets.Stream as WS
|
|
|
|
import Control.Monad.Except
|
|
import qualified Network.Connection as NC
|
|
import Protocols
|
|
import System.IO (IOMode (ReadWriteMode))
|
|
import System.Timeout
|
|
|
|
import qualified Data.ByteString.Base64 as B64
|
|
|
|
import Utils
|
|
import qualified Socks5
|
|
import Data.Binary (encode, decode)
|
|
|
|
data ProxySettings = ProxySettings
|
|
{ host :: HostName
|
|
, port :: PortNumber
|
|
, credentials :: Maybe (ByteString, ByteString)
|
|
} deriving (Show)
|
|
|
|
data TunnelSettings = TunnelSettings
|
|
{ proxySetting :: Maybe ProxySettings
|
|
, localBind :: HostName
|
|
, localPort :: PortNumber
|
|
, serverHost :: HostName
|
|
, serverPort :: PortNumber
|
|
, destHost :: HostName
|
|
, destPort :: PortNumber
|
|
, protocol :: Protocol
|
|
, useTls :: Bool
|
|
, useSocks :: Bool
|
|
}
|
|
|
|
instance Show TunnelSettings where
|
|
show TunnelSettings{..} = localBind <> ":" <> show localPort
|
|
<> (if isNothing proxySetting
|
|
then mempty
|
|
else " <==PROXY==> " <> host (fromJust proxySetting) <> ":" <> (show . port $ fromJust proxySetting)
|
|
)
|
|
<> " <==" <> (if useTls then "WSS" else "WS") <> "==> "
|
|
<> serverHost <> ":" <> show serverPort
|
|
<> " <==" <> show (if protocol == SOCKS5 then TCP else protocol) <> "==> " <> destHost <> ":" <> show destPort
|
|
|
|
|
|
data Connection = Connection
|
|
{ read :: IO (Maybe ByteString)
|
|
, write :: ByteString -> IO ()
|
|
, close :: IO ()
|
|
, rawConnection :: Maybe N.Socket
|
|
}
|
|
|
|
|
|
data Error = ProxyConnectionError String
|
|
| ProxyForwardError String
|
|
| LocalServerError String
|
|
| TunnelError String
|
|
| WebsocketError String
|
|
| TlsError String
|
|
| Other String
|
|
deriving (Show)
|
|
|
|
class ToConnection a where
|
|
toConnection :: a -> Connection
|
|
|
|
instance ToConnection WS.Connection where
|
|
toConnection conn = Connection { read = Just <$> WS.receiveData conn
|
|
, write = WS.sendBinaryData conn
|
|
, close = WS.sendClose conn (mempty :: LByteString)
|
|
, rawConnection = Nothing
|
|
}
|
|
|
|
instance ToConnection N.AppData where
|
|
toConnection conn = Connection { read = Just <$> N.appRead conn
|
|
, write = N.appWrite conn
|
|
, close = N.appCloseConnection conn
|
|
, rawConnection = Nothing
|
|
}
|
|
|
|
instance ToConnection UdpAppData where
|
|
toConnection conn = Connection { read = Just <$> appRead conn
|
|
, write = appWrite conn
|
|
, close = return ()
|
|
, rawConnection = Nothing
|
|
}
|
|
|
|
instance ToConnection NC.Connection where
|
|
toConnection conn = Connection { read = Just <$> NC.connectionGetChunk conn
|
|
, write = NC.connectionPut conn
|
|
, close = NC.connectionClose conn
|
|
, rawConnection = Nothing
|
|
}
|
|
|
|
rrunTCPClient :: N.ClientSettings -> (Connection -> IO a) -> IO a
|
|
rrunTCPClient cfg app = bracket
|
|
(N.getSocketFamilyTCP (N.getHost cfg) (N.getPort cfg) (N.getAddrFamily cfg))
|
|
(\r -> catch (N.sClose $ fst r) (\(_ :: SomeException) -> return ()))
|
|
(\(s, _) -> app Connection
|
|
{ read = Just <$> N.safeRecv s (N.getReadBufferSize cfg)
|
|
, write = N.sendAll s
|
|
, close = N.sClose s
|
|
, rawConnection = Just s
|
|
})
|
|
|
|
--
|
|
-- Pipes
|
|
--
|
|
tunnelingClientP :: MonadError Error m => TunnelSettings -> (Connection -> IO (m ())) -> (Connection -> IO (m ()))
|
|
tunnelingClientP cfg@TunnelSettings{..} app conn = onError $ do
|
|
debug "Oppening Websocket stream"
|
|
|
|
stream <- connectionToStream conn
|
|
ret <- WS.runClientWithStream stream serverHost (toPath cfg) WS.defaultConnectionOptions [] (app . toConnection)
|
|
|
|
debug "Closing Websocket stream"
|
|
return ret
|
|
|
|
where
|
|
connectionToStream Connection{..} = WS.makeStream read (write . toStrict . fromJust)
|
|
onError = flip catch (\(e :: SomeException) -> return . throwError . WebsocketError $ show e)
|
|
|
|
|
|
tlsClientP :: MonadError Error m => TunnelSettings -> (Connection -> IO (m ())) -> (Connection -> IO (m ()))
|
|
tlsClientP TunnelSettings{..} app conn = onError $ do
|
|
debug "Doing tls Handshake"
|
|
|
|
context <- NC.initConnectionContext
|
|
let socket = fromJust $ rawConnection conn
|
|
h <- N.socketToHandle socket ReadWriteMode
|
|
|
|
connection <- NC.connectFromHandle context h connectionParams
|
|
ret <- app (toConnection connection) `finally` hClose h
|
|
|
|
debug "Closing TLS"
|
|
return ret
|
|
|
|
where
|
|
onError = flip catch (\(e :: SomeException) -> return . throwError . TlsError $ show e)
|
|
tlsSettings = NC.TLSSettingsSimple { NC.settingDisableCertificateValidation = True
|
|
, NC.settingDisableSession = False
|
|
, NC.settingUseServerName = False
|
|
}
|
|
connectionParams = NC.ConnectionParams { NC.connectionHostname = serverHost
|
|
, NC.connectionPort = serverPort
|
|
, NC.connectionUseSecure = Just tlsSettings
|
|
, NC.connectionUseSocks = Nothing
|
|
}
|
|
|
|
|
|
--
|
|
-- Connectors
|
|
--
|
|
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)
|
|
|
|
ret <- rrunTCPClient (N.clientSettingsTCP (fromIntegral serverPort) (fromString serverHost)) app
|
|
|
|
debug $ "Closing tcp connection to " <> fromString serverHost <> ":" <> show (fromIntegral serverPort :: Int)
|
|
return ret
|
|
|
|
where
|
|
onError = flip catch (\(e :: SomeException) -> return $ when (take 10 (show e) == "user error") (throwError $ TunnelError $ show e))
|
|
|
|
|
|
|
|
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
|
|
|
|
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
|
|
|
|
if isAuthorized response
|
|
then app conn
|
|
else return . throwError . ProxyForwardError $ BC.unpack response
|
|
|
|
debug $ "Closing tcp connection to proxy " <> show settings
|
|
return ret
|
|
|
|
where
|
|
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
|
|
if "\r\n\r\n" `BC.isInfixOf` response
|
|
then return $ buff <> response
|
|
else readConnectResponse (buff <> response) conn
|
|
|
|
isAuthorized response = " 200 " `BC.isInfixOf` response
|
|
|
|
onError = flip catch (\(e :: SomeException) -> return $ when (take 10 (show e) == "user error") (throwError $ ProxyConnectionError $ show e))
|
|
|
|
--
|
|
-- Client
|
|
--
|
|
runClient :: TunnelSettings -> IO ()
|
|
runClient cfg@TunnelSettings{..} = do
|
|
let withEndPoint = if isJust proxySetting then httpProxyConnection cfg else tcpConnection cfg
|
|
let doTlsIf tlsNeeded app = if tlsNeeded then tlsClientP cfg app else app
|
|
let withTunnel cfg' app = withEndPoint (doTlsIf useTls . tunnelingClientP cfg' $ app)
|
|
|
|
let app cfg' localH = do
|
|
ret <- withTunnel cfg' $ \remoteH -> do
|
|
info $ "CREATE tunnel :: " <> show cfg'
|
|
ret <- remoteH <==> toConnection localH
|
|
info $ "CLOSE tunnel :: " <> show cfg'
|
|
return ret
|
|
|
|
handleError ret
|
|
|
|
case protocol of
|
|
UDP -> runUDPServer (localBind, localPort) (app cfg)
|
|
TCP -> runTCPServer (localBind, localPort) (app cfg)
|
|
SOCKS5 -> runSocks5Server (Socks5.ServerSettings localPort localBind) cfg app
|
|
|
|
handleError :: Either Error () -> IO ()
|
|
handleError (Right ()) = return ()
|
|
handleError (Left errMsg) =
|
|
case errMsg of
|
|
ProxyConnectionError msg -> err "Cannot connect to the proxy" >> debugPP msg
|
|
ProxyForwardError msg -> err "Connection not allowed by the proxy" >> debugPP msg
|
|
TunnelError msg -> err "Cannot establish the connection to the server" >> debugPP msg
|
|
LocalServerError msg -> err "Cannot create the localServer, port already binded ?" >> debugPP msg
|
|
WebsocketError msg -> err "Cannot establish websocket connection with the server" >> debugPP msg
|
|
TlsError msg -> err "Cannot do tls handshake with the server" >> debugPP msg
|
|
Other msg -> debugPP msg
|
|
|
|
where
|
|
debugPP msg = debug $ "====\n" <> msg <> "\n===="
|
|
|
|
|
|
(<==>) :: Connection -> Connection -> IO (Either Error ())
|
|
(<==>) hTunnel hOther =
|
|
myTry $ race_ (propagateReads hTunnel hOther) (propagateWrites hTunnel hOther)
|
|
|
|
propagateReads :: Connection -> Connection -> IO ()
|
|
propagateReads hTunnel hOther = forever $ read hTunnel >>= write hOther . fromJust
|
|
|
|
|
|
propagateWrites :: Connection -> Connection -> IO ()
|
|
propagateWrites hTunnel hOther = do
|
|
payload <- fromJust <$> read hOther
|
|
unless (null payload) (write hTunnel payload >> propagateWrites hTunnel hOther)
|
|
|
|
|
|
myTry :: MonadError Error m => IO a -> IO (m ())
|
|
myTry f = either (\(e :: SomeException) -> throwError . Other $ show e) (const $ return ()) <$> try f
|
|
|
|
|
|
--
|
|
-- Server
|
|
--
|
|
|
|
runTlsTunnelingServer :: (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
|
|
runTlsTunnelingServer endPoint@(bindTo, portNumber) isAllowed = do
|
|
info $ "WAIT for TLS connection on " <> toStr endPoint
|
|
|
|
N.runTCPServerTLS (N.tlsConfigBS (fromString bindTo) (fromIntegral portNumber) serverCertificate serverKey) $ \sClient ->
|
|
runApp sClient WS.defaultConnectionOptions (serverEventLoop isAllowed)
|
|
|
|
info "SHUTDOWN server"
|
|
|
|
where
|
|
runApp :: N.AppData -> WS.ConnectionOptions -> WS.ServerApp -> IO ()
|
|
runApp appData opts app= do
|
|
stream <- WS.makeStream (Just <$> N.appRead appData) (N.appWrite appData . toStrict . fromJust)
|
|
bracket (WS.makePendingConnectionFromStream stream opts)
|
|
(\conn -> catch (WS.close $ WS.pendingStream conn) (\(_ :: SomeException) -> return ()))
|
|
app
|
|
|
|
runTunnelingServer :: (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
|
|
runTunnelingServer endPoint@(host, port) isAllowed = do
|
|
info $ "WAIT for connection on " <> toStr endPoint
|
|
|
|
void $ N.runTCPServer (N.serverSettingsTCP (fromIntegral port) (fromString host)) $ \sClient ->
|
|
runApp (fromJust $ N.appRawSocket sClient) WS.defaultConnectionOptions (serverEventLoop isAllowed)
|
|
|
|
info "CLOSE server"
|
|
|
|
where
|
|
runApp :: N.Socket -> WS.ConnectionOptions -> WS.ServerApp -> IO ()
|
|
runApp socket opts = bracket (WS.makePendingConnection socket opts)
|
|
(\conn -> catch (WS.close $ WS.pendingStream conn) (\(_ :: SomeException) -> return ()))
|
|
|
|
serverEventLoop :: ((ByteString, Int) -> Bool) -> WS.PendingConnection -> IO ()
|
|
serverEventLoop isAllowed pendingConn = do
|
|
let path = fromPath . WS.requestPath $ WS.pendingRequest pendingConn
|
|
case path of
|
|
Nothing -> info "Rejecting connection" >> WS.rejectRequest pendingConn "Invalid tunneling information"
|
|
Just (!proto, !rhost, !rport) ->
|
|
if not $ isAllowed (rhost, rport)
|
|
then do
|
|
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 -> void $ toConnection conn <==> toConnection cnx)
|
|
TCP -> runTCPClient (BC.unpack rhost, fromIntegral rport) (\cnx -> void $ toConnection conn <==> toConnection cnx)
|
|
|
|
|
|
runServer :: Bool -> (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
|
|
runServer useTLS = if useTLS then runTlsTunnelingServer else runTunnelingServer
|
|
|
|
|
|
|
|
|
|
-- openssl genrsa 512 > host.key
|
|
-- openssl req -new -x509 -nodes -sha1 -days 9999 -key host.key > host.cert
|
|
serverKey :: ByteString
|
|
serverKey = "-----BEGIN RSA PRIVATE KEY-----\n" <>
|
|
"MIIBOgIBAAJBAMEEloIcF3sTGYhQmybyDm1NOpXmf94rR1fOwENjuW6jh4WTaz5k\n" <>
|
|
"Uew8CR58e7c5GgK08ZOJwi2Hpl9MfDm4mGUCAwEAAQJAGP+nHqLUx7PpkqYd8iVX\n" <>
|
|
"iQB/nfqEhRnF27GDZTb9RT7e3bR7X1B9oIBnpmqwMG5oPxidoIKv+jzZjsQcxKLu\n" <>
|
|
"4QIhAPdcPmFrtLUpTXx21wtVxotsO7+YcQxtRtBoXeiREUInAiEAx8Jx9a6eVRIh\n" <>
|
|
"slSTJMPuy/LbvK8VUTqtx9x2EhFhBJMCIQC68qlmwZs6y/N3HO4b8AD1gKCLhm/y\n" <>
|
|
"P2ikvCw1R+ZuQwIgdfcgMUPzgK16dMN5OabzaEF8/kouvo92fKZ2m2jj8D0CIFY8\n" <>
|
|
"4SkXDkpeUEKKfxHqrEkkxmpRk93Ui1NPyN+wxrgO\n" <>
|
|
"-----END RSA PRIVATE KEY-----"
|
|
|
|
serverCertificate :: ByteString
|
|
serverCertificate = "-----BEGIN CERTIFICATE-----\n" <>
|
|
"MIICXTCCAgegAwIBAgIJAJf1Sm7DI0KcMA0GCSqGSIb3DQEBBQUAMIGJMQswCQYD\n" <>
|
|
"VQQGEwJGUjESMBAGA1UECAwJQXF1aXRhaW5lMRAwDgYDVQQHDAdCYXlvbm5lMQ4w\n" <>
|
|
"DAYDVQQKDAVFcmViZTELMAkGA1UECwwCSVQxFjAUBgNVBAMMDXJvbWFpbi5nZXJh\n" <>
|
|
"cmQxHzAdBgkqhkiG9w0BCQEWEHdoeW5vdEBnbWFpbC5jb20wHhcNMTYwNTIxMTUy\n" <>
|
|
"MzIyWhcNNDMxMDA2MTUyMzIyWjCBiTELMAkGA1UEBhMCRlIxEjAQBgNVBAgMCUFx\n" <>
|
|
"dWl0YWluZTEQMA4GA1UEBwwHQmF5b25uZTEOMAwGA1UECgwFRXJlYmUxCzAJBgNV\n" <>
|
|
"BAsMAklUMRYwFAYDVQQDDA1yb21haW4uZ2VyYXJkMR8wHQYJKoZIhvcNAQkBFhB3\n" <>
|
|
"aHlub3RAZ21haWwuY29tMFwwDQYJKoZIhvcNAQEBBQADSwAwSAJBAMEEloIcF3sT\n" <>
|
|
"GYhQmybyDm1NOpXmf94rR1fOwENjuW6jh4WTaz5kUew8CR58e7c5GgK08ZOJwi2H\n" <>
|
|
"pl9MfDm4mGUCAwEAAaNQME4wHQYDVR0OBBYEFLY0HsQst1t3QRXU0aTWg3V1IvGX\n" <>
|
|
"MB8GA1UdIwQYMBaAFLY0HsQst1t3QRXU0aTWg3V1IvGXMAwGA1UdEwQFMAMBAf8w\n" <>
|
|
"DQYJKoZIhvcNAQEFBQADQQCP4oYOIrX7xvmQih3hvF4kUnbKjtttImdGruonsLAz\n" <>
|
|
"OL2VExC6OqlDP2yu14BlsjTt+X2v6mhHnSM16c6AkpM/\n" <>
|
|
"-----END CERTIFICATE-----"
|
|
|
|
|
|
|
|
--
|
|
-- Commons
|
|
--
|
|
|
|
|
|
toPath :: TunnelSettings -> String
|
|
toPath TunnelSettings{..} = "/" <> toLower (show $ if protocol == SOCKS5 then TCP else 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')
|
|
|
|
|
|
runSocks5Server :: Socks5.ServerSettings -> TunnelSettings -> (TunnelSettings -> N.AppData -> IO()) -> IO ()
|
|
runSocks5Server socksSettings@Socks5.ServerSettings{..} cfg inner = do
|
|
debug $ "Starting socks5 proxy " <> show socksSettings
|
|
|
|
N.runTCPServer (N.serverSettingsTCP (fromIntegral listenOn) (fromString bindOn)) $ \cnx -> do
|
|
-- Get the auth request and response with a no Auth
|
|
authRequest <- decode . fromStrict <$> N.appRead cnx :: IO Socks5.ResponseAuth
|
|
debug $ "Socks5 authentification request " <> show authRequest
|
|
let responseAuth = encode $ Socks5.ResponseAuth (fromIntegral Socks5.socksVersion) Socks5.NoAuth
|
|
N.appWrite cnx (toStrict responseAuth)
|
|
|
|
-- Get the request and update dynamically the tunnel config
|
|
request <- decode . fromStrict <$> N.appRead cnx :: IO Socks5.Request
|
|
debug $ "Socks5 forward request " <> show request
|
|
let responseRequest = encode $ Socks5.Response (fromIntegral Socks5.socksVersion) Socks5.SUCCEEDED (Socks5.addr request) (Socks5.port request)
|
|
let cfg' = cfg { destHost = Socks5.addr request, destPort = Socks5.port request }
|
|
N.appWrite cnx (toStrict responseRequest)
|
|
|
|
inner cfg' cnx
|
|
|
|
debug $ "Closing socks5 proxy " <> show socksSettings
|
|
|
|
|
|
|
|
|