{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE OverloadedStrings   #-}

module Protocols where

import           ClassyPrelude
import           Control.Concurrent        (forkIO)
import qualified Data.HashMap.Strict       as H
import           System.IO                 hiding (hSetBuffering, hGetBuffering)

import qualified Data.ByteString.Char8     as BC

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           Data.Binary               (decode, encode)

import           Logger
import qualified Socks5
import           Types


runSTDIOServer :: (StdioAppData -> IO ()) -> IO ()
runSTDIOServer :: (StdioAppData -> IO ()) -> IO ()
runSTDIOServer StdioAppData -> IO ()
app = do
  BufferMode
stdin_old_buffering <- Handle -> IO BufferMode
forall (m :: * -> *). MonadIO m => Handle -> m BufferMode
hGetBuffering Handle
stdin
  BufferMode
stdout_old_buffering <- Handle -> IO BufferMode
forall (m :: * -> *). MonadIO m => Handle -> m BufferMode
hGetBuffering Handle
stdout

  Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
stdin (Maybe Int -> BufferMode
BlockBuffering (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
512))
  Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
stdout BufferMode
NoBuffering

  IO Any -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Any -> IO ()) -> IO Any -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ StdioAppData -> IO ()
app StdioAppData
StdioAppData

  Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
stdin BufferMode
stdin_old_buffering
  Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
stdout BufferMode
stdout_old_buffering
  String -> IO ()
info (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"CLOSE stdio server"

runTCPServer :: (HostName, PortNumber) -> (N.AppData -> IO ()) -> IO ()
runTCPServer :: (String, PortNumber) -> (AppData -> IO ()) -> IO ()
runTCPServer endPoint :: (String, PortNumber)
endPoint@(String
host, PortNumber
port) AppData -> IO ()
app = do
  String -> IO ()
info (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"WAIT for tcp connection on " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String, PortNumber) -> String
toStr (String, PortNumber)
endPoint
  let srvSet :: ServerSettings
srvSet = Int -> ServerSettings -> ServerSettings
forall a. HasReadBufferSize a => Int -> a -> a
N.setReadBufferSize Int
defaultRecvBufferSize (ServerSettings -> ServerSettings)
-> ServerSettings -> ServerSettings
forall a b. (a -> b) -> a -> b
$ Int -> HostPreference -> ServerSettings
N.serverSettingsTCP (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port) (String -> HostPreference
forall a. IsString a => String -> a
fromString String
host)
  IO Any -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Any -> IO ()) -> IO Any -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerSettings -> (AppData -> IO ()) -> IO Any
forall a. ServerSettings -> (AppData -> IO ()) -> IO a
N.runTCPServer ServerSettings
srvSet AppData -> IO ()
app
  String -> IO ()
info (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"CLOSE tcp server on " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String, PortNumber) -> String
toStr (String, PortNumber)
endPoint

runTCPClient :: (HostName, PortNumber) -> (N.AppData -> IO ()) -> IO ()
runTCPClient :: (String, PortNumber) -> (AppData -> IO ()) -> IO ()
runTCPClient endPoint :: (String, PortNumber)
endPoint@(String
host, PortNumber
port) AppData -> IO ()
app = do
  String -> IO ()
info (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"CONNECTING to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String, PortNumber) -> String
toStr (String, PortNumber)
endPoint
  let srvSet :: ClientSettings
srvSet = Int -> ClientSettings -> ClientSettings
forall a. HasReadBufferSize a => Int -> a -> a
N.setReadBufferSize Int
defaultRecvBufferSize (ClientSettings -> ClientSettings)
-> ClientSettings -> ClientSettings
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ClientSettings
N.clientSettingsTCP (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port) (String -> ByteString
BC.pack String
host)
  IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ClientSettings -> (AppData -> IO ()) -> IO ()
forall a. ClientSettings -> (AppData -> IO a) -> IO a
N.runTCPClient ClientSettings
srvSet AppData -> IO ()
app
  String -> IO ()
info (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"CLOSE connection to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String, PortNumber) -> String
toStr (String, PortNumber)
endPoint


runUDPClient :: (HostName, PortNumber) -> (UdpAppData -> IO ()) -> IO ()
runUDPClient :: (String, PortNumber) -> (UdpAppData -> IO ()) -> IO ()
runUDPClient endPoint :: (String, PortNumber)
endPoint@(String
host, PortNumber
port) UdpAppData -> IO ()
app = do
  String -> IO ()
info (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SENDING datagrammes to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String, PortNumber) -> String
toStr (String, PortNumber)
endPoint
  IO (Socket, AddrInfo)
-> ((Socket, AddrInfo) -> IO ())
-> ((Socket, AddrInfo) -> IO ())
-> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (String -> Int -> IO (Socket, AddrInfo)
N.getSocketUDP String
host (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port)) (Socket -> IO ()
N.close (Socket -> IO ())
-> ((Socket, AddrInfo) -> Socket) -> (Socket, AddrInfo) -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Socket, AddrInfo) -> Socket
forall a b. (a, b) -> a
fst) (((Socket, AddrInfo) -> IO ()) -> IO ())
-> ((Socket, AddrInfo) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Socket
socket, AddrInfo
addrInfo) -> do
    MVar ByteString
sem <- IO (MVar ByteString)
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
    UdpAppData -> IO ()
app UdpAppData :: SockAddr
-> MVar ByteString
-> IO ByteString
-> (ByteString -> IO ())
-> UdpAppData
UdpAppData { appAddr :: SockAddr
appAddr  = AddrInfo -> SockAddr
N.addrAddress AddrInfo
addrInfo
                   , appSem :: MVar ByteString
appSem   = MVar ByteString
sem
                   , appRead :: IO ByteString
appRead  = (ByteString, SockAddr) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, SockAddr) -> ByteString)
-> IO (ByteString, SockAddr) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Socket -> Int -> IO (ByteString, SockAddr)
N.recvFrom Socket
socket Int
4096
                   , appWrite :: ByteString -> IO ()
appWrite = \ByteString
payload -> IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> ByteString -> SockAddr -> IO ()
N.sendAllTo Socket
socket ByteString
payload (AddrInfo -> SockAddr
N.addrAddress AddrInfo
addrInfo)
                   }

  String -> IO ()
info (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"CLOSE udp connection to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String, PortNumber) -> String
toStr (String, PortNumber)
endPoint


runUDPServer :: (HostName, PortNumber) ->  Int -> (UdpAppData -> IO ()) -> IO ()
runUDPServer :: (String, PortNumber) -> Int -> (UdpAppData -> IO ()) -> IO ()
runUDPServer endPoint :: (String, PortNumber)
endPoint@(String
host, PortNumber
port) Int
cnxTimeout UdpAppData -> IO ()
app = do
  String -> IO ()
info (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"WAIT for datagrames on " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String, PortNumber) -> String
toStr (String, PortNumber)
endPoint
  IORef (HashMap SockAddr UdpAppData)
clientsCtx <- HashMap SockAddr UdpAppData
-> IO (IORef (HashMap SockAddr UdpAppData))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef HashMap SockAddr UdpAppData
forall a. Monoid a => a
mempty
  IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (Int -> HostPreference -> IO Socket
N.bindPortUDP (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port) (String -> HostPreference
forall a. IsString a => String -> a
fromString String
host)) Socket -> IO ()
N.close (IORef (HashMap SockAddr UdpAppData) -> Socket -> IO ()
runEventLoop IORef (HashMap SockAddr UdpAppData)
clientsCtx)
  String -> IO ()
info (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"CLOSE udp server" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String, PortNumber) -> String
toStr (String, PortNumber)
endPoint

  where
    addNewClient :: IORef (H.HashMap N.SockAddr UdpAppData) -> N.Socket -> N.SockAddr -> ByteString -> IO UdpAppData
    addNewClient :: IORef (HashMap SockAddr UdpAppData)
-> Socket -> SockAddr -> ByteString -> IO UdpAppData
addNewClient IORef (HashMap SockAddr UdpAppData)
clientsCtx Socket
socket SockAddr
addr ByteString
payload = do
      MVar ByteString
sem <- ByteString -> IO (MVar ByteString)
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar ByteString
payload
      let appData :: UdpAppData
appData = UdpAppData :: SockAddr
-> MVar ByteString
-> IO ByteString
-> (ByteString -> IO ())
-> UdpAppData
UdpAppData { appAddr :: SockAddr
appAddr  = SockAddr
addr
                               , appSem :: MVar ByteString
appSem   = MVar ByteString
sem
                               , appRead :: IO ByteString
appRead  = MVar ByteString -> IO ByteString
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar ByteString
sem
                               , appWrite :: ByteString -> IO ()
appWrite = \ByteString
payload' -> IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> ByteString -> SockAddr -> IO ()
N.sendAllTo Socket
socket ByteString
payload' SockAddr
addr
                               }
      IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (HashMap SockAddr UdpAppData)
-> (HashMap SockAddr UdpAppData
    -> (HashMap SockAddr UdpAppData, ()))
-> IO ()
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef (HashMap SockAddr UdpAppData)
clientsCtx (\HashMap SockAddr UdpAppData
clients -> (SockAddr
-> UdpAppData
-> HashMap SockAddr UdpAppData
-> HashMap SockAddr UdpAppData
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert SockAddr
addr UdpAppData
appData HashMap SockAddr UdpAppData
clients, ()))
      UdpAppData -> IO UdpAppData
forall (m :: * -> *) a. Monad m => a -> m a
return UdpAppData
appData

    removeClient :: IORef (H.HashMap N.SockAddr UdpAppData) -> UdpAppData -> IO ()
    removeClient :: IORef (HashMap SockAddr UdpAppData) -> UdpAppData -> IO ()
removeClient IORef (HashMap SockAddr UdpAppData)
clientsCtx UdpAppData
clientCtx = do
      IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (HashMap SockAddr UdpAppData)
-> (HashMap SockAddr UdpAppData
    -> (HashMap SockAddr UdpAppData, ()))
-> IO ()
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef (HashMap SockAddr UdpAppData)
clientsCtx (\HashMap SockAddr UdpAppData
clients -> (SockAddr
-> HashMap SockAddr UdpAppData -> HashMap SockAddr UdpAppData
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
H.delete (UdpAppData -> SockAddr
appAddr UdpAppData
clientCtx) HashMap SockAddr UdpAppData
clients, ()))
      String -> IO ()
debug String
"TIMEOUT connection"

    pushDataToClient :: UdpAppData -> ByteString -> IO ()
    pushDataToClient :: UdpAppData -> ByteString -> IO ()
pushDataToClient UdpAppData
clientCtx ByteString
payload = MVar ByteString -> ByteString -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar (UdpAppData -> MVar ByteString
appSem UdpAppData
clientCtx) ByteString
payload
      IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(SomeException
_ :: SomeException) -> String -> IO ()
debug (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"DROP udp packet, client thread dead")
     -- If we are unlucky the client's thread died before we had the time to push the data on a already full mutex
     -- and will leave us waiting forever for the mutex to empty. So catch the exeception and drop the message.
     -- Udp is not a reliable protocol so transmission failure should be handled by the application layer

    runEventLoop :: IORef (H.HashMap N.SockAddr UdpAppData) -> N.Socket -> IO ()
    runEventLoop :: IORef (HashMap SockAddr UdpAppData) -> Socket -> IO ()
runEventLoop IORef (HashMap SockAddr UdpAppData)
clientsCtx Socket
socket = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (ByteString
payload, SockAddr
addr) <- Socket -> Int -> IO (ByteString, SockAddr)
N.recvFrom Socket
socket Int
4096
      Maybe UdpAppData
clientCtx <- SockAddr -> HashMap SockAddr UdpAppData -> Maybe UdpAppData
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup SockAddr
addr (HashMap SockAddr UdpAppData -> Maybe UdpAppData)
-> IO (HashMap SockAddr UdpAppData) -> IO (Maybe UdpAppData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (HashMap SockAddr UdpAppData)
-> IO (HashMap SockAddr UdpAppData)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (HashMap SockAddr UdpAppData)
clientsCtx

      case Maybe UdpAppData
clientCtx of
        Just UdpAppData
clientCtx' -> UdpAppData -> ByteString -> IO ()
pushDataToClient UdpAppData
clientCtx' ByteString
payload
        Maybe UdpAppData
_               -> IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO UdpAppData
-> (UdpAppData -> IO ()) -> (UdpAppData -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
                              (IORef (HashMap SockAddr UdpAppData)
-> Socket -> SockAddr -> ByteString -> IO UdpAppData
addNewClient IORef (HashMap SockAddr UdpAppData)
clientsCtx Socket
socket SockAddr
addr ByteString
payload)
                              (IORef (HashMap SockAddr UdpAppData) -> UdpAppData -> IO ()
removeClient IORef (HashMap SockAddr UdpAppData)
clientsCtx)
                              (IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ())
-> (UdpAppData -> IO (Maybe ())) -> UdpAppData -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> IO () -> IO (Maybe ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout Int
cnxTimeout (IO () -> IO (Maybe ()))
-> (UdpAppData -> IO ()) -> UdpAppData -> IO (Maybe ())
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UdpAppData -> IO ()
app)


runSocks5Server :: Socks5.ServerSettings -> TunnelSettings -> (TunnelSettings -> N.AppData -> IO()) -> IO ()
runSocks5Server :: ServerSettings
-> TunnelSettings -> (TunnelSettings -> AppData -> IO ()) -> IO ()
runSocks5Server socksSettings :: ServerSettings
socksSettings@Socks5.ServerSettings{String
PortNumber
$sel:bindOn:ServerSettings :: ServerSettings -> String
$sel:listenOn:ServerSettings :: ServerSettings -> PortNumber
bindOn :: String
listenOn :: PortNumber
..} TunnelSettings
cfg TunnelSettings -> AppData -> IO ()
inner = do
  String -> IO ()
info (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Starting socks5 proxy " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ServerSettings -> String
forall a. Show a => a -> String
show ServerSettings
socksSettings

  ServerSettings -> (AppData -> IO ()) -> IO Any
forall a. ServerSettings -> (AppData -> IO ()) -> IO a
N.runTCPServer (Int -> HostPreference -> ServerSettings
N.serverSettingsTCP (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
listenOn) (String -> HostPreference
forall a. IsString a => String -> a
fromString String
bindOn)) ((AppData -> IO ()) -> IO Any) -> (AppData -> IO ()) -> IO Any
forall a b. (a -> b) -> a -> b
$ \AppData
cnx -> do
    -- Get the auth request and response with a no Auth
    RequestAuth
authRequest <- ByteString -> RequestAuth
forall a. Binary a => ByteString -> a
decode (ByteString -> RequestAuth)
-> (ByteString -> ByteString) -> ByteString -> RequestAuth
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
forall lazy strict. LazySequence lazy strict => strict -> lazy
fromStrict (ByteString -> RequestAuth) -> IO ByteString -> IO RequestAuth
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppData -> IO ByteString
forall a. HasReadWrite a => a -> IO ByteString
N.appRead AppData
cnx :: IO Socks5.RequestAuth
    String -> IO ()
debug (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Socks5 authentification request " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> RequestAuth -> String
forall a. Show a => a -> String
show RequestAuth
authRequest
    let responseAuth :: ByteString
responseAuth = ResponseAuth -> ByteString
forall a. Binary a => a -> ByteString
encode (ResponseAuth -> ByteString) -> ResponseAuth -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> AuthMethod -> ResponseAuth
Socks5.ResponseAuth (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
Socks5.socksVersion) AuthMethod
Socks5.NoAuth
    AppData -> ByteString -> IO ()
forall a. HasReadWrite a => a -> ByteString -> IO ()
N.appWrite AppData
cnx (ByteString -> ByteString
forall lazy strict. LazySequence lazy strict => lazy -> strict
toStrict ByteString
responseAuth)

    -- Get the request and update dynamically the tunnel config
    Request
request <- ByteString -> Request
forall a. Binary a => ByteString -> a
decode (ByteString -> Request)
-> (ByteString -> ByteString) -> ByteString -> Request
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
forall lazy strict. LazySequence lazy strict => strict -> lazy
fromStrict (ByteString -> Request) -> IO ByteString -> IO Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppData -> IO ByteString
forall a. HasReadWrite a => a -> IO ByteString
N.appRead AppData
cnx :: IO Socks5.Request
    String -> IO ()
debug (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Socks5 forward request " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Request -> String
forall a. Show a => a -> String
show Request
request
    let responseRequest :: ByteString
responseRequest =  Response -> ByteString
forall a. Binary a => a -> ByteString
encode (Response -> ByteString) -> Response -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> RetCode -> String -> PortNumber -> Response
Socks5.Response (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
Socks5.socksVersion) RetCode
Socks5.SUCCEEDED (Request -> String
Socks5.addr Request
request) (Request -> PortNumber
Socks5.port Request
request)
    let cfg' :: TunnelSettings
cfg' = TunnelSettings
cfg { destHost :: String
destHost = Request -> String
Socks5.addr Request
request, destPort :: PortNumber
destPort = Request -> PortNumber
Socks5.port Request
request }
    AppData -> ByteString -> IO ()
forall a. HasReadWrite a => a -> ByteString -> IO ()
N.appWrite AppData
cnx (ByteString -> ByteString
forall lazy strict. LazySequence lazy strict => lazy -> strict
toStrict ByteString
responseRequest)

    TunnelSettings -> AppData -> IO ()
inner TunnelSettings
cfg' AppData
cnx

  String -> IO ()
info (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Closing socks5 proxy " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ServerSettings -> String
forall a. Show a => a -> String
show ServerSettings
socksSettings