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

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

import           Control.Monad.Class.MonadSTM
import           Control.Monad.Class.MonadThrow
import           Control.Monad.Class.MonadTime.SI
import           Control.Tracer (Tracer)

import           Network.Socket (Socket)
#if defined(mingw32_HOST_OS)
import           System.Win32 (HANDLE)
#endif

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

newtype MakeBearer m fd = MakeBearer {
    forall (m :: * -> *) fd.
MakeBearer m fd -> DiffTime -> Tracer m Trace -> fd -> m (Bearer m)
getBearer
      :: DiffTime
      -- timeout for reading an SDU segment, if negative no
      -- timeout is applied.
      -> Tracer m Trace
      -- tracer
      -> fd
      -- file descriptor
      -> m (Bearer m)
  }


pureBearer :: Applicative m
           => (DiffTime -> Tracer m Trace -> fd ->    Bearer m)
           ->  DiffTime -> Tracer m Trace -> fd -> m (Bearer m)
pureBearer :: forall (m :: * -> *) fd.
Applicative m =>
(DiffTime -> Tracer m Trace -> fd -> Bearer m)
-> DiffTime -> Tracer m Trace -> fd -> m (Bearer m)
pureBearer DiffTime -> Tracer m Trace -> fd -> Bearer m
f = \DiffTime
sduTimeout Tracer m Trace
tr fd
fd -> Bearer m -> m (Bearer m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiffTime -> Tracer m Trace -> fd -> Bearer m
f DiffTime
sduTimeout Tracer m Trace
tr fd
fd)

makeSocketBearer :: MakeBearer IO Socket
makeSocketBearer :: MakeBearer IO Socket
makeSocketBearer = (DiffTime -> Tracer IO Trace -> Socket -> IO (Bearer IO))
-> MakeBearer IO Socket
forall (m :: * -> *) fd.
(DiffTime -> Tracer m Trace -> fd -> m (Bearer m))
-> MakeBearer m fd
MakeBearer ((DiffTime -> Tracer IO Trace -> Socket -> IO (Bearer IO))
 -> MakeBearer IO Socket)
-> (DiffTime -> Tracer IO Trace -> Socket -> IO (Bearer IO))
-> MakeBearer IO Socket
forall a b. (a -> b) -> a -> b
$ (DiffTime -> Tracer IO Trace -> Socket -> Bearer IO)
-> DiffTime -> Tracer IO Trace -> Socket -> IO (Bearer IO)
forall (m :: * -> *) fd.
Applicative m =>
(DiffTime -> Tracer m Trace -> fd -> Bearer m)
-> DiffTime -> Tracer m Trace -> fd -> m (Bearer m)
pureBearer (SDUSize -> DiffTime -> Tracer IO Trace -> Socket -> Bearer IO
socketAsBearer SDUSize
size)
  where
    size :: SDUSize
size = Word16 -> SDUSize
SDUSize Word16
12_288

makePipeChannelBearer :: MakeBearer IO PipeChannel
makePipeChannelBearer :: MakeBearer IO PipeChannel
makePipeChannelBearer = (DiffTime -> Tracer IO Trace -> PipeChannel -> IO (Bearer IO))
-> MakeBearer IO PipeChannel
forall (m :: * -> *) fd.
(DiffTime -> Tracer m Trace -> fd -> m (Bearer m))
-> MakeBearer m fd
MakeBearer ((DiffTime -> Tracer IO Trace -> PipeChannel -> IO (Bearer IO))
 -> MakeBearer IO PipeChannel)
-> (DiffTime -> Tracer IO Trace -> PipeChannel -> IO (Bearer IO))
-> MakeBearer IO PipeChannel
forall a b. (a -> b) -> a -> b
$ (DiffTime -> Tracer IO Trace -> PipeChannel -> Bearer IO)
-> DiffTime -> Tracer IO Trace -> PipeChannel -> IO (Bearer IO)
forall (m :: * -> *) fd.
Applicative m =>
(DiffTime -> Tracer m Trace -> fd -> Bearer m)
-> DiffTime -> Tracer m Trace -> fd -> m (Bearer m)
pureBearer (\DiffTime
_ -> SDUSize -> Tracer IO Trace -> PipeChannel -> Bearer IO
pipeAsBearer SDUSize
size)
  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 = (DiffTime -> Tracer m Trace -> QueueChannel m -> m (Bearer m))
-> MakeBearer m (QueueChannel m)
forall (m :: * -> *) fd.
(DiffTime -> Tracer m Trace -> fd -> m (Bearer m))
-> MakeBearer m fd
MakeBearer ((DiffTime -> Tracer m Trace -> QueueChannel m -> m (Bearer m))
 -> MakeBearer m (QueueChannel m))
-> (DiffTime -> Tracer m Trace -> QueueChannel m -> m (Bearer m))
-> MakeBearer m (QueueChannel m)
forall a b. (a -> b) -> a -> b
$ (DiffTime -> Tracer m Trace -> QueueChannel m -> Bearer m)
-> DiffTime -> Tracer m Trace -> QueueChannel m -> m (Bearer m)
forall (m :: * -> *) fd.
Applicative m =>
(DiffTime -> Tracer m Trace -> fd -> Bearer m)
-> DiffTime -> Tracer m Trace -> fd -> m (Bearer m)
pureBearer (\DiffTime
_ -> SDUSize -> Tracer m Trace -> QueueChannel m -> Bearer m
forall (m :: * -> *).
(MonadSTM m, MonadMonotonicTime m, MonadThrow m) =>
SDUSize -> Tracer m Trace -> QueueChannel m -> Bearer m
queueChannelAsBearer SDUSize
size)
  where
    size :: SDUSize
size = Word16 -> SDUSize
SDUSize Word16
1_280

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