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

-- | A view of the object diffusion protocol from the point of view of
-- the outbound/server peer.
--
-- This provides a view that uses less complex types and should be easier to
-- use than the underlying typed protocol itself.
--
-- For execution, 'objectDiffusionOutboundPeer' is provided for conversion
-- into the typed protocol.
module Ouroboros.Network.Protocol.ObjectDiffusion.Outbound
  ( -- * Protocol type for the outbound
    ObjectDiffusionOutbound (..)
  , OutboundStIdle (..)
  , OutboundStObjectIds (..)
  , OutboundStObjects (..)
    -- * Execution as a typed protocol
  , objectDiffusionOutboundPeer
  ) where

import Network.TypedProtocol.Core
import Network.TypedProtocol.Peer (Peer)
import Network.TypedProtocol.Peer.Server
import Ouroboros.Network.Protocol.ObjectDiffusion.Type

-- | The outbound side of the object diffusion protocol.
--
-- The peer in the outbound/server role submits objects to the peer in the
-- inbound/client role.
newtype ObjectDiffusionOutbound objectId object m a = ObjectDiffusionOutbound {
      forall objectId object (m :: * -> *) a.
ObjectDiffusionOutbound objectId object m a
-> m (OutboundStIdle objectId object m a)
runObjectDiffusionOutbound :: m (OutboundStIdle objectId object m a)
    }

-- | In the 'StIdle' protocol state, the outbound does not have agency. Instead
-- it is waiting for:
--
-- * a request for object ids (blocking or non-blocking)
-- * a request for a given list of objects
-- * a termination message
--
-- It must be prepared to handle any of these.
data OutboundStIdle objectId object m a = OutboundStIdle {
      forall objectId object (m :: * -> *) a.
OutboundStIdle objectId object m a
-> forall (blocking :: StBlockingStyle).
   SingBlockingStyle blocking
   -> NumObjectIdsAck
   -> NumObjectIdsReq
   -> m (OutboundStObjectIds blocking objectId object m a)
recvMsgRequestObjectIds :: forall blocking.
                                 SingBlockingStyle blocking
                              -> NumObjectIdsAck
                              -> NumObjectIdsReq
                              -> m (OutboundStObjectIds blocking objectId object m a),
      forall objectId object (m :: * -> *) a.
OutboundStIdle objectId object m a
-> [objectId] -> m (OutboundStObjects objectId object m a)
recvMsgRequestObjects   :: [objectId]
                              -> m (OutboundStObjects objectId object m a),
      forall objectId object (m :: * -> *) a.
OutboundStIdle objectId object m a -> m a
recvMsgDone             :: m a
    }

data OutboundStObjectIds blocking objectId object m a where
  SendMsgReplyObjectIds
    :: BlockingReplyList blocking objectId
    -> OutboundStIdle objectId object m a
    -> OutboundStObjectIds blocking objectId object m a

data OutboundStObjects objectId object m a where
  SendMsgReplyObjects
    :: [object]
    -> OutboundStIdle objectId object m a
    -> OutboundStObjects objectId object m a

-- | A non-pipelined 'Peer' representing the 'ObjectDiffusionOutbound'.
objectDiffusionOutboundPeer
  :: forall objectId object m a.
     Monad m
  => ObjectDiffusionOutbound objectId object m a
  -> Peer (ObjectDiffusion objectId object) AsServer NonPipelined StInit m a
objectDiffusionOutboundPeer :: forall objectId object (m :: * -> *) a.
Monad m =>
ObjectDiffusionOutbound objectId object m a
-> Peer
     (ObjectDiffusion objectId object)
     'AsServer
     'NonPipelined
     'StInit
     m
     a
objectDiffusionOutboundPeer (ObjectDiffusionOutbound m (OutboundStIdle objectId object m a)
outboundSt) =
    (forall (st' :: ObjectDiffusion objectId object).
 Message (ObjectDiffusion objectId object) 'StInit st'
 -> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a)
-> Server
     (ObjectDiffusion objectId object) 'NonPipelined 'StInit m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
(StateTokenI st, StateAgency st ~ 'ClientAgency,
 Outstanding pl ~ 'Z) =>
(forall (st' :: ps). Message ps st st' -> Server ps pl st' m a)
-> Server ps pl st m a
Await
      (\Message (ObjectDiffusion objectId object) 'StInit st'
R:MessageObjectDiffusionfromto objectId object 'StInit st'
MsgInit -> m (Server (ObjectDiffusion objectId object) 'NonPipelined st' m a)
-> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
m (Server ps pl st m a) -> Server ps pl st m a
Effect (OutboundStIdle objectId object m a
-> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a
OutboundStIdle objectId object m a
-> Peer
     (ObjectDiffusion objectId object)
     'AsServer
     'NonPipelined
     'StIdle
     m
     a
run (OutboundStIdle objectId object m a
 -> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a)
-> m (OutboundStIdle objectId object m a)
-> m (Server
        (ObjectDiffusion objectId object) 'NonPipelined st' m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (OutboundStIdle objectId object m a)
outboundSt))
  where
    run
      :: OutboundStIdle objectId object m a
      -> Peer (ObjectDiffusion objectId object) AsServer NonPipelined StIdle m a
    run :: OutboundStIdle objectId object m a
-> Peer
     (ObjectDiffusion objectId object)
     'AsServer
     'NonPipelined
     'StIdle
     m
     a
run OutboundStIdle {forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumObjectIdsAck
-> NumObjectIdsReq
-> m (OutboundStObjectIds blocking objectId object m a)
recvMsgRequestObjectIds :: forall objectId object (m :: * -> *) a.
OutboundStIdle objectId object m a
-> forall (blocking :: StBlockingStyle).
   SingBlockingStyle blocking
   -> NumObjectIdsAck
   -> NumObjectIdsReq
   -> m (OutboundStObjectIds blocking objectId object m a)
recvMsgRequestObjectIds :: forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumObjectIdsAck
-> NumObjectIdsReq
-> m (OutboundStObjectIds blocking objectId object m a)
recvMsgRequestObjectIds, [objectId] -> m (OutboundStObjects objectId object m a)
recvMsgRequestObjects :: forall objectId object (m :: * -> *) a.
OutboundStIdle objectId object m a
-> [objectId] -> m (OutboundStObjects objectId object m a)
recvMsgRequestObjects :: [objectId] -> m (OutboundStObjects objectId object m a)
recvMsgRequestObjects, m a
recvMsgDone :: forall objectId object (m :: * -> *) a.
OutboundStIdle objectId object m a -> m a
recvMsgDone :: m a
recvMsgDone} =
      (forall (st' :: ObjectDiffusion objectId object).
 Message (ObjectDiffusion objectId object) 'StIdle st'
 -> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a)
-> Peer
     (ObjectDiffusion objectId object)
     'AsServer
     'NonPipelined
     'StIdle
     m
     a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
(StateTokenI st, StateAgency st ~ 'ClientAgency,
 Outstanding pl ~ 'Z) =>
(forall (st' :: ps). Message ps st st' -> Server ps pl st' m a)
-> Server ps pl st m a
Await ((forall (st' :: ObjectDiffusion objectId object).
  Message (ObjectDiffusion objectId object) 'StIdle st'
  -> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a)
 -> Peer
      (ObjectDiffusion objectId object)
      'AsServer
      'NonPipelined
      'StIdle
      m
      a)
-> (forall (st' :: ObjectDiffusion objectId object).
    Message (ObjectDiffusion objectId object) 'StIdle st'
    -> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a)
-> Peer
     (ObjectDiffusion objectId object)
     'AsServer
     'NonPipelined
     'StIdle
     m
     a
forall a b. (a -> b) -> a -> b
$ \case
        MsgRequestObjectIds SingBlockingStyle blocking
blocking NumObjectIdsAck
ackNo NumObjectIdsReq
reqNo -> m (Server (ObjectDiffusion objectId object) 'NonPipelined st' m a)
-> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
m (Server ps pl st m a) -> Server ps pl st m a
Effect (m (Server (ObjectDiffusion objectId object) 'NonPipelined st' m a)
 -> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a)
-> m (Server
        (ObjectDiffusion objectId object) 'NonPipelined st' m a)
-> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a
forall a b. (a -> b) -> a -> b
$ do
          reply <- SingBlockingStyle blocking
-> NumObjectIdsAck
-> NumObjectIdsReq
-> m (OutboundStObjectIds blocking objectId object m a)
forall (blocking :: StBlockingStyle).
SingBlockingStyle blocking
-> NumObjectIdsAck
-> NumObjectIdsReq
-> m (OutboundStObjectIds blocking objectId object m a)
recvMsgRequestObjectIds SingBlockingStyle blocking
blocking NumObjectIdsAck
ackNo NumObjectIdsReq
reqNo
          case reply of
            SendMsgReplyObjectIds BlockingReplyList blocking objectId
objectIds OutboundStIdle objectId object m a
k ->
              -- TODO: investigate why GHC cannot infer `SingI`; it used to in
              -- `coot/typed-protocols-rewrite` branch
              Server (ObjectDiffusion objectId object) 'NonPipelined st' m a
-> m (Server
        (ObjectDiffusion objectId object) 'NonPipelined st' m a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Server (ObjectDiffusion objectId object) 'NonPipelined st' m a
 -> m (Server
         (ObjectDiffusion objectId object) 'NonPipelined st' m a))
-> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a
-> m (Server
        (ObjectDiffusion objectId object) 'NonPipelined st' m a)
forall a b. (a -> b) -> a -> b
$ case SingBlockingStyle blocking
blocking of
                SingBlockingStyle blocking
SingBlocking ->
                  Message (ObjectDiffusion objectId object) st' 'StIdle
-> Peer
     (ObjectDiffusion objectId object)
     'AsServer
     'NonPipelined
     'StIdle
     m
     a
-> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a
       (st' :: ps).
(StateTokenI st, StateTokenI st', StateAgency st ~ 'ServerAgency,
 Outstanding pl ~ 'Z) =>
Message ps st st' -> Server ps pl st' m a -> Server ps pl st m a
Yield
                    (BlockingReplyList blocking objectId
-> Message
     (ObjectDiffusion objectId object) ('StObjectIds blocking) 'StIdle
forall (blocking :: StBlockingStyle) objectId object.
BlockingReplyList blocking objectId
-> Message
     (ObjectDiffusion objectId object) ('StObjectIds blocking) 'StIdle
MsgReplyObjectIds BlockingReplyList blocking objectId
objectIds)
                    (OutboundStIdle objectId object m a
-> Peer
     (ObjectDiffusion objectId object)
     'AsServer
     'NonPipelined
     'StIdle
     m
     a
run OutboundStIdle objectId object m a
k)
                SingBlockingStyle blocking
SingNonBlocking ->
                  Message (ObjectDiffusion objectId object) st' 'StIdle
-> Peer
     (ObjectDiffusion objectId object)
     'AsServer
     'NonPipelined
     'StIdle
     m
     a
-> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a
       (st' :: ps).
(StateTokenI st, StateTokenI st', StateAgency st ~ 'ServerAgency,
 Outstanding pl ~ 'Z) =>
Message ps st st' -> Server ps pl st' m a -> Server ps pl st m a
Yield
                    (BlockingReplyList blocking objectId
-> Message
     (ObjectDiffusion objectId object) ('StObjectIds blocking) 'StIdle
forall (blocking :: StBlockingStyle) objectId object.
BlockingReplyList blocking objectId
-> Message
     (ObjectDiffusion objectId object) ('StObjectIds blocking) 'StIdle
MsgReplyObjectIds BlockingReplyList blocking objectId
objectIds)
                    (OutboundStIdle objectId object m a
-> Peer
     (ObjectDiffusion objectId object)
     'AsServer
     'NonPipelined
     'StIdle
     m
     a
run OutboundStIdle objectId object m a
k)
        MsgRequestObjects [objectId]
objectIds -> m (Server (ObjectDiffusion objectId object) 'NonPipelined st' m a)
-> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
m (Server ps pl st m a) -> Server ps pl st m a
Effect (m (Server (ObjectDiffusion objectId object) 'NonPipelined st' m a)
 -> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a)
-> m (Server
        (ObjectDiffusion objectId object) 'NonPipelined st' m a)
-> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a
forall a b. (a -> b) -> a -> b
$ do
          SendMsgReplyObjects objects k <- [objectId] -> m (OutboundStObjects objectId object m a)
recvMsgRequestObjects [objectId]
objectIds
          return $
            Yield
              (MsgReplyObjects objects)
              (run k)
        Message (ObjectDiffusion objectId object) 'StIdle st'
R:MessageObjectDiffusionfromto objectId object 'StIdle st'
MsgDone -> m (Server (ObjectDiffusion objectId object) 'NonPipelined st' m a)
-> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
m (Server ps pl st m a) -> Server ps pl st m a
Effect (m (Server (ObjectDiffusion objectId object) 'NonPipelined st' m a)
 -> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a)
-> m (Server
        (ObjectDiffusion objectId object) 'NonPipelined st' m a)
-> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a
forall a b. (a -> b) -> a -> b
$ a -> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a
forall ps (pl :: IsPipelined) (st :: ps) (m :: * -> *) a.
(StateTokenI st, StateAgency st ~ 'NobodyAgency,
 Outstanding pl ~ 'Z) =>
a -> Server ps pl st m a
Done (a
 -> Server (ObjectDiffusion objectId object) 'NonPipelined st' m a)
-> m a
-> m (Server
        (ObjectDiffusion objectId object) 'NonPipelined st' m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
recvMsgDone