{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Ouroboros.Network.Protocol.BlockFetch.Server where

import           Network.TypedProtocol.Core (Peer (..), PeerHasAgency (..),
                     PeerRole (..))

import           Ouroboros.Network.Protocol.BlockFetch.Type


data BlockFetchServer block point m a where
  BlockFetchServer
    :: (ChainRange point -> m (BlockFetchBlockSender block point m a))
    -> a
    -> BlockFetchServer block point m a

-- | Send batches of blocks, when a batch is sent loop using
-- @'BlockFetchServer'@.
--
data BlockFetchBlockSender block point m a where

  -- | Initiate a batch of blocks.
  SendMsgStartBatch
    :: m (BlockFetchSendBlocks block point m a)
    -> BlockFetchBlockSender block point m a

  SendMsgNoBlocks
    :: m (BlockFetchServer block point m a)
    -> BlockFetchBlockSender block point m a

-- | Stream batch of blocks
--
data BlockFetchSendBlocks block point m a where

  -- | Send a single block and recurse.
  --
  SendMsgBlock
    :: block
    -> m (BlockFetchSendBlocks block point m a)
    -> BlockFetchSendBlocks block point m a

  -- | End of the stream of block bodies.
  --
  SendMsgBatchDone
    :: m (BlockFetchServer block point m a)
    -> BlockFetchSendBlocks block point m a

blockFetchServerPeer
  :: forall block point m a.
     Functor m
  => BlockFetchServer block point m a
  -> Peer (BlockFetch block point) AsServer BFIdle m a
blockFetchServerPeer :: BlockFetchServer block point m a
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
blockFetchServerPeer (BlockFetchServer ChainRange point -> m (BlockFetchBlockSender block point m a)
requestHandler a
result) =
    TheyHaveAgency 'AsServer 'BFIdle
-> (forall (st' :: BlockFetch block point).
    Message (BlockFetch block point) 'BFIdle st'
    -> Peer (BlockFetch block point) 'AsServer st' m a)
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
forall (pr :: PeerRole) ps (st :: ps) (m :: * -> *) a.
TheyHaveAgency pr st
-> (forall (st' :: ps). Message ps st st' -> Peer ps pr st' m a)
-> Peer ps pr st m a
Await (ClientHasAgency 'BFIdle -> PeerHasAgency 'AsClient 'BFIdle
forall ps (st :: ps).
ClientHasAgency st -> PeerHasAgency 'AsClient st
ClientAgency ClientHasAgency 'BFIdle
forall k k (block :: k) (point :: k). ClientHasAgency 'BFIdle
TokIdle) ((forall (st' :: BlockFetch block point).
  Message (BlockFetch block point) 'BFIdle st'
  -> Peer (BlockFetch block point) 'AsServer st' m a)
 -> Peer (BlockFetch block point) 'AsServer 'BFIdle m a)
-> (forall (st' :: BlockFetch block point).
    Message (BlockFetch block point) 'BFIdle st'
    -> Peer (BlockFetch block point) 'AsServer st' m a)
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
forall a b. (a -> b) -> a -> b
$ \Message (BlockFetch block point) 'BFIdle st'
msg -> case Message (BlockFetch block point) 'BFIdle st'
msg of
      MsgRequestRange range -> m (Peer (BlockFetch block point) 'AsServer 'BFBusy m a)
-> Peer (BlockFetch block point) 'AsServer 'BFBusy m a
forall (m :: * -> *) ps (pr :: PeerRole) (st :: ps) a.
m (Peer ps pr st m a) -> Peer ps pr st m a
Effect (m (Peer (BlockFetch block point) 'AsServer 'BFBusy m a)
 -> Peer (BlockFetch block point) 'AsServer 'BFBusy m a)
-> m (Peer (BlockFetch block point) 'AsServer 'BFBusy m a)
-> Peer (BlockFetch block point) 'AsServer 'BFBusy m a
forall a b. (a -> b) -> a -> b
$ BlockFetchBlockSender block point m a
-> Peer (BlockFetch block point) 'AsServer 'BFBusy m a
sendBatch (BlockFetchBlockSender block point m a
 -> Peer (BlockFetch block point) 'AsServer 'BFBusy m a)
-> m (BlockFetchBlockSender block point m a)
-> m (Peer (BlockFetch block point) 'AsServer 'BFBusy m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainRange point -> m (BlockFetchBlockSender block point m a)
requestHandler ChainRange point
ChainRange point
range
      Message (BlockFetch block point) 'BFIdle st'
MsgClientDone         -> NobodyHasAgency 'BFDone
-> a -> Peer (BlockFetch block point) 'AsServer 'BFDone m a
forall ps (st :: ps) a (pr :: PeerRole) (m :: * -> *).
NobodyHasAgency st -> a -> Peer ps pr st m a
Done NobodyHasAgency 'BFDone
forall k k (block :: k) (point :: k). NobodyHasAgency 'BFDone
TokDone a
result
 where
  sendBatch
    :: BlockFetchBlockSender block point m a
    -> Peer (BlockFetch block point) AsServer BFBusy m a

  sendBatch :: BlockFetchBlockSender block point m a
-> Peer (BlockFetch block point) 'AsServer 'BFBusy m a
sendBatch (SendMsgStartBatch m (BlockFetchSendBlocks block point m a)
mblocks) =
    WeHaveAgency 'AsServer 'BFBusy
-> Message (BlockFetch block point) 'BFBusy 'BFStreaming
-> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a
-> Peer (BlockFetch block point) 'AsServer 'BFBusy m a
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps) (m :: * -> *) a.
WeHaveAgency pr st
-> Message ps st st' -> Peer ps pr st' m a -> Peer ps pr st m a
Yield (ServerHasAgency 'BFBusy -> WeHaveAgency 'AsServer 'BFBusy
forall ps (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'BFBusy
forall k k (block :: k) (point :: k). ServerHasAgency 'BFBusy
TokBusy) Message (BlockFetch block point) 'BFBusy 'BFStreaming
forall k k (block :: k) (point :: k).
Message (BlockFetch block point) 'BFBusy 'BFStreaming
MsgStartBatch (Peer (BlockFetch block point) 'AsServer 'BFStreaming m a
 -> Peer (BlockFetch block point) 'AsServer 'BFBusy m a)
-> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a
-> Peer (BlockFetch block point) 'AsServer 'BFBusy m a
forall a b. (a -> b) -> a -> b
$
    m (Peer (BlockFetch block point) 'AsServer 'BFStreaming m a)
-> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a
forall (m :: * -> *) ps (pr :: PeerRole) (st :: ps) a.
m (Peer ps pr st m a) -> Peer ps pr st m a
Effect (m (Peer (BlockFetch block point) 'AsServer 'BFStreaming m a)
 -> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a)
-> m (Peer (BlockFetch block point) 'AsServer 'BFStreaming m a)
-> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a
forall a b. (a -> b) -> a -> b
$
      BlockFetchSendBlocks block point m a
-> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a
sendBlocks (BlockFetchSendBlocks block point m a
 -> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a)
-> m (BlockFetchSendBlocks block point m a)
-> m (Peer (BlockFetch block point) 'AsServer 'BFStreaming m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (BlockFetchSendBlocks block point m a)
mblocks

  sendBatch (SendMsgNoBlocks m (BlockFetchServer block point m a)
next) =
    WeHaveAgency 'AsServer 'BFBusy
-> Message (BlockFetch block point) 'BFBusy 'BFIdle
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
-> Peer (BlockFetch block point) 'AsServer 'BFBusy m a
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps) (m :: * -> *) a.
WeHaveAgency pr st
-> Message ps st st' -> Peer ps pr st' m a -> Peer ps pr st m a
Yield (ServerHasAgency 'BFBusy -> WeHaveAgency 'AsServer 'BFBusy
forall ps (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'BFBusy
forall k k (block :: k) (point :: k). ServerHasAgency 'BFBusy
TokBusy) Message (BlockFetch block point) 'BFBusy 'BFIdle
forall k k (block :: k) (point :: k).
Message (BlockFetch block point) 'BFBusy 'BFIdle
MsgNoBlocks (Peer (BlockFetch block point) 'AsServer 'BFIdle m a
 -> Peer (BlockFetch block point) 'AsServer 'BFBusy m a)
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
-> Peer (BlockFetch block point) 'AsServer 'BFBusy m a
forall a b. (a -> b) -> a -> b
$
    m (Peer (BlockFetch block point) 'AsServer 'BFIdle m a)
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
forall (m :: * -> *) ps (pr :: PeerRole) (st :: ps) a.
m (Peer ps pr st m a) -> Peer ps pr st m a
Effect (m (Peer (BlockFetch block point) 'AsServer 'BFIdle m a)
 -> Peer (BlockFetch block point) 'AsServer 'BFIdle m a)
-> m (Peer (BlockFetch block point) 'AsServer 'BFIdle m a)
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
forall a b. (a -> b) -> a -> b
$
      BlockFetchServer block point m a
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
forall block point (m :: * -> *) a.
Functor m =>
BlockFetchServer block point m a
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
blockFetchServerPeer (BlockFetchServer block point m a
 -> Peer (BlockFetch block point) 'AsServer 'BFIdle m a)
-> m (BlockFetchServer block point m a)
-> m (Peer (BlockFetch block point) 'AsServer 'BFIdle m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (BlockFetchServer block point m a)
next


  sendBlocks
    :: BlockFetchSendBlocks block point m a
    -> Peer (BlockFetch block point) AsServer BFStreaming m a

  sendBlocks :: BlockFetchSendBlocks block point m a
-> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a
sendBlocks (SendMsgBlock block
block m (BlockFetchSendBlocks block point m a)
next') =
    WeHaveAgency 'AsServer 'BFStreaming
-> Message (BlockFetch block point) 'BFStreaming 'BFStreaming
-> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a
-> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps) (m :: * -> *) a.
WeHaveAgency pr st
-> Message ps st st' -> Peer ps pr st' m a -> Peer ps pr st m a
Yield (ServerHasAgency 'BFStreaming -> WeHaveAgency 'AsServer 'BFStreaming
forall ps (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'BFStreaming
forall k k (block :: k) (point :: k). ServerHasAgency 'BFStreaming
TokStreaming) (block -> Message (BlockFetch block point) 'BFStreaming 'BFStreaming
forall k block (point :: k).
block -> Message (BlockFetch block point) 'BFStreaming 'BFStreaming
MsgBlock block
block) (Peer (BlockFetch block point) 'AsServer 'BFStreaming m a
 -> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a)
-> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a
-> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a
forall a b. (a -> b) -> a -> b
$
    m (Peer (BlockFetch block point) 'AsServer 'BFStreaming m a)
-> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a
forall (m :: * -> *) ps (pr :: PeerRole) (st :: ps) a.
m (Peer ps pr st m a) -> Peer ps pr st m a
Effect (m (Peer (BlockFetch block point) 'AsServer 'BFStreaming m a)
 -> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a)
-> m (Peer (BlockFetch block point) 'AsServer 'BFStreaming m a)
-> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a
forall a b. (a -> b) -> a -> b
$
      BlockFetchSendBlocks block point m a
-> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a
sendBlocks (BlockFetchSendBlocks block point m a
 -> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a)
-> m (BlockFetchSendBlocks block point m a)
-> m (Peer (BlockFetch block point) 'AsServer 'BFStreaming m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (BlockFetchSendBlocks block point m a)
next'

  sendBlocks (SendMsgBatchDone m (BlockFetchServer block point m a)
next) =
    WeHaveAgency 'AsServer 'BFStreaming
-> Message (BlockFetch block point) 'BFStreaming 'BFIdle
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
-> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps) (m :: * -> *) a.
WeHaveAgency pr st
-> Message ps st st' -> Peer ps pr st' m a -> Peer ps pr st m a
Yield (ServerHasAgency 'BFStreaming -> WeHaveAgency 'AsServer 'BFStreaming
forall ps (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'BFStreaming
forall k k (block :: k) (point :: k). ServerHasAgency 'BFStreaming
TokStreaming) Message (BlockFetch block point) 'BFStreaming 'BFIdle
forall k k (block :: k) (point :: k).
Message (BlockFetch block point) 'BFStreaming 'BFIdle
MsgBatchDone (Peer (BlockFetch block point) 'AsServer 'BFIdle m a
 -> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a)
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
-> Peer (BlockFetch block point) 'AsServer 'BFStreaming m a
forall a b. (a -> b) -> a -> b
$
    m (Peer (BlockFetch block point) 'AsServer 'BFIdle m a)
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
forall (m :: * -> *) ps (pr :: PeerRole) (st :: ps) a.
m (Peer ps pr st m a) -> Peer ps pr st m a
Effect (m (Peer (BlockFetch block point) 'AsServer 'BFIdle m a)
 -> Peer (BlockFetch block point) 'AsServer 'BFIdle m a)
-> m (Peer (BlockFetch block point) 'AsServer 'BFIdle m a)
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
forall a b. (a -> b) -> a -> b
$
      BlockFetchServer block point m a
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
forall block point (m :: * -> *) a.
Functor m =>
BlockFetchServer block point m a
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
blockFetchServerPeer (BlockFetchServer block point m a
 -> Peer (BlockFetch block point) 'AsServer 'BFIdle m a)
-> m (BlockFetchServer block point m a)
-> m (Peer (BlockFetch block point) 'AsServer 'BFIdle m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (BlockFetchServer block point m a)
next