{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Ouroboros.Network.Protocol.BlockFetch.Direct
  ( direct
  , directPipelined
  ) where

import Control.Monad (join)

import Network.TypedProtocol.Core
import Network.TypedProtocol.Proofs

import Ouroboros.Network.Protocol.BlockFetch.Client
import Ouroboros.Network.Protocol.BlockFetch.Server


-- | Run @'BlockFetchClient'@ and @'BlockFetchServer'@ directly against each
-- other.  This includes running it in any pure monad (e.g. @'Identity'@), and
-- return the result of client and the server.
--
direct
  :: forall block point m a b.
     Monad m
  => BlockFetchClient block point m a
  -> BlockFetchServer block point m b
  -> m (a, b)
direct :: forall block point (m :: * -> *) a b.
Monad m =>
BlockFetchClient block point m a
-> BlockFetchServer block point m b -> m (a, b)
direct (BlockFetchClient m (BlockFetchRequest block point m a)
mclient) BlockFetchServer block point m b
server = m (BlockFetchRequest block point m a)
mclient m (BlockFetchRequest block point m a)
-> (BlockFetchRequest block point m a -> 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
>>= (BlockFetchRequest block point m a
 -> BlockFetchServer block point m b -> m (a, b))
-> BlockFetchServer block point m b
-> BlockFetchRequest block point m a
-> m (a, b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip BlockFetchRequest block point m a
-> BlockFetchServer block point m b -> m (a, b)
go BlockFetchServer block point m b
server
 where
  go :: BlockFetchRequest block point m a
     -> BlockFetchServer  block point m b
     -> m (a, b)

  go :: BlockFetchRequest block point m a
-> BlockFetchServer block point m b -> m (a, b)
go (SendMsgRequestRange ChainRange point
range BlockFetchResponse block m a
resp BlockFetchClient block point m a
client) (BlockFetchServer ChainRange point -> m (BlockFetchBlockSender block point m b)
requestHandler b
_b) =
    ChainRange point -> m (BlockFetchBlockSender block point m b)
requestHandler ChainRange point
range m (BlockFetchBlockSender block point m b)
-> (BlockFetchBlockSender block point 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
>>= BlockFetchClient block point m a
-> BlockFetchResponse block m a
-> BlockFetchBlockSender block point m b
-> m (a, b)
sendBatch BlockFetchClient block point m a
client BlockFetchResponse block m a
resp

  go (SendMsgClientDone a
a) (BlockFetchServer ChainRange point -> m (BlockFetchBlockSender block point m b)
_requestHandler b
b) = (a, b) -> m (a, b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b)


  sendBatch
    :: BlockFetchClient block point m a
    -> BlockFetchResponse block m a
    -> BlockFetchBlockSender block point m b
    -> m (a, b)
  sendBatch :: BlockFetchClient block point m a
-> BlockFetchResponse block m a
-> BlockFetchBlockSender block point m b
-> m (a, b)
sendBatch BlockFetchClient block point m a
client BlockFetchResponse {m (BlockFetchReceiver block m)
handleStartBatch :: m (BlockFetchReceiver block m)
handleStartBatch :: forall {k} block (m :: * -> *) (a :: k).
BlockFetchResponse block m a -> m (BlockFetchReceiver block m)
handleStartBatch} (SendMsgStartBatch m (BlockFetchSendBlocks block point m b)
mblock ) =
    m (m (a, b)) -> m (a, b)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m (a, b)) -> m (a, b)) -> m (m (a, b)) -> m (a, b)
forall a b. (a -> b) -> a -> b
$ BlockFetchClient block point m a
-> BlockFetchReceiver block m
-> BlockFetchSendBlocks block point m b
-> m (a, b)
sendBlocks BlockFetchClient block point m a
client (BlockFetchReceiver block m
 -> BlockFetchSendBlocks block point m b -> m (a, b))
-> m (BlockFetchReceiver block m)
-> m (BlockFetchSendBlocks block point m b -> m (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (BlockFetchReceiver block m)
handleStartBatch m (BlockFetchSendBlocks block point m b -> m (a, b))
-> m (BlockFetchSendBlocks block point m b) -> 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 (BlockFetchSendBlocks block point m b)
mblock

  sendBatch BlockFetchClient block point m a
client BlockFetchResponse {m ()
handleNoBlocks :: m ()
handleNoBlocks :: forall {k} block (m :: * -> *) (a :: k).
BlockFetchResponse block m a -> m ()
handleNoBlocks} (SendMsgNoBlocks m (BlockFetchServer block point m b)
mserver) =
    m ()
handleNoBlocks m ()
-> m (BlockFetchServer block point m b)
-> m (BlockFetchServer block point m b)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m (BlockFetchServer block point m b)
mserver m (BlockFetchServer block point m b)
-> (BlockFetchServer block point 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
>>= BlockFetchClient block point m a
-> BlockFetchServer block point m b -> m (a, b)
forall block point (m :: * -> *) a b.
Monad m =>
BlockFetchClient block point m a
-> BlockFetchServer block point m b -> m (a, b)
direct BlockFetchClient block point m a
client


  sendBlocks
    :: BlockFetchClient block point m a
    -> BlockFetchReceiver block m
    -> BlockFetchSendBlocks block point m b
    -> m (a, b)

  sendBlocks :: BlockFetchClient block point m a
-> BlockFetchReceiver block m
-> BlockFetchSendBlocks block point m b
-> m (a, b)
sendBlocks BlockFetchClient block point m a
client BlockFetchReceiver {block -> m (BlockFetchReceiver block m)
handleBlock :: block -> m (BlockFetchReceiver block m)
handleBlock :: forall block (m :: * -> *).
BlockFetchReceiver block m
-> block -> m (BlockFetchReceiver block m)
handleBlock} (SendMsgBlock block
block m (BlockFetchSendBlocks block point m b)
mblock) =
    m (m (a, b)) -> m (a, b)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m (a, b)) -> m (a, b)) -> m (m (a, b)) -> m (a, b)
forall a b. (a -> b) -> a -> b
$ BlockFetchClient block point m a
-> BlockFetchReceiver block m
-> BlockFetchSendBlocks block point m b
-> m (a, b)
sendBlocks BlockFetchClient block point m a
client (BlockFetchReceiver block m
 -> BlockFetchSendBlocks block point m b -> m (a, b))
-> m (BlockFetchReceiver block m)
-> m (BlockFetchSendBlocks block point m b -> m (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> block -> m (BlockFetchReceiver block m)
handleBlock block
block m (BlockFetchSendBlocks block point m b -> m (a, b))
-> m (BlockFetchSendBlocks block point m b) -> 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 (BlockFetchSendBlocks block point m b)
mblock

  sendBlocks BlockFetchClient block point m a
client BlockFetchReceiver {m ()
handleBatchDone :: m ()
handleBatchDone :: forall block (m :: * -> *). BlockFetchReceiver block m -> m ()
handleBatchDone} (SendMsgBatchDone m (BlockFetchServer block point m b)
mserver) =
    m ()
handleBatchDone m ()
-> m (BlockFetchServer block point m b)
-> m (BlockFetchServer block point m b)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m (BlockFetchServer block point m b)
mserver m (BlockFetchServer block point m b)
-> (BlockFetchServer block point 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
>>= BlockFetchClient block point m a
-> BlockFetchServer block point m b -> m (a, b)
forall block point (m :: * -> *) a b.
Monad m =>
BlockFetchClient block point m a
-> BlockFetchServer block point m b -> m (a, b)
direct BlockFetchClient block point m a
client


-- | Run a pipelined client against a server, directly, and return the result of
-- both client and the server.
--
directPipelined
  :: forall block point m a b. Monad m
  => BlockFetchClientPipelined block point m a
  -> BlockFetchServer block point m b
  -> m (a, b)
directPipelined :: forall block point (m :: * -> *) a b.
Monad m =>
BlockFetchClientPipelined block point m a
-> BlockFetchServer block point m b -> m (a, b)
directPipelined (BlockFetchClientPipelined BlockFetchSender 'Z c block point m a
client0) BlockFetchServer block point m b
server =
  Queue 'Z c
-> BlockFetchSender 'Z c block point m a
-> BlockFetchServer block point m b
-> m (a, b)
forall (n :: N) c.
Queue n c
-> BlockFetchSender n c block point m a
-> BlockFetchServer block point m b
-> m (a, b)
go Queue 'Z c
forall a. Queue 'Z a
EmptyQ BlockFetchSender 'Z c block point m a
client0 BlockFetchServer block point m b
server
 where
  go :: Queue n c
     -> BlockFetchSender n c block point m a
     -> BlockFetchServer     block point m b
     -> m (a, b)

  go :: forall (n :: N) c.
Queue n c
-> BlockFetchSender n c block point m a
-> BlockFetchServer block point m b
-> m (a, b)
go Queue n c
q (SendMsgRequestRangePipelined ChainRange point
range c
c Maybe block -> c -> m c
receive BlockFetchSender ('S n) c block point m a
next) (BlockFetchServer ChainRange point -> m (BlockFetchBlockSender block point m b)
requestHandler b
_) =
    ChainRange point -> m (BlockFetchBlockSender block point m b)
requestHandler ChainRange point
range m (BlockFetchBlockSender block point m b)
-> (BlockFetchBlockSender block point 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
>>= Queue n c
-> c
-> (Maybe block -> c -> m c)
-> BlockFetchSender ('S n) c block point m a
-> BlockFetchBlockSender block point m b
-> m (a, b)
forall (n :: N) c.
Queue n c
-> c
-> (Maybe block -> c -> m c)
-> BlockFetchSender ('S n) c block point m a
-> BlockFetchBlockSender block point m b
-> m (a, b)
sendBatch Queue n c
q c
c Maybe block -> c -> m c
receive BlockFetchSender ('S n) c block point m a
next

  go (ConsQ c
c Queue n1 c
q) (CollectBlocksPipelined Maybe (BlockFetchSender ('S n1) c block point m a)
_ c -> BlockFetchSender n1 c block point m a
k) BlockFetchServer block point m b
srv =
    Queue n1 c
-> BlockFetchSender n1 c block point m a
-> BlockFetchServer block point m b
-> m (a, b)
forall (n :: N) c.
Queue n c
-> BlockFetchSender n c block point m a
-> BlockFetchServer block point m b
-> m (a, b)
go Queue n1 c
q (c -> BlockFetchSender n1 c block point m a
k c
c) BlockFetchServer block point m b
srv

  go Queue n c
EmptyQ (SendMsgDonePipelined a
a) (BlockFetchServer ChainRange point -> m (BlockFetchBlockSender block point m b)
_ b
b) =
    (a, b) -> m (a, b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b)


  -- The server is will send a batch of block bodies.  At this point the
  -- @'BlockFetchSender'@ is a head of the queue.  After sending all blocks the
  -- client will enqueue the computed result @c@, which will match the @n@
  -- parameter back again.
  sendBatch
    :: Queue n c
    -> c
    -> (Maybe block -> c -> m c)
    -> BlockFetchSender (S n) c block point m a
    -> BlockFetchBlockSender    block point m b
    -> m (a, b)
  sendBatch :: forall (n :: N) c.
Queue n c
-> c
-> (Maybe block -> c -> m c)
-> BlockFetchSender ('S n) c block point m a
-> BlockFetchBlockSender block point m b
-> m (a, b)
sendBatch Queue n c
q c
c  Maybe block -> c -> m c
receive BlockFetchSender ('S n) c block point m a
client (SendMsgStartBatch m (BlockFetchSendBlocks block point m b)
next) =
    m (BlockFetchSendBlocks block point m b)
next m (BlockFetchSendBlocks block point m b)
-> (BlockFetchSendBlocks block point 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
>>= Queue n c
-> c
-> (Maybe block -> c -> m c)
-> BlockFetchSender ('S n) c block point m a
-> BlockFetchSendBlocks block point m b
-> m (a, b)
forall (n :: N) c.
Queue n c
-> c
-> (Maybe block -> c -> m c)
-> BlockFetchSender ('S n) c block point m a
-> BlockFetchSendBlocks block point m b
-> m (a, b)
sendBlocks Queue n c
q c
c Maybe block -> c -> m c
receive BlockFetchSender ('S n) c block point m a
client

  sendBatch Queue n c
q c
c Maybe block -> c -> m c
_receive BlockFetchSender ('S n) c block point m a
client (SendMsgNoBlocks m (BlockFetchServer block point m b)
next) =
    m (BlockFetchServer block point m b)
next m (BlockFetchServer block point m b)
-> (BlockFetchServer block point 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
>>= Queue ('S n) c
-> BlockFetchSender ('S n) c block point m a
-> BlockFetchServer block point m b
-> m (a, b)
forall (n :: N) c.
Queue n c
-> BlockFetchSender n c block point m a
-> BlockFetchServer block point m b
-> m (a, b)
go (c -> Queue n c -> Queue ('S n) c
forall a (n :: N). a -> Queue n a -> Queue ('S n) a
enqueue c
c Queue n c
q) BlockFetchSender ('S n) c block point m a
client


  -- Loop through received block bodies until we are done. At each step update
  -- @c@ using the @receive@ function and enqueue it when we received all block
  -- bodies.
  sendBlocks
    :: Queue n c
    -> c
    -> (Maybe block -> c -> m c)
    -> BlockFetchSender (S n) c block point m a
    -> BlockFetchSendBlocks     block point m b
    -> m (a, b)

  sendBlocks :: forall (n :: N) c.
Queue n c
-> c
-> (Maybe block -> c -> m c)
-> BlockFetchSender ('S n) c block point m a
-> BlockFetchSendBlocks block point m b
-> m (a, b)
sendBlocks Queue n c
q c
c Maybe block -> c -> m c
receive  BlockFetchSender ('S n) c block point m a
client (SendMsgBlock block
b m (BlockFetchSendBlocks block point m b)
next) = do
    c' <- Maybe block -> c -> m c
receive (block -> Maybe block
forall a. a -> Maybe a
Just block
b) c
c
    next >>= sendBlocks q c' receive client

  sendBlocks Queue n c
q c
c Maybe block -> c -> m c
_receive BlockFetchSender ('S n) c block point m a
client (SendMsgBatchDone m (BlockFetchServer block point m b)
next) =
    -- after receiving all the block bodies, we calculated the final value of
    -- @c@ which we can enqueue now
    m (BlockFetchServer block point m b)
next m (BlockFetchServer block point m b)
-> (BlockFetchServer block point 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
>>= Queue ('S n) c
-> BlockFetchSender ('S n) c block point m a
-> BlockFetchServer block point m b
-> m (a, b)
forall (n :: N) c.
Queue n c
-> BlockFetchSender n c block point m a
-> BlockFetchServer block point m b
-> m (a, b)
go (c -> Queue n c -> Queue ('S n) c
forall a (n :: N). a -> Queue n a -> Queue ('S n) a
enqueue c
c Queue n c
q) BlockFetchSender ('S n) c block point m a
client