diff --git a/hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs b/hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs index c7efc6b8..97554306 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs @@ -1,4 +1,44 @@ module HBS2.Net.Proto.BlockInfo where +import HBS2.Prelude.Plated +import HBS2.Net.Proto +import HBS2.Hash + +import Codec.Serialise () + +data BlockSize e = GetBlockSize (Hash HbSync) + | NoBlock (Hash HbSync) + | BlockSize (Hash HbSync) Integer + deriving stock (Eq,Generic,Show) + +type HasBlockEvent h e m = (Peer e, Hash h, Maybe Integer) -> m () + +type GetBlockSize h m = Hash h -> m (Maybe Integer) + +instance Serialise (BlockSize e) + +blockSizeProto :: forall e m . ( MonadIO m + , Response e (BlockSize e) m + ) + => GetBlockSize HbSync m + -> HasBlockEvent HbSync e m + -> BlockSize e + -> m () + +blockSizeProto getBlockSize evHasBlock = + \case + GetBlockSize h -> do + deferred (Proxy @(BlockSize e))$ do + getBlockSize h >>= \case + Just size -> response (BlockSize @e h size) + Nothing -> response (NoBlock @e h) + + NoBlock h -> do + that <- thatPeer (Proxy @(BlockSize e)) + evHasBlock ( that, h, Nothing ) + + BlockSize h sz -> do + that <- thatPeer (Proxy @(BlockSize e)) + evHasBlock ( that, h, Just sz ) diff --git a/hbs2-tests/test/Main.hs b/hbs2-tests/test/Main.hs index 5c52cf98..adaef3b7 100644 --- a/hbs2-tests/test/Main.hs +++ b/hbs2-tests/test/Main.hs @@ -5,11 +5,11 @@ import HBS2.Clock import HBS2.Hash -- import HBS2.Net.Messaging import HBS2.Net.Proto +import HBS2.Net.Proto.BlockInfo import HBS2.Net.Messaging.Fake import HBS2.Net.Peer import HBS2.Storage.Simple import HBS2.Storage.Simple.Extra -import HBS2.Actors -- import Test.Tasty hiding (Timeout) import Test.Tasty.HUnit hiding (Timeout) @@ -43,53 +43,17 @@ instance Pretty (Peer Fake) where debug :: (MonadIO m) => Doc ann -> m () debug p = liftIO $ hPrint stderr p - -data BlockSize e = GetBlockSize (Hash HbSync) - | NoBlock (Hash HbSync) - | BlockSize (Hash HbSync) Integer - deriving stock (Eq,Generic,Show) - - -instance Serialise (BlockSize e) - instance HasProtocol Fake (BlockSize Fake) where type instance ProtocolId (BlockSize Fake) = 1 type instance Encoded Fake = ByteString decode = either (const Nothing) Just . deserialiseOrFail encode = serialise -type HasBlockEvent h e m = (Peer e, Hash h, Maybe Integer) -> m () - -type GetBlockSize h m = Hash h -> m (Maybe Integer) dontHandle :: Applicative f => a -> f () dontHandle = const $ pure () -blockSizeProto :: forall e m . ( MonadIO m - , Response e (BlockSize e) m - ) - => GetBlockSize HbSync m - -> HasBlockEvent HbSync e m - -> BlockSize e - -> m () - -blockSizeProto getBlockSize evHasBlock = - \case - GetBlockSize h -> do - deferred (Proxy @(BlockSize e))$ do - getBlockSize h >>= \case - Just size -> response (BlockSize @e h size) - Nothing -> response (NoBlock @e h) - - NoBlock h -> do - that <- thatPeer (Proxy @(BlockSize e)) - evHasBlock ( that, h, Nothing ) - - BlockSize h sz -> do - that <- thatPeer (Proxy @(BlockSize e)) - evHasBlock ( that, h, Just sz ) - main :: IO () main = do hSetBuffering stderr LineBuffering