{-# 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
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
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)
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
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) =
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