wip

hbs2-core/hbs2-core.cabal

@@ -116,6 +116,7 @@ test-suite test
 
     other-modules:  TestFakeMessaging
                   , TestActors
+                  , TestBlockInfoActor
 
     -- other-extensions:
 
@@ -131,6 +132,7 @@ test-suite test
         , microlens-platform
         , mtl
         , prettyprinter
+        , QuickCheck
         , random
         , safe
         , serialise

hbs2-core/lib/HBS2/Net/Proto/Actors/BlockInfo.hs

@@ -4,8 +4,11 @@ import HBS2.Prelude
 import HBS2.Hash
 import HBS2.Net.Proto
 import HBS2.Clock
+import HBS2.Actors
 
 import Data.Function
+import Data.Kind
+import Prettyprinter
 
 -- needs: logger
 -- needs: reader and shit
@@ -13,9 +16,9 @@ import Data.Function
 -- needs: cookie manager
 -- needs: peer manager
 
-data BlockInfoActor =
+data BlockInfoActor (m :: Type -> Type) =
   BlockInfoActor
-  {
+  { tasks :: Pipeline m ()
   }
 
 
@@ -25,27 +28,31 @@ data BlockInfoActor =
 -- TODO: get block info per peer
 
 
-createBlockInfoActor :: MonadIO m => m BlockInfoActor
+createBlockInfoActor :: MonadIO m => m (BlockInfoActor m )
 createBlockInfoActor = do
-  pure $ BlockInfoActor
+  pip <- newPipeline 200 -- FIXME: to settings!
+  pure $ BlockInfoActor pip
 
-runBlockInfoActor :: MonadIO m => BlockInfoActor -> m ()
-runBlockInfoActor _ =
-  fix \next -> do
-    pause (1 :: Timeout 'Seconds)
-    next
+runBlockInfoActor :: MonadIO m => BlockInfoActor m -> m ()
+runBlockInfoActor b = runPipeline (tasks b)
 
-requestBlockInfo :: MonadIO m
-                 => BlockInfoActor
+stopBlockInfoActor :: MonadIO m => BlockInfoActor m -> m ()
+stopBlockInfoActor b = stopPipeline (tasks b)
+
+requestBlockInfo :: forall peer h m . ( MonadIO m
+                                      , Pretty (Hash h)
+                                      )
+                 => BlockInfoActor m
                  -> Maybe (Peer peer)
                  -> Hash h
                  -> m  ()
 
-requestBlockInfo b h = do
-  undefined
+requestBlockInfo b _ h = do
+  addJob (tasks b) do
+    liftIO $ print ( "request-info" <+> pretty h)
 
 getBlockInfo :: MonadIO m
-             => BlockInfoActor
+             => BlockInfoActor m
              -> Maybe (Peer peer)
              -> m (Maybe BlockInfo)
 

hbs2-core/test/Main.hs

@@ -2,6 +2,7 @@ module Main where
 
 import TestFakeMessaging
 import TestActors
+import TestBlockInfoActor
 
 import Test.Tasty
 import Test.Tasty.HUnit
@@ -13,6 +14,7 @@ main =
       [
         testCase "testFakeMessaging1" testFakeMessaging1
       , testCase "testActorsBasic" testActorsBasic
+      , testCase "testBlockInfoActor" testBlockInfoActor
       ]
 
 

hbs2-core/test/TestBlockInfoActor.hs

@@ -0,0 +1,34 @@
+module TestBlockInfoActor where
+
+import HBS2.Hash
+import HBS2.Clock
+import HBS2.Net.Proto.Actors.BlockInfo
+
+import Test.Tasty.HUnit
+
+import Test.QuickCheck
+import Data.Word
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as B
+import Control.Concurrent.Async
+
+testBlockInfoActor :: IO ()
+testBlockInfoActor = do
+
+  a <- createBlockInfoActor
+  actor <- async $ runBlockInfoActor a
+
+  let obj = shrink [0x00 .. 0xFF] :: [[Word8]]
+
+  forConcurrently_ obj $ \x -> do
+    requestBlockInfo a Nothing (hashObject (B.pack x) :: Hash HbSync)
+
+  pause ( 1 :: Timeout 'Seconds)
+
+  stopBlockInfoActor a
+
+  waitAnyCatchCancel [actor]
+
+  assertBool "testBlockInfoActor" True
+
+