{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE OverloadedStrings   #-}


module Tunnel
    ( runClient
    , runServer
    , rrunTCPClient
    ) where

import           ClassyPrelude
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.Socket.ByteString.Lazy     as NL

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           System.IO                     (IOMode (ReadWriteMode))

import qualified Data.ByteString.Base64        as B64

import           Types
import           Protocols
import qualified Socks5
import           Logger
import qualified Credentials



rrunTCPClient :: N.ClientSettings -> (Connection -> IO a) -> IO a
rrunTCPClient :: forall a. ClientSettings -> (Connection -> IO a) -> IO a
rrunTCPClient ClientSettings
cfg Connection -> IO a
app = forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
    (do
      (Socket
s,SockAddr
addr) <- ByteString -> Int -> Family -> IO (Socket, SockAddr)
N.getSocketFamilyTCP (ClientSettings -> ByteString
N.getHost ClientSettings
cfg) (forall a. HasPort a => a -> Int
N.getPort ClientSettings
cfg) (ClientSettings -> Family
N.getAddrFamily ClientSettings
cfg)
      Int
so_mark_val <- forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
sO_MARK_Value
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
so_mark_val forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
&& SocketOption -> Bool
N.isSupportedSocketOption SocketOption
sO_MARK) (Socket -> SocketOption -> Int -> IO ()
N.setSocketOption Socket
s SocketOption
sO_MARK Int
so_mark_val)
      forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
s,SockAddr
addr)
    )
    (\(Socket, SockAddr)
r -> forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch (Socket -> IO ()
N.close forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst (Socket, SockAddr)
r) (\(SomeException
_ :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()))
    (\(Socket
s, SockAddr
_) -> Connection -> IO a
app Connection
        { read :: IO (Maybe ByteString)
read = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Socket -> Int -> IO ByteString
N.safeRecv Socket
s Int
defaultRecvBufferSize
        , write :: ByteString -> IO ()
write = Socket -> ByteString -> IO ()
N.sendAll Socket
s
        , close :: IO ()
close = Socket -> IO ()
N.close Socket
s
        , rawConnection :: Maybe Socket
rawConnection = forall a. a -> Maybe a
Just Socket
s
        })

--
--  Pipes
--
tunnelingClientP :: MonadError Error m => TunnelSettings -> (Connection -> IO (m ())) -> (Connection -> IO (m ()))
tunnelingClientP :: forall (m :: * -> *).
MonadError Error m =>
TunnelSettings
-> (Connection -> IO (m ())) -> Connection -> IO (m ())
tunnelingClientP cfg :: TunnelSettings
cfg@TunnelSettings{Bool
Int
[Char]
Headers
Maybe ProxySettings
ByteString
PortNumber
Protocol
customHeaders :: TunnelSettings -> Headers
websocketPingFrequencySec :: TunnelSettings -> Int
udpTimeout :: TunnelSettings -> Int
hostHeader :: TunnelSettings -> ByteString
tlsVerifyCertificate :: TunnelSettings -> Bool
tlsSNI :: TunnelSettings -> ByteString
upgradeCredentials :: TunnelSettings -> ByteString
upgradePrefix :: TunnelSettings -> [Char]
useSocks :: TunnelSettings -> Bool
useTls :: TunnelSettings -> Bool
protocol :: TunnelSettings -> Protocol
destPort :: TunnelSettings -> PortNumber
destHost :: TunnelSettings -> [Char]
serverPort :: TunnelSettings -> PortNumber
serverHost :: TunnelSettings -> [Char]
localPort :: TunnelSettings -> PortNumber
localBind :: TunnelSettings -> [Char]
proxySetting :: TunnelSettings -> Maybe ProxySettings
customHeaders :: Headers
websocketPingFrequencySec :: Int
udpTimeout :: Int
hostHeader :: ByteString
tlsVerifyCertificate :: Bool
tlsSNI :: ByteString
upgradeCredentials :: ByteString
upgradePrefix :: [Char]
useSocks :: Bool
useTls :: Bool
protocol :: Protocol
destPort :: PortNumber
destHost :: [Char]
serverPort :: PortNumber
serverHost :: [Char]
localPort :: PortNumber
localBind :: [Char]
proxySetting :: Maybe ProxySettings
..} Connection -> IO (m ())
app Connection
conn = forall {a}. IO (m a) -> IO (m a)
onError forall a b. (a -> b) -> a -> b
$ do
  [Char] -> IO ()
debug [Char]
"Opening Websocket stream"

  Stream
stream <- Connection -> IO Stream
connectionToStream Connection
conn
  let authorization :: Headers
authorization = ([(CI ByteString
"Authorization", ByteString
"Basic " forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
B64.encode ByteString
upgradeCredentials) | Bool -> Bool
not (forall mono. MonoFoldable mono => mono -> Bool
null ByteString
upgradeCredentials)])
  let headers :: Headers
headers = Headers
authorization forall a. Semigroup a => a -> a -> a
<> Headers
customHeaders
  let hostname :: [Char]
hostname = if Bool -> Bool
not (forall mono. MonoFoldable mono => mono -> Bool
null ByteString
hostHeader) then ByteString -> [Char]
BC.unpack ByteString
hostHeader else [Char]
serverHost

  m ()
ret <- forall a.
Stream
-> [Char]
-> [Char]
-> ConnectionOptions
-> Headers
-> ClientApp a
-> IO a
WS.runClientWithStream Stream
stream [Char]
hostname (TunnelSettings -> [Char]
toPath TunnelSettings
cfg) ConnectionOptions
WS.defaultConnectionOptions Headers
headers Connection -> IO (m ())
run

  [Char] -> IO ()
debug [Char]
"Closing Websocket stream"
  forall (m :: * -> *) a. Monad m => a -> m a
return m ()
ret

  where
    connectionToStream :: Connection -> IO Stream
connectionToStream Connection{Maybe Socket
IO (Maybe ByteString)
IO ()
ByteString -> IO ()
rawConnection :: Maybe Socket
close :: IO ()
write :: ByteString -> IO ()
read :: IO (Maybe ByteString)
rawConnection :: Connection -> Maybe Socket
close :: Connection -> IO ()
write :: Connection -> ByteString -> IO ()
read :: Connection -> IO (Maybe ByteString)
..} =  IO (Maybe ByteString) -> (Maybe ByteString -> IO ()) -> IO Stream
WS.makeStream IO (Maybe ByteString)
read (ByteString -> IO ()
write forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall lazy strict. LazySequence lazy strict => lazy -> strict
toStrict forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. HasCallStack => Maybe a -> a
fromJust)
    onError :: IO (m a) -> IO (m a)
onError = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch (\(SomeException
e :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Char] -> Error
WebsocketError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show SomeException
e)
    run :: Connection -> IO (m ())
run Connection
cnx = do
      Connection -> Int -> IO ()
WS.forkPingThread Connection
cnx Int
websocketPingFrequencySec
      Connection -> IO (m ())
app (forall a. ToConnection a => a -> Connection
toConnection Connection
cnx)


tlsClientP :: MonadError Error m => TunnelSettings -> (Connection -> IO (m ())) -> (Connection -> IO (m ()))
tlsClientP :: forall (m :: * -> *).
MonadError Error m =>
TunnelSettings
-> (Connection -> IO (m ())) -> Connection -> IO (m ())
tlsClientP TunnelSettings{Bool
Int
[Char]
Headers
Maybe ProxySettings
ByteString
PortNumber
Protocol
customHeaders :: Headers
websocketPingFrequencySec :: Int
udpTimeout :: Int
hostHeader :: ByteString
tlsVerifyCertificate :: Bool
tlsSNI :: ByteString
upgradeCredentials :: ByteString
upgradePrefix :: [Char]
useSocks :: Bool
useTls :: Bool
protocol :: Protocol
destPort :: PortNumber
destHost :: [Char]
serverPort :: PortNumber
serverHost :: [Char]
localPort :: PortNumber
localBind :: [Char]
proxySetting :: Maybe ProxySettings
customHeaders :: TunnelSettings -> Headers
websocketPingFrequencySec :: TunnelSettings -> Int
udpTimeout :: TunnelSettings -> Int
hostHeader :: TunnelSettings -> ByteString
tlsVerifyCertificate :: TunnelSettings -> Bool
tlsSNI :: TunnelSettings -> ByteString
upgradeCredentials :: TunnelSettings -> ByteString
upgradePrefix :: TunnelSettings -> [Char]
useSocks :: TunnelSettings -> Bool
useTls :: TunnelSettings -> Bool
protocol :: TunnelSettings -> Protocol
destPort :: TunnelSettings -> PortNumber
destHost :: TunnelSettings -> [Char]
serverPort :: TunnelSettings -> PortNumber
serverHost :: TunnelSettings -> [Char]
localPort :: TunnelSettings -> PortNumber
localBind :: TunnelSettings -> [Char]
proxySetting :: TunnelSettings -> Maybe ProxySettings
..} Connection -> IO (m ())
app Connection
conn = forall {a}. IO (m a) -> IO (m a)
onError forall a b. (a -> b) -> a -> b
$ do
    [Char] -> IO ()
debug [Char]
"Doing tls Handshake"

    ConnectionContext
context <- IO ConnectionContext
NC.initConnectionContext
    let socket :: Socket
socket = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Connection -> Maybe Socket
rawConnection Connection
conn
    Handle
h <- Socket -> IOMode -> IO Handle
N.socketToHandle Socket
socket IOMode
ReadWriteMode

    Connection
connection <- ConnectionContext -> Handle -> ConnectionParams -> IO Connection
NC.connectFromHandle ConnectionContext
context Handle
h ConnectionParams
connectionParams
    m ()
ret <- Connection -> IO (m ())
app (forall a. ToConnection a => a -> Connection
toConnection Connection
connection) forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
h

    [Char] -> IO ()
debug [Char]
"Closing TLS"
    forall (m :: * -> *) a. Monad m => a -> m a
return m ()
ret

  where
    onError :: IO (m a) -> IO (m a)
onError = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch (\(SomeException
e :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Char] -> Error
TlsError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show SomeException
e)
    tlsSettings :: TLSSettings
tlsSettings = NC.TLSSettingsSimple { settingDisableCertificateValidation :: Bool
NC.settingDisableCertificateValidation = Bool -> Bool
not Bool
tlsVerifyCertificate
                                       , settingDisableSession :: Bool
NC.settingDisableSession = Bool
False
                                       , settingUseServerName :: Bool
NC.settingUseServerName = Bool
False
                                       }
    connectionParams :: ConnectionParams
connectionParams = NC.ConnectionParams { connectionHostname :: [Char]
NC.connectionHostname = if ByteString
tlsSNI forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty then [Char]
serverHost else ByteString -> [Char]
BC.unpack ByteString
tlsSNI
                                           , connectionPort :: PortNumber
NC.connectionPort = PortNumber
serverPort
                                           , connectionUseSecure :: Maybe TLSSettings
NC.connectionUseSecure = forall a. a -> Maybe a
Just TLSSettings
tlsSettings
                                           , connectionUseSocks :: Maybe ProxySettings
NC.connectionUseSocks = forall a. Maybe a
Nothing
                                           }


--
--  Connectors
--
tcpConnection :: MonadError Error m => TunnelSettings -> (Connection -> IO (m ())) -> IO (m ())
tcpConnection :: forall (m :: * -> *).
MonadError Error m =>
TunnelSettings -> (Connection -> IO (m ())) -> IO (m ())
tcpConnection TunnelSettings{Bool
Int
[Char]
Headers
Maybe ProxySettings
ByteString
PortNumber
Protocol
customHeaders :: Headers
websocketPingFrequencySec :: Int
udpTimeout :: Int
hostHeader :: ByteString
tlsVerifyCertificate :: Bool
tlsSNI :: ByteString
upgradeCredentials :: ByteString
upgradePrefix :: [Char]
useSocks :: Bool
useTls :: Bool
protocol :: Protocol
destPort :: PortNumber
destHost :: [Char]
serverPort :: PortNumber
serverHost :: [Char]
localPort :: PortNumber
localBind :: [Char]
proxySetting :: Maybe ProxySettings
customHeaders :: TunnelSettings -> Headers
websocketPingFrequencySec :: TunnelSettings -> Int
udpTimeout :: TunnelSettings -> Int
hostHeader :: TunnelSettings -> ByteString
tlsVerifyCertificate :: TunnelSettings -> Bool
tlsSNI :: TunnelSettings -> ByteString
upgradeCredentials :: TunnelSettings -> ByteString
upgradePrefix :: TunnelSettings -> [Char]
useSocks :: TunnelSettings -> Bool
useTls :: TunnelSettings -> Bool
protocol :: TunnelSettings -> Protocol
destPort :: TunnelSettings -> PortNumber
destHost :: TunnelSettings -> [Char]
serverPort :: TunnelSettings -> PortNumber
serverHost :: TunnelSettings -> [Char]
localPort :: TunnelSettings -> PortNumber
localBind :: TunnelSettings -> [Char]
proxySetting :: TunnelSettings -> Maybe ProxySettings
..} Connection -> IO (m ())
app = IO (m ()) -> IO (m ())
onError forall a b. (a -> b) -> a -> b
$ do
  [Char] -> IO ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Opening tcp connection to " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
serverHost forall a. Semigroup a => a -> a -> a
<> [Char]
":" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
serverPort :: Int)

  m ()
ret <- forall a. ClientSettings -> (Connection -> IO a) -> IO a
rrunTCPClient (Int -> ByteString -> ClientSettings
N.clientSettingsTCP (forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
serverPort) (forall a. IsString a => [Char] -> a
fromString [Char]
serverHost)) Connection -> IO (m ())
app

  [Char] -> IO ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Closing tcp connection to " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
serverHost forall a. Semigroup a => a -> a -> a
<> [Char]
":" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
serverPort :: Int)
  forall (m :: * -> *) a. Monad m => a -> m a
return m ()
ret

  where
    onError :: IO (m ()) -> IO (m ())
onError = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch (\(SomeException
e :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall seq. IsSequence seq => Index seq -> seq -> seq
take Int
10 (forall a. Show a => a -> [Char]
show SomeException
e) forall a. Eq a => a -> a -> Bool
== [Char]
"user error") (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [Char] -> Error
TunnelError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show SomeException
e))



httpProxyConnection :: MonadError Error m => TunnelSettings -> (Connection -> IO (m ())) -> IO (m ())
httpProxyConnection :: forall (m :: * -> *).
MonadError Error m =>
TunnelSettings -> (Connection -> IO (m ())) -> IO (m ())
httpProxyConnection TunnelSettings{Bool
Int
[Char]
Headers
Maybe ProxySettings
ByteString
PortNumber
Protocol
customHeaders :: Headers
websocketPingFrequencySec :: Int
udpTimeout :: Int
hostHeader :: ByteString
tlsVerifyCertificate :: Bool
tlsSNI :: ByteString
upgradeCredentials :: ByteString
upgradePrefix :: [Char]
useSocks :: Bool
useTls :: Bool
protocol :: Protocol
destPort :: PortNumber
destHost :: [Char]
serverPort :: PortNumber
serverHost :: [Char]
localPort :: PortNumber
localBind :: [Char]
proxySetting :: Maybe ProxySettings
customHeaders :: TunnelSettings -> Headers
websocketPingFrequencySec :: TunnelSettings -> Int
udpTimeout :: TunnelSettings -> Int
hostHeader :: TunnelSettings -> ByteString
tlsVerifyCertificate :: TunnelSettings -> Bool
tlsSNI :: TunnelSettings -> ByteString
upgradeCredentials :: TunnelSettings -> ByteString
upgradePrefix :: TunnelSettings -> [Char]
useSocks :: TunnelSettings -> Bool
useTls :: TunnelSettings -> Bool
protocol :: TunnelSettings -> Protocol
destPort :: TunnelSettings -> PortNumber
destHost :: TunnelSettings -> [Char]
serverPort :: TunnelSettings -> PortNumber
serverHost :: TunnelSettings -> [Char]
localPort :: TunnelSettings -> PortNumber
localBind :: TunnelSettings -> [Char]
proxySetting :: TunnelSettings -> Maybe ProxySettings
..} Connection -> IO (m ())
app = IO (m ()) -> IO (m ())
onError forall a b. (a -> b) -> a -> b
$ do
  let settings :: ProxySettings
settings = forall a. HasCallStack => Maybe a -> a
fromJust Maybe ProxySettings
proxySetting
  [Char] -> IO ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Opening tcp connection to proxy " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ProxySettings
settings

  m ()
ret <- forall a. ClientSettings -> (Connection -> IO a) -> IO a
rrunTCPClient (Int -> ByteString -> ClientSettings
N.clientSettingsTCP (forall a b. (Integral a, Num b) => a -> b
fromIntegral (ProxySettings -> PortNumber
port ProxySettings
settings)) ([Char] -> ByteString
BC.pack forall a b. (a -> b) -> a -> b
$ ProxySettings -> [Char]
host ProxySettings
settings)) forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
    ()
_ <- ProxySettings -> Connection -> IO ()
sendConnectRequest ProxySettings
settings Connection
conn
    Maybe ByteString
responseM <- forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout (Int
1000000 forall a. Num a => a -> a -> a
* Int
10) forall a b. (a -> b) -> a -> b
$ ByteString -> Connection -> IO ByteString
readConnectResponse forall a. Monoid a => a
mempty Connection
conn
    let response :: ByteString
response = forall a. a -> Maybe a -> a
fromMaybe ByteString
"No response of the proxy after 10s" Maybe ByteString
responseM

    if ByteString -> Bool
isAuthorized ByteString
response
    then Connection -> IO (m ())
app Connection
conn
    else forall (m :: * -> *) a. Monad m => a -> m a
return forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Char] -> Error
ProxyForwardError forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
BC.unpack ByteString
response

  [Char] -> IO ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"Closing tcp connection to proxy " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ProxySettings
settings
  forall (m :: * -> *) a. Monad m => a -> m a
return m ()
ret

  where
    credentialsToHeader :: (ByteString, ByteString) -> ByteString
credentialsToHeader (ByteString
user, ByteString
password) = ByteString
"Proxy-Authorization: Basic " forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
B64.encode (ByteString
user forall a. Semigroup a => a -> a -> a
<> ByteString
":" forall a. Semigroup a => a -> a -> a
<> ByteString
password) forall a. Semigroup a => a -> a -> a
<> ByteString
"\r\n"
    sendConnectRequest :: ProxySettings -> Connection -> IO ()
sendConnectRequest ProxySettings
settings Connection
h = Connection -> ByteString -> IO ()
write Connection
h forall a b. (a -> b) -> a -> b
$ ByteString
"CONNECT " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
serverHost forall a. Semigroup a => a -> a -> a
<> ByteString
":" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show PortNumber
serverPort) forall a. Semigroup a => a -> a -> a
<> ByteString
" HTTP/1.0\r\n"
                                  forall a. Semigroup a => a -> a -> a
<> ByteString
"Host: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
serverHost forall a. Semigroup a => a -> a -> a
<> ByteString
":" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show PortNumber
serverPort) forall a. Semigroup a => a -> a -> a
<> ByteString
"\r\n"
                                  forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (ByteString, ByteString) -> ByteString
credentialsToHeader (ProxySettings -> Maybe (ByteString, ByteString)
credentials ProxySettings
settings)
                                  forall a. Semigroup a => a -> a -> a
<> ByteString
"\r\n"

    readConnectResponse :: ByteString -> Connection -> IO ByteString
readConnectResponse ByteString
buff Connection
conn = do
      ByteString
response <- forall a. HasCallStack => Maybe a -> a
fromJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO (Maybe ByteString)
read Connection
conn
      if ByteString
"\r\n\r\n" ByteString -> ByteString -> Bool
`BC.isInfixOf` ByteString
response
      then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString
buff forall a. Semigroup a => a -> a -> a
<> ByteString
response
      else ByteString -> Connection -> IO ByteString
readConnectResponse (ByteString
buff forall a. Semigroup a => a -> a -> a
<> ByteString
response) Connection
conn

    isAuthorized :: ByteString -> Bool
isAuthorized ByteString
response = ByteString
" 200 " ByteString -> ByteString -> Bool
`BC.isInfixOf` ByteString
response

    onError :: IO (m ()) -> IO (m ())
onError = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch (\(SomeException
e :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall seq. IsSequence seq => Index seq -> seq -> seq
take Int
10 (forall a. Show a => a -> [Char]
show SomeException
e) forall a. Eq a => a -> a -> Bool
== [Char]
"user error") (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [Char] -> Error
ProxyConnectionError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show SomeException
e))

--
--  Client
--
runClient :: TunnelSettings -> IO ()
runClient :: TunnelSettings -> IO ()
runClient cfg :: TunnelSettings
cfg@TunnelSettings{Bool
Int
[Char]
Headers
Maybe ProxySettings
ByteString
PortNumber
Protocol
customHeaders :: Headers
websocketPingFrequencySec :: Int
udpTimeout :: Int
hostHeader :: ByteString
tlsVerifyCertificate :: Bool
tlsSNI :: ByteString
upgradeCredentials :: ByteString
upgradePrefix :: [Char]
useSocks :: Bool
useTls :: Bool
protocol :: Protocol
destPort :: PortNumber
destHost :: [Char]
serverPort :: PortNumber
serverHost :: [Char]
localPort :: PortNumber
localBind :: [Char]
proxySetting :: Maybe ProxySettings
customHeaders :: TunnelSettings -> Headers
websocketPingFrequencySec :: TunnelSettings -> Int
udpTimeout :: TunnelSettings -> Int
hostHeader :: TunnelSettings -> ByteString
tlsVerifyCertificate :: TunnelSettings -> Bool
tlsSNI :: TunnelSettings -> ByteString
upgradeCredentials :: TunnelSettings -> ByteString
upgradePrefix :: TunnelSettings -> [Char]
useSocks :: TunnelSettings -> Bool
useTls :: TunnelSettings -> Bool
protocol :: TunnelSettings -> Protocol
destPort :: TunnelSettings -> PortNumber
destHost :: TunnelSettings -> [Char]
serverPort :: TunnelSettings -> PortNumber
serverHost :: TunnelSettings -> [Char]
localPort :: TunnelSettings -> PortNumber
localBind :: TunnelSettings -> [Char]
proxySetting :: TunnelSettings -> Maybe ProxySettings
..} = do
  let withEndPoint :: (Connection -> IO (Either Error ())) -> IO (Either Error ())
withEndPoint = if forall a. Maybe a -> Bool
isJust Maybe ProxySettings
proxySetting then forall (m :: * -> *).
MonadError Error m =>
TunnelSettings -> (Connection -> IO (m ())) -> IO (m ())
httpProxyConnection TunnelSettings
cfg else forall (m :: * -> *).
MonadError Error m =>
TunnelSettings -> (Connection -> IO (m ())) -> IO (m ())
tcpConnection TunnelSettings
cfg
  let doTlsIf :: Bool -> (Connection -> IO (m ())) -> Connection -> IO (m ())
doTlsIf Bool
tlsNeeded Connection -> IO (m ())
app = if Bool
tlsNeeded then forall (m :: * -> *).
MonadError Error m =>
TunnelSettings
-> (Connection -> IO (m ())) -> Connection -> IO (m ())
tlsClientP TunnelSettings
cfg Connection -> IO (m ())
app else Connection -> IO (m ())
app
  let withTunnel :: TunnelSettings
-> (Connection -> IO (Either Error ())) -> IO (Either Error ())
withTunnel TunnelSettings
cfg' Connection -> IO (Either Error ())
app = (Connection -> IO (Either Error ())) -> IO (Either Error ())
withEndPoint (forall {m :: * -> *}.
MonadError Error m =>
Bool -> (Connection -> IO (m ())) -> Connection -> IO (m ())
doTlsIf Bool
useTls forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *).
MonadError Error m =>
TunnelSettings
-> (Connection -> IO (m ())) -> Connection -> IO (m ())
tunnelingClientP TunnelSettings
cfg' forall a b. (a -> b) -> a -> b
$ Connection -> IO (Either Error ())
app)

  let app :: TunnelSettings -> a -> IO ()
app TunnelSettings
cfg' a
localH = do
        Either Error ()
ret <- TunnelSettings
-> (Connection -> IO (Either Error ())) -> IO (Either Error ())
withTunnel TunnelSettings
cfg' forall a b. (a -> b) -> a -> b
$ \Connection
remoteH -> do
          Either Error ()
ret <- Connection
remoteH Connection -> Connection -> IO (Either Error ())
<==> forall a. ToConnection a => a -> Connection
toConnection a
localH
          [Char] -> IO ()
info forall a b. (a -> b) -> a -> b
$ [Char]
"CLOSE tunnel :: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show TunnelSettings
cfg'
          forall (m :: * -> *) a. Monad m => a -> m a
return Either Error ()
ret

        Either Error () -> IO ()
handleError Either Error ()
ret

  case Protocol
protocol of
        Protocol
UDP -> ([Char], PortNumber) -> Int -> (UdpAppData -> IO ()) -> IO ()
runUDPServer ([Char]
localBind, PortNumber
localPort) Int
udpTimeout (forall {a}. ToConnection a => TunnelSettings -> a -> IO ()
app TunnelSettings
cfg)
        Protocol
TCP -> ([Char], PortNumber) -> (AppData -> IO ()) -> IO ()
runTCPServer ([Char]
localBind, PortNumber
localPort) (forall {a}. ToConnection a => TunnelSettings -> a -> IO ()
app TunnelSettings
cfg)
        Protocol
STDIO -> (StdioAppData -> IO ()) -> IO ()
runSTDIOServer (forall {a}. ToConnection a => TunnelSettings -> a -> IO ()
app TunnelSettings
cfg)
        Protocol
SOCKS5 -> ServerSettings
-> TunnelSettings -> (TunnelSettings -> AppData -> IO ()) -> IO ()
runSocks5Server (PortNumber -> [Char] -> ServerSettings
Socks5.ServerSettings PortNumber
localPort [Char]
localBind) TunnelSettings
cfg forall {a}. ToConnection a => TunnelSettings -> a -> IO ()
app




--
--  Server
--
runTlsTunnelingServer :: (ByteString, ByteString) -> (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
runTlsTunnelingServer :: (ByteString, ByteString)
-> ([Char], PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
runTlsTunnelingServer (ByteString
tlsCert, ByteString
tlsKey) endPoint :: ([Char], PortNumber)
endPoint@([Char]
bindTo, PortNumber
portNumber) (ByteString, Int) -> Bool
isAllowed = do
  [Char] -> IO ()
info forall a b. (a -> b) -> a -> b
$ [Char]
"WAIT for TLS connection on " forall a. Semigroup a => a -> a -> a
<> ([Char], PortNumber) -> [Char]
toStr ([Char], PortNumber)
endPoint

  TLSConfig -> (AppData -> IO ()) -> IO ()
N.runTCPServerTLS (HostPreference -> Int -> ByteString -> ByteString -> TLSConfig
N.tlsConfigBS (forall a. IsString a => [Char] -> a
fromString [Char]
bindTo) (forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
portNumber) ByteString
tlsCert ByteString
tlsKey) forall a b. (a -> b) -> a -> b
$ \AppData
sClient ->
    AppData -> ConnectionOptions -> ServerApp -> IO ()
runApp AppData
sClient ConnectionOptions
WS.defaultConnectionOptions (SockAddr -> ((ByteString, Int) -> Bool) -> ServerApp
serverEventLoop (AppData -> SockAddr
N.appSockAddr AppData
sClient) (ByteString, Int) -> Bool
isAllowed)

  [Char] -> IO ()
info [Char]
"SHUTDOWN server"

  where
    runApp :: N.AppData -> WS.ConnectionOptions -> WS.ServerApp -> IO ()
    runApp :: AppData -> ConnectionOptions -> ServerApp -> IO ()
runApp AppData
appData ConnectionOptions
opts ServerApp
app = do
      Stream
stream <- IO (Maybe ByteString) -> (Maybe ByteString -> IO ()) -> IO Stream
WS.makeStream (forall a. HasReadWrite a => a -> IO ByteString
N.appRead AppData
appData forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ByteString
payload -> if ByteString
payload forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just ByteString
payload) (forall a. HasReadWrite a => a -> ByteString -> IO ()
N.appWrite AppData
appData forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall lazy strict. LazySequence lazy strict => lazy -> strict
toStrict forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. HasCallStack => Maybe a -> a
fromJust)
      --let socket = fromJust $ N.appRawSocket appData
      --stream <- WS.makeStream (N.recv socket defaultRecvBufferSize <&> \payload -> if payload == mempty then Nothing else Just payload) (NL.sendAll socket . fromJust)
      forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (Stream -> ConnectionOptions -> IO PendingConnection
WS.makePendingConnectionFromStream Stream
stream ConnectionOptions
opts)
              (\PendingConnection
conn -> forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch (Stream -> IO ()
WS.close forall a b. (a -> b) -> a -> b
$ PendingConnection -> Stream
WS.pendingStream PendingConnection
conn) (\(SomeException
_ :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()))
              ServerApp
app

runTunnelingServer :: (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
runTunnelingServer :: ([Char], PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
runTunnelingServer endPoint :: ([Char], PortNumber)
endPoint@([Char]
host, PortNumber
port) (ByteString, Int) -> Bool
isAllowed = do
  [Char] -> IO ()
info forall a b. (a -> b) -> a -> b
$ [Char]
"WAIT for connection on " forall a. Semigroup a => a -> a -> a
<> ([Char], PortNumber) -> [Char]
toStr ([Char], PortNumber)
endPoint

  let srvSet :: ServerSettings
srvSet = forall a. HasReadBufferSize a => Int -> a -> a
N.setReadBufferSize Int
defaultRecvBufferSize forall a b. (a -> b) -> a -> b
$ Int -> HostPreference -> ServerSettings
N.serverSettingsTCP (forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port) (forall a. IsString a => [Char] -> a
fromString [Char]
host)
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. ServerSettings -> (AppData -> IO ()) -> IO a
N.runTCPServer ServerSettings
srvSet forall a b. (a -> b) -> a -> b
$ \AppData
sClient -> do
    let socket :: Socket
socket = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ AppData -> Maybe Socket
N.appRawSocket AppData
sClient
    Stream
stream <- IO (Maybe ByteString) -> (Maybe ByteString -> IO ()) -> IO Stream
WS.makeStream (Socket -> Int -> IO ByteString
N.recv Socket
socket Int
defaultRecvBufferSize forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ByteString
payload -> if ByteString
payload forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just ByteString
payload) (Socket -> ByteString -> IO ()
NL.sendAll Socket
socket forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. HasCallStack => Maybe a -> a
fromJust)
    Stream -> ConnectionOptions -> ServerApp -> IO ()
runApp Stream
stream ConnectionOptions
WS.defaultConnectionOptions (SockAddr -> ((ByteString, Int) -> Bool) -> ServerApp
serverEventLoop (AppData -> SockAddr
N.appSockAddr AppData
sClient) (ByteString, Int) -> Bool
isAllowed)

  [Char] -> IO ()
info [Char]
"CLOSE server"

  where
    runApp :: WS.Stream -> WS.ConnectionOptions -> WS.ServerApp -> IO ()
    runApp :: Stream -> ConnectionOptions -> ServerApp -> IO ()
runApp Stream
socket ConnectionOptions
opts = forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (Stream -> ConnectionOptions -> IO PendingConnection
WS.makePendingConnectionFromStream Stream
socket ConnectionOptions
opts)
                         (\PendingConnection
conn -> forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch (Stream -> IO ()
WS.close forall a b. (a -> b) -> a -> b
$ PendingConnection -> Stream
WS.pendingStream PendingConnection
conn) (\(SomeException
_ :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()))

serverEventLoop :: N.SockAddr -> ((ByteString, Int) -> Bool) -> WS.PendingConnection -> IO ()
serverEventLoop :: SockAddr -> ((ByteString, Int) -> Bool) -> ServerApp
serverEventLoop SockAddr
sClient (ByteString, Int) -> Bool
isAllowed PendingConnection
pendingConn = do
  let path :: Maybe (Protocol, ByteString, Int)
path =  ByteString -> Maybe (Protocol, ByteString, Int)
fromPath forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. RequestHead -> ByteString
WS.requestPath forall a b. (a -> b) -> a -> b
$ PendingConnection -> RequestHead
WS.pendingRequest PendingConnection
pendingConn
  let forwardedFor :: Headers
forwardedFor = forall seq. IsSequence seq => (Element seq -> Bool) -> seq -> seq
filter (\(CI ByteString
header,ByteString
val) -> CI ByteString
header forall a. Eq a => a -> a -> Bool
== CI ByteString
"x-forwarded-for") forall a b. (a -> b) -> a -> b
$ RequestHead -> Headers
WS.requestHeaders forall a b. (a -> b) -> a -> b
$ PendingConnection -> RequestHead
WS.pendingRequest PendingConnection
pendingConn
  [Char] -> IO ()
info forall a b. (a -> b) -> a -> b
$ [Char]
"NEW incoming connection from " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show SockAddr
sClient forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Headers
forwardedFor
  case Maybe (Protocol, ByteString, Int)
path of
    Maybe (Protocol, ByteString, Int)
Nothing -> [Char] -> IO ()
info [Char]
"Rejecting connection" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PendingConnection -> ByteString -> IO ()
WS.rejectRequest PendingConnection
pendingConn ByteString
"Invalid tunneling information"
    Just (!Protocol
proto, !ByteString
rhost, !Int
rport) ->
      if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ (ByteString, Int) -> Bool
isAllowed (ByteString
rhost, Int
rport)
      then do
        [Char] -> IO ()
info [Char]
"Rejecting tunneling"
        PendingConnection -> ByteString -> IO ()
WS.rejectRequest PendingConnection
pendingConn ByteString
"Restriction is on, You cannot request this tunneling"
      else do
        Connection
conn <- PendingConnection -> IO Connection
WS.acceptRequest PendingConnection
pendingConn
        case Protocol
proto of
          Protocol
UDP -> ([Char], PortNumber) -> (UdpAppData -> IO ()) -> IO ()
runUDPClient (ByteString -> [Char]
BC.unpack ByteString
rhost, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rport) (\UdpAppData
cnx -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. ToConnection a => a -> Connection
toConnection Connection
conn Connection -> Connection -> IO (Either Error ())
<==> forall a. ToConnection a => a -> Connection
toConnection UdpAppData
cnx)
          Protocol
TCP -> ([Char], PortNumber) -> (AppData -> IO ()) -> IO ()
runTCPClient (ByteString -> [Char]
BC.unpack ByteString
rhost, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rport) (\AppData
cnx -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. ToConnection a => a -> Connection
toConnection Connection
conn Connection -> Connection -> IO (Either Error ())
<==> forall a. ToConnection a => a -> Connection
toConnection AppData
cnx)
          Protocol
STDIO -> forall a. Monoid a => a
mempty
          Protocol
SOCKS5 -> forall a. Monoid a => a
mempty


runServer :: Maybe (ByteString, ByteString) -> (HostName, PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
runServer :: Maybe (ByteString, ByteString)
-> ([Char], PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
runServer Maybe (ByteString, ByteString)
Nothing = ([Char], PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
runTunnelingServer
runServer (Just (ByteString
tlsCert, ByteString
tlsKey)) = (ByteString, ByteString)
-> ([Char], PortNumber) -> ((ByteString, Int) -> Bool) -> IO ()
runTlsTunnelingServer (ByteString
tlsCert, ByteString
tlsKey)




--
--  Commons
--
toPath :: TunnelSettings -> String
toPath :: TunnelSettings -> [Char]
toPath TunnelSettings{Bool
Int
[Char]
Headers
Maybe ProxySettings
ByteString
PortNumber
Protocol
customHeaders :: Headers
websocketPingFrequencySec :: Int
udpTimeout :: Int
hostHeader :: ByteString
tlsVerifyCertificate :: Bool
tlsSNI :: ByteString
upgradeCredentials :: ByteString
upgradePrefix :: [Char]
useSocks :: Bool
useTls :: Bool
protocol :: Protocol
destPort :: PortNumber
destHost :: [Char]
serverPort :: PortNumber
serverHost :: [Char]
localPort :: PortNumber
localBind :: [Char]
proxySetting :: Maybe ProxySettings
customHeaders :: TunnelSettings -> Headers
websocketPingFrequencySec :: TunnelSettings -> Int
udpTimeout :: TunnelSettings -> Int
hostHeader :: TunnelSettings -> ByteString
tlsVerifyCertificate :: TunnelSettings -> Bool
tlsSNI :: TunnelSettings -> ByteString
upgradeCredentials :: TunnelSettings -> ByteString
upgradePrefix :: TunnelSettings -> [Char]
useSocks :: TunnelSettings -> Bool
useTls :: TunnelSettings -> Bool
protocol :: TunnelSettings -> Protocol
destPort :: TunnelSettings -> PortNumber
destHost :: TunnelSettings -> [Char]
serverPort :: TunnelSettings -> PortNumber
serverHost :: TunnelSettings -> [Char]
localPort :: TunnelSettings -> PortNumber
localBind :: TunnelSettings -> [Char]
proxySetting :: TunnelSettings -> Maybe ProxySettings
..} = [Char]
"/" forall a. Semigroup a => a -> a -> a
<> [Char]
upgradePrefix forall a. Semigroup a => a -> a -> a
<> [Char]
"/"
                            forall a. Semigroup a => a -> a -> a
<> forall t. Textual t => t -> t
toLower (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ if Protocol
protocol forall a. Eq a => a -> a -> Bool
== Protocol
UDP then Protocol
UDP else Protocol
TCP)
                            forall a. Semigroup a => a -> a -> a
<> [Char]
"/" forall a. Semigroup a => a -> a -> a
<> [Char]
destHost forall a. Semigroup a => a -> a -> a
<> [Char]
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show PortNumber
destPort

fromPath :: ByteString -> Maybe (Protocol, ByteString, Int)
fromPath :: ByteString -> Maybe (Protocol, ByteString, Int)
fromPath ByteString
path = let rets :: [ByteString]
rets = Char -> ByteString -> [ByteString]
BC.split Char
'/' forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> ByteString -> ByteString
BC.drop Int
1 forall a b. (a -> b) -> a -> b
$ ByteString
path
  in do
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall mono. MonoFoldable mono => mono -> Int
length [ByteString]
rets forall a. Eq a => a -> a -> Bool
== Int
4)
    let [ByteString
_, ByteString
protocol, ByteString
h, ByteString
prt] = [ByteString]
rets
    Int
prt' <- forall c a.
(Element c ~ Char, MonoFoldable c, Read a) =>
c -> Maybe a
readMay forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> [Char]
BC.unpack forall a b. (a -> b) -> a -> b
$ ByteString
prt :: Maybe Int
    Protocol
proto <- forall c a.
(Element c ~ Char, MonoFoldable c, Read a) =>
c -> Maybe a
readMay forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall t. Textual t => t -> t
toUpper forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> [Char]
BC.unpack forall a b. (a -> b) -> a -> b
$ ByteString
protocol :: Maybe Protocol
    forall (m :: * -> *) a. Monad m => a -> m a
return (Protocol
proto, ByteString
h, Int
prt')

handleError :: Either Error () -> IO ()
handleError :: Either Error () -> IO ()
handleError (Right ()) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
handleError (Left Error
errMsg) =
  case Error
errMsg of
    ProxyConnectionError [Char]
msg -> [Char] -> IO ()
err [Char]
"Cannot connect to the proxy" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> IO ()
debugPP [Char]
msg
    ProxyForwardError [Char]
msg    -> [Char] -> IO ()
err [Char]
"Connection not allowed by the proxy" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> IO ()
debugPP [Char]
msg
    TunnelError [Char]
msg          -> [Char] -> IO ()
err [Char]
"Cannot establish the connection to the server" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> IO ()
debugPP [Char]
msg
    LocalServerError [Char]
msg     -> [Char] -> IO ()
err [Char]
"Cannot create the localServer, port already binded ?" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> IO ()
debugPP [Char]
msg
    WebsocketError [Char]
msg       -> [Char] -> IO ()
err [Char]
"Cannot establish websocket connection with the server" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> IO ()
debugPP [Char]
msg
    TlsError [Char]
msg             -> [Char] -> IO ()
err [Char]
"Cannot do tls handshake with the server" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> IO ()
debugPP [Char]
msg
    Other [Char]
msg                -> [Char] -> IO ()
debugPP [Char]
msg

  where
    debugPP :: [Char] -> IO ()
debugPP [Char]
msg = [Char] -> IO ()
debug forall a b. (a -> b) -> a -> b
$ [Char]
"====\n" forall a. Semigroup a => a -> a -> a
<> [Char]
msg forall a. Semigroup a => a -> a -> a
<> [Char]
"\n===="

myTry :: MonadError Error m => IO a -> IO (m ())
myTry :: forall (m :: * -> *) a. MonadError Error m => IO a -> IO (m ())
myTry IO a
f = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(SomeException
e :: SomeException) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Char] -> Error
Other forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show SomeException
e) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try IO a
f

(<==>) :: Connection -> Connection -> IO (Either Error ())
<==> :: Connection -> Connection -> IO (Either Error ())
(<==>) Connection
hTunnel Connection
hOther =
  forall (m :: * -> *) a. MonadError Error m => IO a -> IO (m ())
myTry forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
race_ (Connection -> Connection -> IO ()
propagateReads Connection
hTunnel Connection
hOther) (Connection -> Connection -> IO ()
propagateWrites Connection
hTunnel Connection
hOther)

propagateReads :: Connection -> Connection -> IO ()
propagateReads :: Connection -> Connection -> IO ()
propagateReads Connection
hTunnel Connection
hOther = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ Connection -> IO (Maybe ByteString)
read Connection
hTunnel forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Connection -> ByteString -> IO ()
write Connection
hOther forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. HasCallStack => Maybe a -> a
fromJust


propagateWrites :: Connection -> Connection -> IO ()
propagateWrites :: Connection -> Connection -> IO ()
propagateWrites Connection
hTunnel Connection
hOther = do
  ByteString
payload <- forall a. HasCallStack => Maybe a -> a
fromJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO (Maybe ByteString)
read Connection
hOther
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall mono. MonoFoldable mono => mono -> Bool
null ByteString
payload) (Connection -> ByteString -> IO ()
write Connection
hTunnel ByteString
payload forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Connection -> Connection -> IO ()
propagateWrites Connection
hTunnel Connection
hOther)