{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Ouroboros.Network.Protocol.BlockFetch.Server where

import Network.TypedProtocol.Core
import Network.TypedProtocol.Peer.Server

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
  -> Server (BlockFetch block point) NonPipelined BFIdle m a
blockFetchServerPeer :: forall block point (m :: * -> *) a.
Functor m =>
BlockFetchServer block point m a
-> Server (BlockFetch block point) 'NonPipelined 'BFIdle m a
blockFetchServerPeer (BlockFetchServer ChainRange point -> m (BlockFetchBlockSender block point m a)
requestHandler a
result) =
    (forall (st' :: BlockFetch block point).
 Message (BlockFetch block point) 'BFIdle st'
 -> Server (BlockFetch block point) 'NonPipelined st' m a)
-> Server (BlockFetch block point) 'NonPipelined 'BFIdle 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' :: BlockFetch block point).
  Message (BlockFetch block point) 'BFIdle st'
  -> Server (BlockFetch block point) 'NonPipelined st' m a)
 -> Server (BlockFetch block point) 'NonPipelined 'BFIdle m a)
-> (forall (st' :: BlockFetch block point).
    Message (BlockFetch block point) 'BFIdle st'
    -> Server (BlockFetch block point) 'NonPipelined st' m a)
-> Server (BlockFetch block point) 'NonPipelined '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 ChainRange point1
range -> m (Server (BlockFetch block point) 'NonPipelined st' m a)
-> Server (BlockFetch block point) '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 (BlockFetch block point) 'NonPipelined st' m a)
 -> Server (BlockFetch block point) 'NonPipelined st' m a)
-> m (Server (BlockFetch block point) 'NonPipelined st' m a)
-> Server (BlockFetch block point) 'NonPipelined st' m a
forall a b. (a -> b) -> a -> b
$ BlockFetchBlockSender block point m a
-> Server (BlockFetch block point) 'NonPipelined st' m a
BlockFetchBlockSender block point m a
-> Server (BlockFetch block point) 'NonPipelined 'BFBusy m a
sendBatch (BlockFetchBlockSender block point m a
 -> Server (BlockFetch block point) 'NonPipelined st' m a)
-> m (BlockFetchBlockSender block point m a)
-> m (Server (BlockFetch block point) 'NonPipelined st' 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 point1
range
      Message (BlockFetch block point) 'BFIdle st'
R:MessageBlockFetchfromto (*) (*) block point 'BFIdle st'
MsgClientDone         -> a -> Server (BlockFetch block point) '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
result
 where
  sendBatch
    :: BlockFetchBlockSender block point m a
    -> Server (BlockFetch block point) NonPipelined BFBusy m a

  sendBatch :: BlockFetchBlockSender block point m a
-> Server (BlockFetch block point) 'NonPipelined 'BFBusy m a
sendBatch (SendMsgStartBatch m (BlockFetchSendBlocks block point m a)
mblocks) =
    Message (BlockFetch block point) 'BFBusy 'BFStreaming
-> Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a
-> Server (BlockFetch block point) 'NonPipelined 'BFBusy 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 Message (BlockFetch block point) 'BFBusy 'BFStreaming
forall {k} {k1} (block :: k) (point :: k1).
Message (BlockFetch block point) 'BFBusy 'BFStreaming
MsgStartBatch (Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a
 -> Server (BlockFetch block point) 'NonPipelined 'BFBusy m a)
-> Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a
-> Server (BlockFetch block point) 'NonPipelined 'BFBusy m a
forall a b. (a -> b) -> a -> b
$
    m (Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a)
-> Server (BlockFetch block point) 'NonPipelined 'BFStreaming 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 (BlockFetch block point) 'NonPipelined 'BFStreaming m a)
 -> Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a)
-> m (Server
        (BlockFetch block point) 'NonPipelined 'BFStreaming m a)
-> Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a
forall a b. (a -> b) -> a -> b
$
      BlockFetchSendBlocks block point m a
-> Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a
sendBlocks (BlockFetchSendBlocks block point m a
 -> Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a)
-> m (BlockFetchSendBlocks block point m a)
-> m (Server
        (BlockFetch block point) 'NonPipelined '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) =
    Message (BlockFetch block point) 'BFBusy 'BFIdle
-> Server (BlockFetch block point) 'NonPipelined 'BFIdle m a
-> Server (BlockFetch block point) 'NonPipelined 'BFBusy 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 Message (BlockFetch block point) 'BFBusy 'BFIdle
forall {k} {k1} (block :: k) (point :: k1).
Message (BlockFetch block point) 'BFBusy 'BFIdle
MsgNoBlocks (Server (BlockFetch block point) 'NonPipelined 'BFIdle m a
 -> Server (BlockFetch block point) 'NonPipelined 'BFBusy m a)
-> Server (BlockFetch block point) 'NonPipelined 'BFIdle m a
-> Server (BlockFetch block point) 'NonPipelined 'BFBusy m a
forall a b. (a -> b) -> a -> b
$
    m (Server (BlockFetch block point) 'NonPipelined 'BFIdle m a)
-> Server (BlockFetch block point) 'NonPipelined 'BFIdle 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 (BlockFetch block point) 'NonPipelined 'BFIdle m a)
 -> Server (BlockFetch block point) 'NonPipelined 'BFIdle m a)
-> m (Server (BlockFetch block point) 'NonPipelined 'BFIdle m a)
-> Server (BlockFetch block point) 'NonPipelined 'BFIdle m a
forall a b. (a -> b) -> a -> b
$
      BlockFetchServer block point m a
-> Server (BlockFetch block point) 'NonPipelined 'BFIdle m a
forall block point (m :: * -> *) a.
Functor m =>
BlockFetchServer block point m a
-> Server (BlockFetch block point) 'NonPipelined 'BFIdle m a
blockFetchServerPeer (BlockFetchServer block point m a
 -> Server (BlockFetch block point) 'NonPipelined 'BFIdle m a)
-> m (BlockFetchServer block point m a)
-> m (Server (BlockFetch block point) 'NonPipelined '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
    -> Server (BlockFetch block point) NonPipelined BFStreaming m a

  sendBlocks :: BlockFetchSendBlocks block point m a
-> Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a
sendBlocks (SendMsgBlock block
block m (BlockFetchSendBlocks block point m a)
next') =
    Message (BlockFetch block point) 'BFStreaming 'BFStreaming
-> Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a
-> Server (BlockFetch block point) 'NonPipelined 'BFStreaming 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 (block -> Message (BlockFetch block point) 'BFStreaming 'BFStreaming
forall {k1} block1 (point :: k1).
block1
-> Message (BlockFetch block1 point) 'BFStreaming 'BFStreaming
MsgBlock block
block) (Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a
 -> Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a)
-> Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a
-> Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a
forall a b. (a -> b) -> a -> b
$
    m (Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a)
-> Server (BlockFetch block point) 'NonPipelined 'BFStreaming 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 (BlockFetch block point) 'NonPipelined 'BFStreaming m a)
 -> Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a)
-> m (Server
        (BlockFetch block point) 'NonPipelined 'BFStreaming m a)
-> Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a
forall a b. (a -> b) -> a -> b
$
      BlockFetchSendBlocks block point m a
-> Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a
sendBlocks (BlockFetchSendBlocks block point m a
 -> Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a)
-> m (BlockFetchSendBlocks block point m a)
-> m (Server
        (BlockFetch block point) 'NonPipelined '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) =
    Message (BlockFetch block point) 'BFStreaming 'BFIdle
-> Server (BlockFetch block point) 'NonPipelined 'BFIdle m a
-> Server (BlockFetch block point) 'NonPipelined 'BFStreaming 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 Message (BlockFetch block point) 'BFStreaming 'BFIdle
forall {k} {k1} (block :: k) (point :: k1).
Message (BlockFetch block point) 'BFStreaming 'BFIdle
MsgBatchDone (Server (BlockFetch block point) 'NonPipelined 'BFIdle m a
 -> Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a)
-> Server (BlockFetch block point) 'NonPipelined 'BFIdle m a
-> Server (BlockFetch block point) 'NonPipelined 'BFStreaming m a
forall a b. (a -> b) -> a -> b
$
    m (Server (BlockFetch block point) 'NonPipelined 'BFIdle m a)
-> Server (BlockFetch block point) 'NonPipelined 'BFIdle 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 (BlockFetch block point) 'NonPipelined 'BFIdle m a)
 -> Server (BlockFetch block point) 'NonPipelined 'BFIdle m a)
-> m (Server (BlockFetch block point) 'NonPipelined 'BFIdle m a)
-> Server (BlockFetch block point) 'NonPipelined 'BFIdle m a
forall a b. (a -> b) -> a -> b
$
      BlockFetchServer block point m a
-> Server (BlockFetch block point) 'NonPipelined 'BFIdle m a
forall block point (m :: * -> *) a.
Functor m =>
BlockFetchServer block point m a
-> Server (BlockFetch block point) 'NonPipelined 'BFIdle m a
blockFetchServerPeer (BlockFetchServer block point m a
 -> Server (BlockFetch block point) 'NonPipelined 'BFIdle m a)
-> m (BlockFetchServer block point m a)
-> m (Server (BlockFetch block point) 'NonPipelined 'BFIdle m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (BlockFetchServer block point m a)
next