{-|
Module      : Z.IO.Network.TCP
Description : TCP servers and clients
Copyright   : (c) Dong Han, 2018
License     : BSD
Maintainer  : winterland1989@gmail.com
Stability   : experimental
Portability : non-portable

This module provides an API for creating TCP servers and clients.

-}

module Z.IO.Network.TCP (
  -- * TCP Client
    TCPClientConfig(..)
  , UVStream
  , defaultTCPClientConfig
  , initTCPClient
  , getTCPSockName
  -- * TCP Server
  , TCPServerConfig(..)
  , defaultTCPServerConfig
  , startTCPServer
  , getTCPPeerName
  -- * For test
  , helloWorld
  , echo
  -- * Internal helper
  , startServerLoop
  , setTCPNoDelay
  , setTCPKeepAlive
  , initTCPStream
  ) where

import           Control.Concurrent
import           Control.Monad
import           Control.Monad.IO.Class
import           Data.Primitive.PrimArray
import           Foreign.Ptr
import           GHC.Generics
import           Z.Data.Text.Print   (Print)
import           Z.Data.JSON         (JSON)
import           Z.IO.Exception
import           Z.IO.Network.SocketAddr
import           Z.IO.Resource
import           Z.IO.UV.FFI
import           Z.IO.UV.Manager
import           Z.IO.UV.UVStream
import           Z.Foreign

--------------------------------------------------------------------------------

-- | A TCP client configuration
--
data TCPClientConfig = TCPClientConfig
    { TCPClientConfig -> Maybe SocketAddr
tcpClientAddr :: Maybe SocketAddr -- ^ assign a local address, or let OS pick one
    , TCPClientConfig -> SocketAddr
tcpRemoteAddr :: SocketAddr       -- ^ remote target address
    , TCPClientConfig -> Bool
tcpClientNoDelay :: Bool          -- ^ if we want to use @TCP_NODELAY@
    , TCPClientConfig -> CUInt
tcpClientKeepAlive :: CUInt       -- ^ set keepalive delay for client socket, see 'setTCPKeepAlive'
    } deriving (TCPClientConfig -> TCPClientConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TCPClientConfig -> TCPClientConfig -> Bool
$c/= :: TCPClientConfig -> TCPClientConfig -> Bool
== :: TCPClientConfig -> TCPClientConfig -> Bool
$c== :: TCPClientConfig -> TCPClientConfig -> Bool
Eq, Eq TCPClientConfig
TCPClientConfig -> TCPClientConfig -> Bool
TCPClientConfig -> TCPClientConfig -> Ordering
TCPClientConfig -> TCPClientConfig -> TCPClientConfig
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TCPClientConfig -> TCPClientConfig -> TCPClientConfig
$cmin :: TCPClientConfig -> TCPClientConfig -> TCPClientConfig
max :: TCPClientConfig -> TCPClientConfig -> TCPClientConfig
$cmax :: TCPClientConfig -> TCPClientConfig -> TCPClientConfig
>= :: TCPClientConfig -> TCPClientConfig -> Bool
$c>= :: TCPClientConfig -> TCPClientConfig -> Bool
> :: TCPClientConfig -> TCPClientConfig -> Bool
$c> :: TCPClientConfig -> TCPClientConfig -> Bool
<= :: TCPClientConfig -> TCPClientConfig -> Bool
$c<= :: TCPClientConfig -> TCPClientConfig -> Bool
< :: TCPClientConfig -> TCPClientConfig -> Bool
$c< :: TCPClientConfig -> TCPClientConfig -> Bool
compare :: TCPClientConfig -> TCPClientConfig -> Ordering
$ccompare :: TCPClientConfig -> TCPClientConfig -> Ordering
Ord, Int -> TCPClientConfig -> ShowS
[TCPClientConfig] -> ShowS
TCPClientConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TCPClientConfig] -> ShowS
$cshowList :: [TCPClientConfig] -> ShowS
show :: TCPClientConfig -> String
$cshow :: TCPClientConfig -> String
showsPrec :: Int -> TCPClientConfig -> ShowS
$cshowsPrec :: Int -> TCPClientConfig -> ShowS
Show, forall x. Rep TCPClientConfig x -> TCPClientConfig
forall x. TCPClientConfig -> Rep TCPClientConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TCPClientConfig x -> TCPClientConfig
$cfrom :: forall x. TCPClientConfig -> Rep TCPClientConfig x
Generic)
      deriving anyclass (Int -> TCPClientConfig -> Builder ()
forall a. (Int -> a -> Builder ()) -> Print a
toUTF8BuilderP :: Int -> TCPClientConfig -> Builder ()
$ctoUTF8BuilderP :: Int -> TCPClientConfig -> Builder ()
Print, Value -> Converter TCPClientConfig
TCPClientConfig -> Value
TCPClientConfig -> Builder ()
forall a.
(Value -> Converter a)
-> (a -> Value) -> (a -> Builder ()) -> JSON a
encodeJSON :: TCPClientConfig -> Builder ()
$cencodeJSON :: TCPClientConfig -> Builder ()
toValue :: TCPClientConfig -> Value
$ctoValue :: TCPClientConfig -> Value
fromValue :: Value -> Converter TCPClientConfig
$cfromValue :: Value -> Converter TCPClientConfig
JSON)

-- | Default config, connect to @localhost:8888@.
--
defaultTCPClientConfig :: TCPClientConfig
{-# INLINABLE defaultTCPClientConfig #-}
defaultTCPClientConfig :: TCPClientConfig
defaultTCPClientConfig = Maybe SocketAddr -> SocketAddr -> Bool -> CUInt -> TCPClientConfig
TCPClientConfig forall a. Maybe a
Nothing (IPv4 -> PortNumber -> SocketAddr
SocketAddrIPv4 IPv4
ipv4Loopback PortNumber
8888) Bool
True CUInt
30

-- | init a TCP client 'Resource', which open a new connect when used.
--
initTCPClient :: HasCallStack => TCPClientConfig -> Resource UVStream
{-# INLINABLE initTCPClient #-}
initTCPClient :: HasCallStack => TCPClientConfig -> Resource UVStream
initTCPClient TCPClientConfig{Bool
Maybe SocketAddr
CUInt
SocketAddr
tcpClientKeepAlive :: CUInt
tcpClientNoDelay :: Bool
tcpRemoteAddr :: SocketAddr
tcpClientAddr :: Maybe SocketAddr
tcpClientKeepAlive :: TCPClientConfig -> CUInt
tcpClientNoDelay :: TCPClientConfig -> Bool
tcpRemoteAddr :: TCPClientConfig -> SocketAddr
tcpClientAddr :: TCPClientConfig -> Maybe SocketAddr
..} = do
    UVManager
uvm <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UVManager
getUVManager
    UVStream
client <- UVManager -> Resource UVStream
initTCPStream UVManager
uvm
    let hdl :: Ptr UVHandle
hdl = UVStream -> Ptr UVHandle
uvsHandle UVStream
client
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe SocketAddr
tcpClientAddr forall a b. (a -> b) -> a -> b
$ \ SocketAddr
tcpClientAddr' ->
            forall a. SocketAddr -> (MBA# SocketAddr -> IO a) -> IO a
withSocketAddrUnsafe SocketAddr
tcpClientAddr' forall a b. (a -> b) -> a -> b
$ \ MBA# SocketAddr
localPtr ->
                -- bind is safe without withUVManager
                forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> MBA# SocketAddr -> CUInt -> IO CInt
uv_tcp_bind Ptr UVHandle
hdl MBA# SocketAddr
localPtr CUInt
0)
        -- nodelay is safe without withUVManager
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tcpClientNoDelay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ forall a b. (a -> b) -> a -> b
$ Ptr UVHandle -> CInt -> IO CInt
uv_tcp_nodelay Ptr UVHandle
hdl CInt
1
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CUInt
tcpClientKeepAlive forall a. Ord a => a -> a -> Bool
> CUInt
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ forall a b. (a -> b) -> a -> b
$
            Ptr UVHandle -> CInt -> CUInt -> IO CInt
uv_tcp_keepalive Ptr UVHandle
hdl CInt
1 CUInt
tcpClientKeepAlive
        forall a. SocketAddr -> (MBA# SocketAddr -> IO a) -> IO a
withSocketAddrUnsafe SocketAddr
tcpRemoteAddr forall a b. (a -> b) -> a -> b
$ \ MBA# SocketAddr
targetPtr -> do
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack =>
UVManager -> (Ptr UVLoop -> IO UVSlotUnsafe) -> IO Int
withUVRequest UVManager
uvm forall a b. (a -> b) -> a -> b
$ \ Ptr UVLoop
_ -> Ptr UVHandle -> MBA# SocketAddr -> IO UVSlotUnsafe
hs_uv_tcp_connect Ptr UVHandle
hdl MBA# SocketAddr
targetPtr
    forall (m :: * -> *) a. Monad m => a -> m a
return UVStream
client

--------------------------------------------------------------------------------

-- | A TCP server configuration
--
data TCPServerConfig = TCPServerConfig
    { TCPServerConfig -> SocketAddr
tcpListenAddr       :: SocketAddr      -- ^ listening address
    , TCPServerConfig -> Int
tcpListenBacklog    :: Int           -- ^ listening socket's backlog size, should be large enough(>128)
    , TCPServerConfig -> Bool
tcpServerWorkerNoDelay :: Bool       -- ^ if we want to use @TCP_NODELAY@
    , TCPServerConfig -> CUInt
tcpServerWorkerKeepAlive :: CUInt    -- ^ set keepalive delay for worker socket, see 'setTCPKeepAlive'
    } deriving (TCPServerConfig -> TCPServerConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TCPServerConfig -> TCPServerConfig -> Bool
$c/= :: TCPServerConfig -> TCPServerConfig -> Bool
== :: TCPServerConfig -> TCPServerConfig -> Bool
$c== :: TCPServerConfig -> TCPServerConfig -> Bool
Eq, Eq TCPServerConfig
TCPServerConfig -> TCPServerConfig -> Bool
TCPServerConfig -> TCPServerConfig -> Ordering
TCPServerConfig -> TCPServerConfig -> TCPServerConfig
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TCPServerConfig -> TCPServerConfig -> TCPServerConfig
$cmin :: TCPServerConfig -> TCPServerConfig -> TCPServerConfig
max :: TCPServerConfig -> TCPServerConfig -> TCPServerConfig
$cmax :: TCPServerConfig -> TCPServerConfig -> TCPServerConfig
>= :: TCPServerConfig -> TCPServerConfig -> Bool
$c>= :: TCPServerConfig -> TCPServerConfig -> Bool
> :: TCPServerConfig -> TCPServerConfig -> Bool
$c> :: TCPServerConfig -> TCPServerConfig -> Bool
<= :: TCPServerConfig -> TCPServerConfig -> Bool
$c<= :: TCPServerConfig -> TCPServerConfig -> Bool
< :: TCPServerConfig -> TCPServerConfig -> Bool
$c< :: TCPServerConfig -> TCPServerConfig -> Bool
compare :: TCPServerConfig -> TCPServerConfig -> Ordering
$ccompare :: TCPServerConfig -> TCPServerConfig -> Ordering
Ord, Int -> TCPServerConfig -> ShowS
[TCPServerConfig] -> ShowS
TCPServerConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TCPServerConfig] -> ShowS
$cshowList :: [TCPServerConfig] -> ShowS
show :: TCPServerConfig -> String
$cshow :: TCPServerConfig -> String
showsPrec :: Int -> TCPServerConfig -> ShowS
$cshowsPrec :: Int -> TCPServerConfig -> ShowS
Show, forall x. Rep TCPServerConfig x -> TCPServerConfig
forall x. TCPServerConfig -> Rep TCPServerConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TCPServerConfig x -> TCPServerConfig
$cfrom :: forall x. TCPServerConfig -> Rep TCPServerConfig x
Generic)
      deriving anyclass (Int -> TCPServerConfig -> Builder ()
forall a. (Int -> a -> Builder ()) -> Print a
toUTF8BuilderP :: Int -> TCPServerConfig -> Builder ()
$ctoUTF8BuilderP :: Int -> TCPServerConfig -> Builder ()
Print, Value -> Converter TCPServerConfig
TCPServerConfig -> Value
TCPServerConfig -> Builder ()
forall a.
(Value -> Converter a)
-> (a -> Value) -> (a -> Builder ()) -> JSON a
encodeJSON :: TCPServerConfig -> Builder ()
$cencodeJSON :: TCPServerConfig -> Builder ()
toValue :: TCPServerConfig -> Value
$ctoValue :: TCPServerConfig -> Value
fromValue :: Value -> Converter TCPServerConfig
$cfromValue :: Value -> Converter TCPServerConfig
JSON)

-- | A default hello world server on 0.0.0.0:8888
--
-- Test it with @main = startTCPServer defaultTCPServerConfig helloWorldWorker@ or
-- @main = startTCPServer defaultTCPServerConfig echoWorker@, now try @nc -v 127.0.0.1 8888@
--
defaultTCPServerConfig :: TCPServerConfig
{-# INLINABLE defaultTCPServerConfig #-}
defaultTCPServerConfig :: TCPServerConfig
defaultTCPServerConfig = SocketAddr -> Int -> Bool -> CUInt -> TCPServerConfig
TCPServerConfig
    (IPv4 -> PortNumber -> SocketAddr
SocketAddrIPv4 IPv4
ipv4Any PortNumber
8888)
    Int
256
    Bool
True
    CUInt
30

-- | Start a TCP server
--
-- Fork new worker threads upon a new connection.
--
startTCPServer :: HasCallStack
               => TCPServerConfig
               -> (UVStream -> IO ())   -- ^ worker which will get an accepted TCP stream and
                                        -- run in a seperated haskell thread,
                                        -- will be closed upon exception or worker finishes.
               -> IO ()
{-# INLINABLE startTCPServer #-}
startTCPServer :: HasCallStack => TCPServerConfig -> (UVStream -> IO ()) -> IO ()
startTCPServer TCPServerConfig{Bool
Int
CUInt
SocketAddr
tcpServerWorkerKeepAlive :: CUInt
tcpServerWorkerNoDelay :: Bool
tcpListenBacklog :: Int
tcpListenAddr :: SocketAddr
tcpServerWorkerKeepAlive :: TCPServerConfig -> CUInt
tcpServerWorkerNoDelay :: TCPServerConfig -> Bool
tcpListenBacklog :: TCPServerConfig -> Int
tcpListenAddr :: TCPServerConfig -> SocketAddr
..} = HasCallStack =>
Int
-> (UVManager -> Resource UVStream)
-> (Ptr UVHandle -> IO ())
-> (CInt -> (UVStream -> IO ()) -> IO ())
-> (UVStream -> IO ())
-> IO ()
startServerLoop
    (forall a. Ord a => a -> a -> a
max Int
tcpListenBacklog Int
128)
    UVManager -> Resource UVStream
initTCPStream
    -- bind is safe without withUVManager
    (\ Ptr UVHandle
serverHandle -> forall a. SocketAddr -> (MBA# SocketAddr -> IO a) -> IO a
withSocketAddrUnsafe SocketAddr
tcpListenAddr forall a b. (a -> b) -> a -> b
$ \ MBA# SocketAddr
addrPtr -> do
        forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> MBA# SocketAddr -> CUInt -> IO CInt
uv_tcp_bind Ptr UVHandle
serverHandle MBA# SocketAddr
addrPtr CUInt
0))
    (\ CInt
fd UVStream -> IO ()
worker -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkBa forall a b. (a -> b) -> a -> b
$ do
        -- It's important to use the worker thread's mananger instead of server's one!
        UVManager
uvm <- IO UVManager
getUVManager
        forall (m :: * -> *) a b.
(MonadMask m, MonadIO m, HasCallStack) =>
Resource a -> (a -> m b) -> m b
withResource (HasCallStack =>
(Ptr UVLoop -> Ptr UVHandle -> IO ())
-> UVManager -> Resource UVStream
initUVStream (\ Ptr UVLoop
loop Ptr UVHandle
hdl -> do
            forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVLoop -> Ptr UVHandle -> IO CInt
uv_tcp_init Ptr UVLoop
loop Ptr UVHandle
hdl)
            forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> CInt -> IO CInt
uv_tcp_open Ptr UVHandle
hdl CInt
fd)) UVManager
uvm) forall a b. (a -> b) -> a -> b
$ \ UVStream
uvs -> do
            -- safe without withUVManager
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tcpServerWorkerNoDelay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ forall a b. (a -> b) -> a -> b
$
                Ptr UVHandle -> CInt -> IO CInt
uv_tcp_nodelay (UVStream -> Ptr UVHandle
uvsHandle UVStream
uvs) CInt
1
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CUInt
tcpServerWorkerKeepAlive forall a. Ord a => a -> a -> Bool
> CUInt
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ forall a b. (a -> b) -> a -> b
$
                Ptr UVHandle -> CInt -> CUInt -> IO CInt
uv_tcp_keepalive (UVStream -> Ptr UVHandle
uvsHandle UVStream
uvs) CInt
1 CUInt
tcpServerWorkerKeepAlive
            UVStream -> IO ()
worker UVStream
uvs)

-- | Start a server loop with different kind of @uv_stream@s, such as tcp or pipe.
--
startServerLoop :: HasCallStack
                => Int -- ^ backLog
                -> (UVManager -> Resource UVStream) -- ^ uv_stream_t initializer
                -> (Ptr UVHandle -> IO ())          -- ^ bind function
                -> (FD -> (UVStream -> IO ()) -> IO ()) -- ^ thread spawner
                -> (UVStream -> IO ())                  -- ^ worker
                -> IO ()
{-# INLINABLE startServerLoop #-}
startServerLoop :: HasCallStack =>
Int
-> (UVManager -> Resource UVStream)
-> (Ptr UVHandle -> IO ())
-> (CInt -> (UVStream -> IO ()) -> IO ())
-> (UVStream -> IO ())
-> IO ()
startServerLoop Int
backLog UVManager -> Resource UVStream
initStream Ptr UVHandle -> IO ()
bind CInt -> (UVStream -> IO ()) -> IO ()
spawn UVStream -> IO ()
worker = do
    UVManager
serverUVManager <- IO UVManager
getUVManager
    forall (m :: * -> *) a b.
(MonadMask m, MonadIO m, HasCallStack) =>
Resource a -> (a -> m b) -> m b
withResource (UVManager -> Resource UVStream
initStream UVManager
serverUVManager) forall a b. (a -> b) -> a -> b
$ \ (UVStream Ptr UVHandle
serverHandle Int
serverSlot UVManager
_ IORef Bool
_) -> do
        Ptr UVHandle -> IO ()
bind Ptr UVHandle
serverHandle
        forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
            (do Ptr UVHandle
check <- forall a. HasCallStack => IO (Ptr a) -> IO (Ptr a)
throwOOMIfNull forall a b. (a -> b) -> a -> b
$ IO (Ptr UVHandle)
hs_uv_check_alloc
                forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> Ptr UVHandle -> IO CInt
hs_uv_check_init Ptr UVHandle
check Ptr UVHandle
serverHandle)
                forall (m :: * -> *) a. Monad m => a -> m a
return Ptr UVHandle
check)
            Ptr UVHandle -> IO ()
hs_uv_check_close forall a b. (a -> b) -> a -> b
$
            \ Ptr UVHandle
check -> do
-- The buffer passing of accept is a litte complicated here, to get maximum performance,
-- we do batch accepting. i.e. recv multiple client inside libuv's event loop:
--
-- We poke uvmanager's buffer table like a normal Ptr Word8, with byte size (backLog*sizeof(FD))
-- inside libuv event loop, we cast the buffer back to int32_t* pointer.
-- each accept callback push a new socket fd to the buffer, and increase a counter(buffer_size_table).
-- backLog should be large enough(>128), so under windows we can't possibly filled it up within one
-- uv_run, under unix we hacked uv internal to provide a stop and resume function, when backLog is
-- reached, we will stop receiving.
--
-- Once back to haskell side, we read all accepted sockets and fork worker threads.
-- if backLog is reached, we resume receiving from haskell side.
--
-- Step 1.
-- we allocate a buffer to hold accepted FDs, pass it just like a normal reading buffer.
-- then we can start listening.
                MutablePrimArray RealWorld CInt
acceptBuf <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPinnedPrimArray Int
backLog
                -- https://stackoverflow.com/questions/1953639/is-it-safe-to-cast-socket-to-int-under-win64
                -- FD is 32bit CInt, it's large enough to hold uv_os_sock_t
                let acceptBufPtr :: Ptr Word8
acceptBufPtr = forall a b. Ptr a -> Ptr b
castPtr (forall s a. MutablePrimArray s a -> Ptr a
mutablePrimArrayContents MutablePrimArray RealWorld CInt
acceptBuf :: Ptr FD)

                forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
serverUVManager forall a b. (a -> b) -> a -> b
$ do
                    -- We use buffersize as accepted fd count(count backwards)
                    UVManager -> Int -> Ptr Word8 -> Int -> IO ()
pokeBufferTable UVManager
serverUVManager Int
serverSlot Ptr Word8
acceptBufPtr (Int
backLogforall a. Num a => a -> a -> a
-Int
1)
                    forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> CInt -> IO CInt
hs_uv_listen Ptr UVHandle
serverHandle (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
backLog))
-- Step 2.
-- we start a uv_check_t for given uv_stream_t, with predefined checking callback
-- see hs_accept_check_cb in hs_uv_stream.c
                    forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ forall a b. (a -> b) -> a -> b
$ Ptr UVHandle -> IO CInt
hs_uv_accept_check_start Ptr UVHandle
check

                MVar Int
m <- UVManager -> Int -> IO (MVar Int)
getBlockMVar UVManager
serverUVManager Int
serverSlot
                forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
                    -- wait until accept some FDs
                    Int
_ <- forall a. MVar a -> IO a
takeMVar MVar Int
m
-- Step 3.
-- After uv loop finishes, if we got some FDs, copy the FD buffer, fetch accepted FDs and fork worker threads.

                    -- we shouldn't receive asycn exceptions here otherwise accepted FDs are not closed
                    forall a. IO a -> IO a
mask_forall a b. (a -> b) -> a -> b
$ do
                        -- we lock uv manager here in case of next uv_run overwrite current accept buffer
                        PrimArray CInt
acceptBufCopy <- forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
serverUVManager forall a b. (a -> b) -> a -> b
$ do
                            Maybe Int
_ <- forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar Int
m
                            Int
acceptCountDown <- UVManager -> Int -> IO Int
peekBufferSizeTable UVManager
serverUVManager Int
serverSlot
                            UVManager -> Int -> Int -> IO ()
pokeBufferSizeTable UVManager
serverUVManager Int
serverSlot (Int
backLogforall a. Num a => a -> a -> a
-Int
1)

                            -- if acceptCountDown count to -1, we should resume on haskell side
                            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
acceptCountDown forall a. Eq a => a -> a -> Bool
== -Int
1) (Ptr UVHandle -> IO ()
hs_uv_listen_resume Ptr UVHandle
serverHandle)

                            -- copy accepted FDs
                            let acceptCount :: Int
acceptCount = Int
backLog forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
- Int
acceptCountDown
                            MutablePrimArray RealWorld CInt
acceptBuf' <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
acceptCount
                            forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> MutablePrimArray (PrimState m) a -> Int -> Int -> m ()
copyMutablePrimArray MutablePrimArray RealWorld CInt
acceptBuf' Int
0 MutablePrimArray RealWorld CInt
acceptBuf (Int
acceptCountDownforall a. Num a => a -> a -> a
+Int
1) Int
acceptCount
                            forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld CInt
acceptBuf'

                        -- looping to fork worker threads
                        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray CInt
acceptBufCopyforall a. Num a => a -> a -> a
-Int
1] forall a b. (a -> b) -> a -> b
$ \ Int
i -> do
                            let fd :: CInt
fd = forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray CInt
acceptBufCopy Int
i
                            if CInt
fd forall a. Ord a => a -> a -> Bool
< CInt
0
                            -- minus fd indicate a server error and we should close server
                            then forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (forall (m :: * -> *) a. Monad m => a -> m a
return CInt
fd)
                            else CInt -> (UVStream -> IO ()) -> IO ()
spawn CInt
fd UVStream -> IO ()
worker

--------------------------------------------------------------------------------

initTCPStream :: UVManager -> Resource UVStream
{-# INLINABLE initTCPStream #-}
initTCPStream :: UVManager -> Resource UVStream
initTCPStream = HasCallStack =>
(Ptr UVLoop -> Ptr UVHandle -> IO ())
-> UVManager -> Resource UVStream
initUVStream (\ Ptr UVLoop
loop Ptr UVHandle
hdl -> forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVLoop -> Ptr UVHandle -> IO CInt
uv_tcp_init Ptr UVLoop
loop Ptr UVHandle
hdl))

-- | Enable or disable @TCP_NODELAY@, which enable or disable Nagle’s algorithm.
setTCPNoDelay :: HasCallStack => UVStream -> Bool -> IO ()
{-# INLINABLE setTCPNoDelay #-}
setTCPNoDelay :: HasCallStack => UVStream -> Bool -> IO ()
setTCPNoDelay UVStream
uvs Bool
nodelay =
    forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> CInt -> IO CInt
uv_tcp_nodelay (UVStream -> Ptr UVHandle
uvsHandle UVStream
uvs) (if Bool
nodelay then CInt
1 else CInt
0))

-- | Enable \/ disable TCP keep-alive. delay is the initial delay in seconds, ignored when enable is zero.
--
-- After delay has been reached, 10 successive probes, each spaced 1 second from the previous one,
-- will still happen. If the connection is still lost at the end of this procedure,
-- then the connection is closed, pending io thread will throw 'TimeExpired' exception.
setTCPKeepAlive :: HasCallStack => UVStream -> CUInt -> IO ()
{-# INLINABLE setTCPKeepAlive #-}
setTCPKeepAlive :: HasCallStack => UVStream -> CUInt -> IO ()
setTCPKeepAlive UVStream
uvs CUInt
delay
    | CUInt
delay forall a. Ord a => a -> a -> Bool
> CUInt
0 = forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> CInt -> CUInt -> IO CInt
uv_tcp_keepalive (UVStream -> Ptr UVHandle
uvsHandle UVStream
uvs) CInt
1 CUInt
delay)
    | Bool
otherwise = forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> CInt -> CUInt -> IO CInt
uv_tcp_keepalive (UVStream -> Ptr UVHandle
uvsHandle UVStream
uvs) CInt
0 CUInt
0)

-- | Get the current address to which the handle is bound.
getTCPSockName :: HasCallStack => UVStream -> IO SocketAddr
{-# INLINABLE getTCPSockName #-}
getTCPSockName :: HasCallStack => UVStream -> IO SocketAddr
getTCPSockName UVStream
uvs = do
    (MBA# SocketAddr -> IO ()) -> IO SocketAddr
withSocketAddrStorageUnsafe forall a b. (a -> b) -> a -> b
$ \ MBA# SocketAddr
paddr ->
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a b. Prim a => a -> (MBA# SocketAddr -> IO b) -> IO (a, b)
withPrimUnsafe (forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
sizeOfSocketAddrStorage :: CInt) forall a b. (a -> b) -> a -> b
$ \ MBA# SocketAddr
plen ->
            forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> MBA# SocketAddr -> MBA# SocketAddr -> IO CInt
uv_tcp_getsockname (UVStream -> Ptr UVHandle
uvsHandle UVStream
uvs) MBA# SocketAddr
paddr MBA# SocketAddr
plen)

-- | Get the address of the peer connected to the handle.
getTCPPeerName :: HasCallStack => UVStream -> IO SocketAddr
{-# INLINABLE getTCPPeerName #-}
getTCPPeerName :: HasCallStack => UVStream -> IO SocketAddr
getTCPPeerName UVStream
uvs = do
    (MBA# SocketAddr -> IO ()) -> IO SocketAddr
withSocketAddrStorageUnsafe forall a b. (a -> b) -> a -> b
$ \ MBA# SocketAddr
paddr ->
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a b. Prim a => a -> (MBA# SocketAddr -> IO b) -> IO (a, b)
withPrimUnsafe (forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
sizeOfSocketAddrStorage :: CInt) forall a b. (a -> b) -> a -> b
$ \ MBA# SocketAddr
plen ->
            forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> MBA# SocketAddr -> MBA# SocketAddr -> IO CInt
uv_tcp_getpeername (UVStream -> Ptr UVHandle
uvsHandle UVStream
uvs) MBA# SocketAddr
paddr MBA# SocketAddr
plen)