{-# 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
})
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
}
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))
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
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)
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)
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)