{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Ouroboros.Network.Protocol.LocalTxMonitor.Direct (direct) where

import Control.Monad (join)

import Ouroboros.Network.Protocol.LocalTxMonitor.Client
import Ouroboros.Network.Protocol.LocalTxMonitor.Server

direct :: forall m txid tx slot a b.
          ( Monad m
          )
       => LocalTxMonitorClient txid tx slot m a
       -> LocalTxMonitorServer txid tx slot m b
       -> m (a, b)
direct :: forall (m :: * -> *) txid tx slot a b.
Monad m =>
LocalTxMonitorClient txid tx slot m a
-> LocalTxMonitorServer txid tx slot m b -> m (a, b)
direct (LocalTxMonitorClient m (ClientStIdle txid tx slot m a)
mClient) (LocalTxMonitorServer m (ServerStIdle txid tx slot m b)
mServer) = do
    m (m (a, b)) -> m (a, b)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (ServerStIdle txid tx slot m b
-> ClientStIdle txid tx slot m a -> m (a, b)
directIdle (ServerStIdle txid tx slot m b
 -> ClientStIdle txid tx slot m a -> m (a, b))
-> m (ServerStIdle txid tx slot m b)
-> m (ClientStIdle txid tx slot m a -> m (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ServerStIdle txid tx slot m b)
mServer m (ClientStIdle txid tx slot m a -> m (a, b))
-> m (ClientStIdle txid tx slot m a) -> m (m (a, b))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (ClientStIdle txid tx slot m a)
mClient)
  where
    directIdle ::
         ServerStIdle txid tx slot m b
      -> ClientStIdle txid tx slot m a
      -> m (a, b)
    directIdle :: ServerStIdle txid tx slot m b
-> ClientStIdle txid tx slot m a -> m (a, b)
directIdle ServerStIdle
      { m b
recvMsgDone :: m b
recvMsgDone :: forall txid tx slot (m :: * -> *) a.
ServerStIdle txid tx slot m a -> m a
recvMsgDone
      , m (ServerStAcquiring txid tx slot m b)
recvMsgAcquire :: m (ServerStAcquiring txid tx slot m b)
recvMsgAcquire :: forall txid tx slot (m :: * -> *) a.
ServerStIdle txid tx slot m a
-> m (ServerStAcquiring txid tx slot m a)
recvMsgAcquire
      } = \case
        SendMsgDone a
a -> do
          b <- m b
recvMsgDone
          pure (a, b)
        SendMsgAcquire slot -> m (ClientStAcquired txid tx slot m a)
mClientStAcquired -> do
          SendMsgAcquired slot serverStAcquired <- m (ServerStAcquiring txid tx slot m b)
recvMsgAcquire
          clientStAcquired <- mClientStAcquired slot
          directAcquired serverStAcquired clientStAcquired

    directAcquired ::
         ServerStAcquired txid tx slot m b
      -> ClientStAcquired txid tx slot m a
      -> m (a, b)
    directAcquired :: ServerStAcquired txid tx slot m b
-> ClientStAcquired txid tx slot m a -> m (a, b)
directAcquired ServerStAcquired
      { m (ServerStIdle txid tx slot m b)
recvMsgRelease :: m (ServerStIdle txid tx slot m b)
recvMsgRelease :: forall txid tx slot (m :: * -> *) a.
ServerStAcquired txid tx slot m a
-> m (ServerStIdle txid tx slot m a)
recvMsgRelease
      , m (ServerStAcquiring txid tx slot m b)
recvMsgAwaitAcquire :: m (ServerStAcquiring txid tx slot m b)
recvMsgAwaitAcquire :: forall txid tx slot (m :: * -> *) a.
ServerStAcquired txid tx slot m a
-> m (ServerStAcquiring txid tx slot m a)
recvMsgAwaitAcquire
      , m (ServerStBusy 'NextTx txid tx slot m b)
recvMsgNextTx :: m (ServerStBusy 'NextTx txid tx slot m b)
recvMsgNextTx :: forall txid tx slot (m :: * -> *) a.
ServerStAcquired txid tx slot m a
-> m (ServerStBusy 'NextTx txid tx slot m a)
recvMsgNextTx
      , txid -> m (ServerStBusy 'HasTx txid tx slot m b)
recvMsgHasTx :: txid -> m (ServerStBusy 'HasTx txid tx slot m b)
recvMsgHasTx :: forall txid tx slot (m :: * -> *) a.
ServerStAcquired txid tx slot m a
-> txid -> m (ServerStBusy 'HasTx txid tx slot m a)
recvMsgHasTx
      , m (ServerStBusy 'GetSizes txid tx slot m b)
recvMsgGetSizes :: m (ServerStBusy 'GetSizes txid tx slot m b)
recvMsgGetSizes :: forall txid tx slot (m :: * -> *) a.
ServerStAcquired txid tx slot m a
-> m (ServerStBusy 'GetSizes txid tx slot m a)
recvMsgGetSizes
      } = \case
        SendMsgRelease m (ClientStIdle txid tx slot m a)
mClientStIdle -> do
          serverStIdle <- m (ServerStIdle txid tx slot m b)
recvMsgRelease
          clientStIdle <- mClientStIdle
          directIdle serverStIdle clientStIdle
        SendMsgAwaitAcquire slot -> m (ClientStAcquired txid tx slot m a)
mClientStAcquired -> do
          SendMsgAcquired slot serverStAcquired <- m (ServerStAcquiring txid tx slot m b)
recvMsgAwaitAcquire
          clientStAcquired <- mClientStAcquired slot
          directAcquired serverStAcquired clientStAcquired
        SendMsgNextTx Maybe tx -> m (ClientStAcquired txid tx slot m a)
mClientStAcquired -> do
          m (ServerStBusy 'NextTx txid tx slot m b)
recvMsgNextTx m (ServerStBusy 'NextTx txid tx slot m b)
-> (ServerStBusy 'NextTx txid tx slot m b -> m (a, b)) -> m (a, b)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            SendMsgReplyNextTx Maybe tx
result ServerStAcquired txid tx slot m b
serverStAcquired -> do
              clientStAcquired <- Maybe tx -> m (ClientStAcquired txid tx slot m a)
mClientStAcquired Maybe tx
result
              directAcquired serverStAcquired clientStAcquired
        SendMsgHasTx txid
txid Bool -> m (ClientStAcquired txid tx slot m a)
mClientStAcquired -> do
          txid -> m (ServerStBusy 'HasTx txid tx slot m b)
recvMsgHasTx txid
txid m (ServerStBusy 'HasTx txid tx slot m b)
-> (ServerStBusy 'HasTx txid tx slot m b -> m (a, b)) -> m (a, b)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            SendMsgReplyHasTx Bool
result ServerStAcquired txid tx slot m b
serverStAcquired -> do
              clientStAcquired <- Bool -> m (ClientStAcquired txid tx slot m a)
mClientStAcquired Bool
result
              directAcquired serverStAcquired clientStAcquired
        SendMsgGetSizes MempoolSizeAndCapacity -> m (ClientStAcquired txid tx slot m a)
mClientStAcquired -> do
          m (ServerStBusy 'GetSizes txid tx slot m b)
recvMsgGetSizes m (ServerStBusy 'GetSizes txid tx slot m b)
-> (ServerStBusy 'GetSizes txid tx slot m b -> m (a, b))
-> m (a, b)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            SendMsgReplyGetSizes MempoolSizeAndCapacity
result ServerStAcquired txid tx slot m b
serverStAcquired -> do
              clientStAcquired <- MempoolSizeAndCapacity -> m (ClientStAcquired txid tx slot m a)
mClientStAcquired MempoolSizeAndCapacity
result
              directAcquired serverStAcquired clientStAcquired