{-# LANGUAGE CPP                    #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE NumericUnderscores     #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE UndecidableInstances   #-}

module Network.Mux.Bearer
  ( Bearer (..)
  , MakeBearerCb
  , MakeBearer (..)
  , BearerTrace (..)
  , makeSocketBearer
  , makeSocketBearer'
  , makePipeChannelBearer
  , makeQueueChannelBearer
#if defined(mingw32_HOST_OS)
  , makeNamedPipeBearer
#endif
  , withReadBufferIO
  ) where

import           Control.Monad.Class.MonadSTM
import           Control.Concurrent.Class.MonadSTM.Strict
import           Control.Monad.Class.MonadThrow
import           Control.Monad.Class.MonadTime.SI

import           Data.ByteString.Lazy qualified as BL
import           Network.Socket (Socket)
#if defined(mingw32_HOST_OS)
import           System.Win32 (HANDLE)
#endif
import           Foreign.Marshal.Alloc

import           Network.Mux.Bearer.Pipe
import           Network.Mux.Bearer.Queues
import           Network.Mux.Bearer.Socket
import           Network.Mux.Trace
import           Network.Mux.Types hiding (egressInterval)
#if defined(mingw32_HOST_OS)
import           Network.Mux.Bearer.NamedPipe
#endif

-- | Callback which constructs a bearer, see `MakeBearer`.
--
type MakeBearerCb m fd =
       DiffTime
    -- ^ Timeout for reading an SDU segment, if negative no timeout is
    -- applied.  The timeout is not applied to the first SDU segment received
    -- from the network, which allows a mini-protocol to have longer
    -- timeouts than the one given here (or even have no timeout).
    --
    -- NOTE: a mini-protocol timeouts (which are not responsibility of
    -- `network-mux` library) might include the time waiting for the response,
    -- receiving all bytes, and the time required to parse the message.
    -> fd
    -- ^ file descriptor
    -> Maybe (ReadBuffer m)
    -- ^ optional `ReadBuffer`
    -> m (Bearer m)


-- | Construct a bearer using a `MakeBearerCb`.
--
newtype MakeBearer m fd = MakeBearer { forall (m :: * -> *) fd. MakeBearer m fd -> MakeBearerCb m fd
getBearer :: MakeBearerCb m fd }

pureBearer :: Applicative m
           => (DiffTime -> fd -> Maybe (ReadBuffer m) ->    Bearer m)
           ->  DiffTime -> fd -> Maybe (ReadBuffer m) -> m (Bearer m)
pureBearer :: forall (m :: * -> *) fd.
Applicative m =>
(DiffTime -> fd -> Maybe (ReadBuffer m) -> Bearer m)
-> DiffTime -> fd -> Maybe (ReadBuffer m) -> m (Bearer m)
pureBearer DiffTime -> fd -> Maybe (ReadBuffer m) -> Bearer m
f = \DiffTime
sduTimeout fd
rb Maybe (ReadBuffer m)
fd -> Bearer m -> m (Bearer m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiffTime -> fd -> Maybe (ReadBuffer m) -> Bearer m
f DiffTime
sduTimeout fd
rb Maybe (ReadBuffer m)
fd)


-- | `Socket` Bearer without egress interval.
--
makeSocketBearer :: MakeBearer IO Socket
makeSocketBearer :: MakeBearer IO Socket
makeSocketBearer = DiffTime -> MakeBearer IO Socket
makeSocketBearer' DiffTime
0

makeSocketBearer'
  :: DiffTime
  -- ^ egress interval
  -> MakeBearer IO Socket
makeSocketBearer' :: DiffTime -> MakeBearer IO Socket
makeSocketBearer' DiffTime
egressInterval = MakeBearerCb IO Socket -> MakeBearer IO Socket
forall (m :: * -> *) fd. MakeBearerCb m fd -> MakeBearer m fd
MakeBearer (MakeBearerCb IO Socket -> MakeBearer IO Socket)
-> MakeBearerCb IO Socket -> MakeBearer IO Socket
forall a b. (a -> b) -> a -> b
$ (DiffTime -> Socket -> Maybe (ReadBuffer IO) -> Bearer IO)
-> MakeBearerCb IO Socket
forall (m :: * -> *) fd.
Applicative m =>
(DiffTime -> fd -> Maybe (ReadBuffer m) -> Bearer m)
-> DiffTime -> fd -> Maybe (ReadBuffer m) -> m (Bearer m)
pureBearer ((DiffTime -> Socket -> Maybe (ReadBuffer IO) -> Bearer IO)
 -> MakeBearerCb IO Socket)
-> (DiffTime -> Socket -> Maybe (ReadBuffer IO) -> Bearer IO)
-> MakeBearerCb IO Socket
forall a b. (a -> b) -> a -> b
$ \DiffTime
sduTimeout Socket
fd Maybe (ReadBuffer IO)
rb ->
    SDUSize
-> Int
-> Maybe (ReadBuffer IO)
-> DiffTime
-> DiffTime
-> Socket
-> Bearer IO
socketAsBearer SDUSize
size Int
batch Maybe (ReadBuffer IO)
rb DiffTime
sduTimeout DiffTime
egressInterval Socket
fd
  where
    size :: SDUSize
size = Word16 -> SDUSize
SDUSize Word16
12_288
    batch :: Int
batch = Int
131_072

withReadBufferIO :: (Maybe (ReadBuffer IO) -> IO b)
                 -> IO b
withReadBufferIO :: forall b. (Maybe (ReadBuffer IO) -> IO b) -> IO b
withReadBufferIO Maybe (ReadBuffer IO) -> IO b
f = Int -> Int -> (Ptr Word8 -> IO b) -> IO b
forall a b. Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAligned Int
size Int
8 ((Ptr Word8 -> IO b) -> IO b) -> (Ptr Word8 -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> do
    v <- ByteString -> IO (StrictTVar IO ByteString)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO ByteString
BL.empty
    f $ Just $ ReadBuffer v ptr size
  where
    -- Maximum amount of data read in one call.
    -- Corresponds to the default readbuffer size on Linux.
    -- We want it larger than 64Kbyte, but not too large since
    -- it is a memory overhead per mux bearer in an application.
    size :: Int
size = Int
131_072

makePipeChannelBearer :: MakeBearer IO PipeChannel
makePipeChannelBearer :: MakeBearer IO PipeChannel
makePipeChannelBearer = MakeBearerCb IO PipeChannel -> MakeBearer IO PipeChannel
forall (m :: * -> *) fd. MakeBearerCb m fd -> MakeBearer m fd
MakeBearer (MakeBearerCb IO PipeChannel -> MakeBearer IO PipeChannel)
-> MakeBearerCb IO PipeChannel -> MakeBearer IO PipeChannel
forall a b. (a -> b) -> a -> b
$ (DiffTime -> PipeChannel -> Maybe (ReadBuffer IO) -> Bearer IO)
-> MakeBearerCb IO PipeChannel
forall (m :: * -> *) fd.
Applicative m =>
(DiffTime -> fd -> Maybe (ReadBuffer m) -> Bearer m)
-> DiffTime -> fd -> Maybe (ReadBuffer m) -> m (Bearer m)
pureBearer (\DiffTime
_ PipeChannel
fd Maybe (ReadBuffer IO)
_ -> SDUSize -> PipeChannel -> Bearer IO
pipeAsBearer SDUSize
size PipeChannel
fd)
  where
    size :: SDUSize
size = Word16 -> SDUSize
SDUSize Word16
32_768

makeQueueChannelBearer :: ( MonadSTM   m
                          , MonadMonotonicTime m
                          , MonadThrow m
                          )
                       => MakeBearer m (QueueChannel m)
makeQueueChannelBearer :: forall (m :: * -> *).
(MonadSTM m, MonadMonotonicTime m, MonadThrow m) =>
MakeBearer m (QueueChannel m)
makeQueueChannelBearer = MakeBearerCb m (QueueChannel m) -> MakeBearer m (QueueChannel m)
forall (m :: * -> *) fd. MakeBearerCb m fd -> MakeBearer m fd
MakeBearer (MakeBearerCb m (QueueChannel m) -> MakeBearer m (QueueChannel m))
-> MakeBearerCb m (QueueChannel m) -> MakeBearer m (QueueChannel m)
forall a b. (a -> b) -> a -> b
$ (DiffTime -> QueueChannel m -> Maybe (ReadBuffer m) -> Bearer m)
-> MakeBearerCb m (QueueChannel m)
forall (m :: * -> *) fd.
Applicative m =>
(DiffTime -> fd -> Maybe (ReadBuffer m) -> Bearer m)
-> DiffTime -> fd -> Maybe (ReadBuffer m) -> m (Bearer m)
pureBearer (\DiffTime
_ QueueChannel m
q Maybe (ReadBuffer m)
_ -> SDUSize -> QueueChannel m -> Bearer m
forall (m :: * -> *).
(MonadSTM m, MonadMonotonicTime m, MonadThrow m) =>
SDUSize -> QueueChannel m -> Bearer m
queueChannelAsBearer SDUSize
size QueueChannel m
q)
  where
    size :: SDUSize
size = Word16 -> SDUSize
SDUSize Word16
1_280

#if defined(mingw32_HOST_OS)
makeNamedPipeBearer :: MakeBearer IO HANDLE
makeNamedPipeBearer = MakeBearer $ pureBearer (\_ fd _ -> namedPipeAsBearer size fd)
  where
    size = SDUSize 24_576
#endif