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

module Network.Mux.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 MuxTrace -> fd -> m (MuxBearer m)
getBearer
      :: DiffTime
      -- timeout for reading an SDUMux segment, if negative no
      -- timeout is applied.
      -> Tracer m MuxTrace
      -- tracer
      -> fd
      -- file descriptor
      -> m (MuxBearer m)
  }


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

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

makePipeChannelBearer :: MakeBearer IO PipeChannel
makePipeChannelBearer :: MakeBearer IO PipeChannel
makePipeChannelBearer = forall (m :: * -> *) fd.
(DiffTime -> Tracer m MuxTrace -> fd -> m (MuxBearer m))
-> MakeBearer m fd
MakeBearer forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) fd.
Applicative m =>
(DiffTime -> Tracer m MuxTrace -> fd -> MuxBearer m)
-> DiffTime -> Tracer m MuxTrace -> fd -> m (MuxBearer m)
pureBearer (\DiffTime
_ -> SDUSize -> Tracer IO MuxTrace -> PipeChannel -> MuxBearer IO
pipeAsMuxBearer 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 = forall (m :: * -> *) fd.
(DiffTime -> Tracer m MuxTrace -> fd -> m (MuxBearer m))
-> MakeBearer m fd
MakeBearer forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) fd.
Applicative m =>
(DiffTime -> Tracer m MuxTrace -> fd -> MuxBearer m)
-> DiffTime -> Tracer m MuxTrace -> fd -> m (MuxBearer m)
pureBearer (\DiffTime
_ -> forall (m :: * -> *).
(MonadSTM m, MonadMonotonicTime m, MonadThrow m) =>
SDUSize -> Tracer m MuxTrace -> QueueChannel m -> MuxBearer m
queueChannelAsMuxBearer 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