{-# LANGUAGE StrictData #-}

-- | Abstractions for the definition of
-- 'Command' 'Messages', that flow between
module UnliftIO.MessageBox.Command
  ( Message (..),
    Command,
    ReturnType (..),
    ReplyBox (),
    CommandError (..),
    DuplicateReply (..),
    cast,
    call,
    replyTo,
    callAsync,
    delegateCall,
    AsyncReply (),
    waitForReply,
    tryTakeReply,
  )
where

import Control.Applicative (Alternative ((<|>)))
import Control.Monad (unless)
import Control.Monad.Reader (MonadReader)
import Data.Kind (Type)
import UnliftIO.MessageBox.Util.CallId
  ( CallId (),
    HasCallIdCounter,
  )
import qualified UnliftIO.MessageBox.Util.CallId as CallId
import qualified UnliftIO.MessageBox.Class as MessageBox
import UnliftIO
  ( Exception,
    MonadUnliftIO,
    TMVar,
    Typeable,
    atomically,
    checkSTM,
    newEmptyTMVarIO,
    readTMVar,
    readTVar,
    registerDelay,
    takeTMVar,
    throwIO,
    tryPutTMVar,
    tryReadTMVar,
  )

-- | This family allows to encode imperative /commands/.
--
-- The clauses of a 'Command' define the commands that
-- a process should execute.
--
-- Every clause may specify an individual 'ReturnType' that
-- declares if and what response is valid for a message.
--
-- For example:
--
-- >
-- > type LampId = Int
-- >
-- > data instance Command LightControl r where
-- >   GetLamps :: Command LigthControl (Return [LampId])
-- >   SwitchOn :: LampId -> Command LigthControl FireAndForget
-- >
-- > data LightControl -- the phantom type
-- >
--
-- The type index of the Command family is the uninhabited
-- @LightControl@ type.
-- .
--
-- The second type parameter indicates if a message requires the
-- receiver to send a reply back to the blocked and waiting
-- sender, or if no reply is necessary.
data family Command apiTag :: ReturnType -> Type

-- | Indicates if a 'Command' requires the
-- receiver to send a reply or not.
data ReturnType where
  -- | Indicates that a 'Command' value is sent _one-way_.
  --
  -- Values of a 'Command' instance with 'FireAndForget' as second
  -- parameter indicate that the sender should not expect any direct
  -- answer from the recepient.
  FireAndForget :: ReturnType
  -- | Indicates that a 'Command' value requires the receiver
  -- to send a reply of the given type.
  --
  -- Values of a 'Command' instance with 'Return' as second parameter
  -- are received wrapped into a 'Blocking'.
  Return :: Type -> ReturnType

-- | A message valid for some user defined @apiTag@.
--
-- The @apiTag@ tag (phantom-) type defines the
-- messages allowed here, declared by the instance of
-- 'Command' for 'apiTag'.
data Message apiTag where
  -- | Wraps a 'Command' with a 'ReturnType' of 'Return' @result@.
  --
  -- Such a message can formed by using 'call'.
  --
  -- A 'Blocking' contains a 'ReplyBox' that can be
  -- used to send the reply to the other process
  -- blocking on 'call'
  Blocking ::
    Show (Command apiTag ( 'Return result)) =>
    Command apiTag ( 'Return result) ->
    ReplyBox result ->
    Message apiTag
  -- | If the 'Command' has a 'ReturnType' of 'FireAndForget'
  -- it has fire-and-forget semantics.
  --
  -- The smart constructor 'cast' can be used to
  -- this message.
  NonBlocking ::
    (Show (Command apiTag 'FireAndForget)) =>
    Command apiTag 'FireAndForget ->
    Message apiTag

instance Show (Message apiTag) where
  showsPrec :: Int -> Message apiTag -> ShowS
showsPrec Int
d (NonBlocking !Command apiTag 'FireAndForget
m) =
    Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
9) (String -> ShowS
showString String
"NB: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Command apiTag 'FireAndForget -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
9 Command apiTag 'FireAndForget
m)
  showsPrec Int
d (Blocking !Command apiTag ('Return result)
m (MkReplyBox TMVar (InternalReply result)
_ !CallId
callId)) =
    Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
9) (String -> ShowS
showString String
"B: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Command apiTag ('Return result) -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
9 Command apiTag ('Return result)
m ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallId -> ShowS
forall a. Show a => a -> ShowS
shows CallId
callId)

-- | This is like 'Input', it can be used
-- by the receiver of a 'Blocking'
-- to either send a reply using 'reply'
-- or to fail/abort the request using 'sendRequestError'
data ReplyBox a
  = MkReplyBox
      !(TMVar (InternalReply a))
      !CallId

-- | This is the reply to a 'Blocking' sent through the 'ReplyBox'.
type InternalReply a = (Either CommandError a)

-- | The failures that the receiver of a 'Return' 'Command', i.e. a 'Blocking',
-- can communicate to the /caller/, in order to indicate that
-- processing a request did not or will not lead to the result the
-- caller is blocked waiting for.
data CommandError where
  -- | Failed to enqueue a 'Blocking' 'Command' 'Message' into the corresponding
  -- 'MessageBox.Input'
  CouldNotEnqueueCommand :: !CallId -> CommandError
  -- | The request has failed /for reasons/.
  BlockingCommandFailure :: !CallId -> CommandError
  -- | Timeout waiting for the result.
  BlockingCommandTimedOut :: !CallId -> CommandError
  deriving stock (Int -> CommandError -> ShowS
[CommandError] -> ShowS
CommandError -> String
(Int -> CommandError -> ShowS)
-> (CommandError -> String)
-> ([CommandError] -> ShowS)
-> Show CommandError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CommandError] -> ShowS
$cshowList :: [CommandError] -> ShowS
show :: CommandError -> String
$cshow :: CommandError -> String
showsPrec :: Int -> CommandError -> ShowS
$cshowsPrec :: Int -> CommandError -> ShowS
Show, CommandError -> CommandError -> Bool
(CommandError -> CommandError -> Bool)
-> (CommandError -> CommandError -> Bool) -> Eq CommandError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommandError -> CommandError -> Bool
$c/= :: CommandError -> CommandError -> Bool
== :: CommandError -> CommandError -> Bool
$c== :: CommandError -> CommandError -> Bool
Eq)

-- | Enqueue a 'NonBlocking' 'Message' into an 'Input'.
-- This is just for symetry to 'call', this is
-- equivalent to: @\input -> MessageBox.tryToDeliver input . NonBlocking@
--
-- The
{-# INLINE cast #-}
cast ::
  ( MonadUnliftIO m,
    MessageBox.IsInput o,
    Show (Command apiTag 'FireAndForget)
  ) =>
  o (Message apiTag) ->
  Command apiTag 'FireAndForget ->
  m Bool
cast :: o (Message apiTag) -> Command apiTag 'FireAndForget -> m Bool
cast o (Message apiTag)
input !Command apiTag 'FireAndForget
msg =
  o (Message apiTag) -> Message apiTag -> m Bool
forall (input :: * -> *) (m :: * -> *) a.
(IsInput input, MonadUnliftIO m) =>
input a -> a -> m Bool
MessageBox.deliver o (Message apiTag)
input (Command apiTag 'FireAndForget -> Message apiTag
forall apiTag.
Show (Command apiTag 'FireAndForget) =>
Command apiTag 'FireAndForget -> Message apiTag
NonBlocking Command apiTag 'FireAndForget
msg)

-- | Enqueue a 'Blocking' 'Message' into an 'MessageBox.IsInput' and wait for the
-- response.
--
-- If message 'deliver'y failed, return @Left 'CouldNotEnqueueCommand'@.
--
-- If no reply was given by the receiving process (using 'replyTo') within
-- a given duration, return @Left 'BlockingCommandTimedOut'@.
--
-- Important: The given timeout starts __after__ 'deliver' has returned,
-- if 'deliver' blocks and delays, 'call' might take longer than the
-- specified timeout.
--
-- The receiving process can either delegate the call using
-- 'delegateCall' or reply to the call by using: 'replyTo'.
call ::
  ( HasCallIdCounter env,
    MonadReader env m,
    MonadUnliftIO m,
    MessageBox.IsInput input,
    Show (Command apiTag ( 'Return result))
  ) =>
  input (Message apiTag) ->
  Command apiTag ( 'Return result) ->
  Int ->
  m (Either CommandError result)
call :: input (Message apiTag)
-> Command apiTag ('Return result)
-> Int
-> m (Either CommandError result)
call !input (Message apiTag)
input !Command apiTag ('Return result)
pdu !Int
timeoutMicroseconds = do
  !CallId
callId <- m CallId
forall env (m :: * -> *).
(MonadReader env m, HasCallIdCounter env, MonadUnliftIO m) =>
m CallId
CallId.takeNext
  !TMVar (Either CommandError result)
resultVar <- m (TMVar (Either CommandError result))
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
  !Bool
sendSuccessful <- do
    let !rbox :: ReplyBox result
rbox = TMVar (Either CommandError result) -> CallId -> ReplyBox result
forall a. TMVar (InternalReply a) -> CallId -> ReplyBox a
MkReplyBox TMVar (Either CommandError result)
resultVar CallId
callId
    let !msg :: Message apiTag
msg = Command apiTag ('Return result)
-> ReplyBox result -> Message apiTag
forall apiTag result.
Show (Command apiTag ('Return result)) =>
Command apiTag ('Return result)
-> ReplyBox result -> Message apiTag
Blocking Command apiTag ('Return result)
pdu ReplyBox result
rbox
    input (Message apiTag) -> Message apiTag -> m Bool
forall (input :: * -> *) (m :: * -> *) a.
(IsInput input, MonadUnliftIO m) =>
input a -> a -> m Bool
MessageBox.deliver input (Message apiTag)
input Message apiTag
msg
  if Bool -> Bool
not Bool
sendSuccessful
    then Either CommandError result -> m (Either CommandError result)
forall (m :: * -> *) a. Monad m => a -> m a
return (CommandError -> Either CommandError result
forall a b. a -> Either a b
Left (CallId -> CommandError
CouldNotEnqueueCommand CallId
callId))
    else do
      TVar Bool
timedOutVar <- Int -> m (TVar Bool)
forall (m :: * -> *). MonadIO m => Int -> m (TVar Bool)
registerDelay Int
timeoutMicroseconds
      STM (Either CommandError result) -> m (Either CommandError result)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either CommandError result)
 -> m (Either CommandError result))
-> STM (Either CommandError result)
-> m (Either CommandError result)
forall a b. (a -> b) -> a -> b
$
        TMVar (Either CommandError result)
-> STM (Either CommandError result)
forall a. TMVar a -> STM a
takeTMVar TMVar (Either CommandError result)
resultVar
          STM (Either CommandError result)
-> STM (Either CommandError result)
-> STM (Either CommandError result)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ( do
                  TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
timedOutVar STM Bool -> (Bool -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM ()
checkSTM
                  Either CommandError result -> STM (Either CommandError result)
forall (m :: * -> *) a. Monad m => a -> m a
return (CommandError -> Either CommandError result
forall a b. a -> Either a b
Left (CallId -> CommandError
BlockingCommandTimedOut CallId
callId))
              )

-- | This is called from the callback contained in the 'Blocking' 'Message'.
--
-- When handling a 'Blocking' 'Message' the 'ReplyBox' contained
-- in the message contains the 'TMVar' for the result, and this
-- function puts the result into it.
{-# INLINE replyTo #-}
replyTo :: (MonadUnliftIO m) => ReplyBox a -> a -> m ()
replyTo :: ReplyBox a -> a -> m ()
replyTo (MkReplyBox !TMVar (InternalReply a)
replyBox !CallId
callId) !a
message =
  STM Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar (InternalReply a) -> InternalReply a -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar (InternalReply a)
replyBox (a -> InternalReply a
forall a b. b -> Either a b
Right a
message))
    m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
success -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (DuplicateReply -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (CallId -> DuplicateReply
DuplicateReply CallId
callId))

-- | Exception thrown by 'replyTo' when 'replyTo' is call more than once.
newtype DuplicateReply = DuplicateReply CallId deriving stock (DuplicateReply -> DuplicateReply -> Bool
(DuplicateReply -> DuplicateReply -> Bool)
-> (DuplicateReply -> DuplicateReply -> Bool) -> Eq DuplicateReply
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DuplicateReply -> DuplicateReply -> Bool
$c/= :: DuplicateReply -> DuplicateReply -> Bool
== :: DuplicateReply -> DuplicateReply -> Bool
$c== :: DuplicateReply -> DuplicateReply -> Bool
Eq)

instance Show DuplicateReply where
  showsPrec :: Int -> DuplicateReply -> ShowS
showsPrec Int
d (DuplicateReply !CallId
callId) =
    Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
9) (String -> ShowS
showString String
"more than one reply sent for: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallId -> ShowS
forall a. Show a => a -> ShowS
shows CallId
callId)

instance Exception DuplicateReply

-- | Pass on the call to another process.
--
-- Used to implement dispatcher processes.
--
-- Returns 'True' if the 'MessageBox.deliver' operation was
-- successful.
{-# INLINE delegateCall #-}
delegateCall ::
  ( MonadUnliftIO m,
    MessageBox.IsInput o,
    Show (Command apiTag ( 'Return r))
  ) =>
  o (Message apiTag) ->
  Command apiTag ( 'Return r) ->
  ReplyBox r ->
  m Bool
delegateCall :: o (Message apiTag)
-> Command apiTag ('Return r) -> ReplyBox r -> m Bool
delegateCall !o (Message apiTag)
o !Command apiTag ('Return r)
c !ReplyBox r
r =
  o (Message apiTag) -> Message apiTag -> m Bool
forall (input :: * -> *) (m :: * -> *) a.
(IsInput input, MonadUnliftIO m) =>
input a -> a -> m Bool
MessageBox.deliver o (Message apiTag)
o (Command apiTag ('Return r) -> ReplyBox r -> Message apiTag
forall apiTag result.
Show (Command apiTag ('Return result)) =>
Command apiTag ('Return result)
-> ReplyBox result -> Message apiTag
Blocking Command apiTag ('Return r)
c ReplyBox r
r)

-- ** Non-Blocking call API

-- |  Enqueue a 'Blocking' 'Message' into an 'MessageBox.IsInput'.
--
-- If the call to 'deliver' fails, return @Nothing@ otherwise
-- @Just@ the 'AsyncReply'.
--
-- The receiving process must use 'replyTo'  with the 'ReplyBox'
-- received along side the 'Command' in the 'Blocking'.
callAsync ::
  ( HasCallIdCounter env,
    MonadReader env m,
    MonadUnliftIO m,
    MessageBox.IsInput o,
    Show (Command apiTag ( 'Return result))
  ) =>
  o (Message apiTag) ->
  Command apiTag ( 'Return result) ->
  m (Maybe (AsyncReply result))
callAsync :: o (Message apiTag)
-> Command apiTag ('Return result) -> m (Maybe (AsyncReply result))
callAsync !o (Message apiTag)
input !Command apiTag ('Return result)
pdu = do
  !CallId
callId <- m CallId
forall env (m :: * -> *).
(MonadReader env m, HasCallIdCounter env, MonadUnliftIO m) =>
m CallId
CallId.takeNext
  !TMVar (InternalReply result)
resultVar <- m (TMVar (InternalReply result))
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
  !Bool
sendSuccessful <- do
    let !rbox :: ReplyBox result
rbox = TMVar (InternalReply result) -> CallId -> ReplyBox result
forall a. TMVar (InternalReply a) -> CallId -> ReplyBox a
MkReplyBox TMVar (InternalReply result)
resultVar CallId
callId
    let !msg :: Message apiTag
msg = Command apiTag ('Return result)
-> ReplyBox result -> Message apiTag
forall apiTag result.
Show (Command apiTag ('Return result)) =>
Command apiTag ('Return result)
-> ReplyBox result -> Message apiTag
Blocking Command apiTag ('Return result)
pdu ReplyBox result
rbox
    o (Message apiTag) -> Message apiTag -> m Bool
forall (input :: * -> *) (m :: * -> *) a.
(IsInput input, MonadUnliftIO m) =>
input a -> a -> m Bool
MessageBox.deliver o (Message apiTag)
input Message apiTag
msg
  if Bool
sendSuccessful
    then Maybe (AsyncReply result) -> m (Maybe (AsyncReply result))
forall (m :: * -> *) a. Monad m => a -> m a
return (AsyncReply result -> Maybe (AsyncReply result)
forall a. a -> Maybe a
Just (CallId -> TMVar (InternalReply result) -> AsyncReply result
forall r. CallId -> TMVar (InternalReply r) -> AsyncReply r
MkAsyncReply CallId
callId TMVar (InternalReply result)
resultVar))
    else Maybe (AsyncReply result) -> m (Maybe (AsyncReply result))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (AsyncReply result)
forall a. Maybe a
Nothing

-- | The result of 'callAsync'.
-- Use 'waitForReply' or 'tryTakeReply'.
data AsyncReply r
  = MkAsyncReply !CallId !(TMVar (InternalReply r))

instance (Typeable r) => Show (AsyncReply r) where
  showsPrec :: Int -> AsyncReply r -> ShowS
showsPrec !Int
d (MkAsyncReply !CallId
cId TMVar (InternalReply r)
_) =
    Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
9) (String -> ShowS
showString String
"AR: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallId -> ShowS
forall a. Show a => a -> ShowS
shows CallId
cId)

-- | Wait for the reply of a 'Blocking' 'Message'
-- sent by 'callAsync'.
{-# INLINE waitForReply #-}
waitForReply ::
  MonadUnliftIO m =>
  -- | The time in micro seconds to wait
  -- before returning 'Left' 'BlockingCommandTimedOut'
  Int ->
  AsyncReply result ->
  m (Either CommandError result)
waitForReply :: Int -> AsyncReply result -> m (Either CommandError result)
waitForReply !Int
t (MkAsyncReply !CallId
cId !TMVar (Either CommandError result)
rVar) = do
  !TVar Bool
delay <- Int -> m (TVar Bool)
forall (m :: * -> *). MonadIO m => Int -> m (TVar Bool)
registerDelay Int
t
  STM (Either CommandError result) -> m (Either CommandError result)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically
    ( ( do
          !Bool
hasTimedOut <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
delay
          Bool -> STM ()
checkSTM Bool
hasTimedOut
          Either CommandError result -> STM (Either CommandError result)
forall (m :: * -> *) a. Monad m => a -> m a
return (CommandError -> Either CommandError result
forall a b. a -> Either a b
Left (CallId -> CommandError
BlockingCommandTimedOut CallId
cId))
      )
        STM (Either CommandError result)
-> STM (Either CommandError result)
-> STM (Either CommandError result)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TMVar (Either CommandError result)
-> STM (Either CommandError result)
forall a. TMVar a -> STM a
readTMVar TMVar (Either CommandError result)
rVar
    )

-- | If a reply for an 'callAsync' operation is available
-- return it, otherwise return 'Nothing'.
{-# INLINE tryTakeReply #-}
tryTakeReply ::
  MonadUnliftIO m =>
  AsyncReply result ->
  m (Maybe (Either CommandError result))
tryTakeReply :: AsyncReply result -> m (Maybe (Either CommandError result))
tryTakeReply (MkAsyncReply CallId
_expectedCallId !TMVar (Either CommandError result)
resultVar) = do
  !Maybe (Either CommandError result)
maybeTheResult <- STM (Maybe (Either CommandError result))
-> m (Maybe (Either CommandError result))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar (Either CommandError result)
-> STM (Maybe (Either CommandError result))
forall a. TMVar a -> STM (Maybe a)
tryReadTMVar TMVar (Either CommandError result)
resultVar)
  case Maybe (Either CommandError result)
maybeTheResult of
    Maybe (Either CommandError result)
Nothing ->
      Maybe (Either CommandError result)
-> m (Maybe (Either CommandError result))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either CommandError result)
forall a. Maybe a
Nothing
    Just !Either CommandError result
result ->
      Maybe (Either CommandError result)
-> m (Maybe (Either CommandError result))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either CommandError result -> Maybe (Either CommandError result)
forall a. a -> Maybe a
Just Either CommandError result
result)