detecting data && deferred emit

hbs2-core/hbs2-core.cabal

@@ -68,6 +68,7 @@ library
                     , HBS2.Actors.ChunkWriter
                     , HBS2.Actors.Peer
                     , HBS2.Clock
+                    , HBS2.Data.Detect
                     , HBS2.Data.Types
                     , HBS2.Data.Types.Refs
                     , HBS2.Defaults

hbs2-core/lib/HBS2/Actors/Peer.hs

@@ -263,21 +263,25 @@ instance ( HasProtocol e p
          ) => EventEmitter e p (PeerM e IO) where
 
   emit k d = do
-    se <- asks (view envEvents)
-    let sk = newSKey @(EventKey e p) k
+    pip <- asks (view envDeferred)
+    env <- ask
+    liftIO $ addJob pip $ withPeerM env $ do
 
-    void $ runMaybeT $ do
-      subs <- MaybeT $ liftIO $ atomically $ readTVar se <&> HashMap.lookup sk
-      void $ liftIO $ atomically $ modifyTVar' se (HashMap.delete sk)
-      pers <- forM subs $ \r -> do
-                ev <- MaybeT $ pure $ fromDynamic @(EventHandler e p (PeerM e IO)) r
-                lift $ ev d
-                if isPersistent @(Event e p) then
-                  pure [r]
-                else
-                  pure []
+      se <- asks (view envEvents)
+      let sk = newSKey @(EventKey e p) k
 
-      void $ liftIO $ atomically $ modifyTVar' se (HashMap.insert sk (mconcat pers))
+      void $ runMaybeT $ do
+        subs <- MaybeT $ liftIO $ atomically $ readTVar se <&> HashMap.lookup sk
+        void $ liftIO $ atomically $ modifyTVar' se (HashMap.delete sk)
+        pers <- forM subs $ \r -> do
+                  ev <- MaybeT $ pure $ fromDynamic @(EventHandler e p (PeerM e IO)) r
+                  lift $ ev d
+                  if isPersistent @(Event e p) then
+                    pure [r]
+                  else
+                    pure []
+
+        void $ liftIO $ atomically $ modifyTVar' se (HashMap.insert sk (mconcat pers))
 
 runPeerM :: forall e m . (MonadIO m, HasPeer e, Ord (Peer e), Pretty (Peer e))
          => AnyStorage

hbs2-tests/test/Peer2Main.hs

@@ -371,7 +371,7 @@ main = do
                   env <- ask
                   liftIO $ async $ withPeerM env $ do
                       maybe1 rootSz (pure ()) $ \rsz -> do
-                        pause ( 0.01 :: Timeout 'Seconds )
+                        pause ( 0.001 :: Timeout 'Seconds )
                         let info = BlockAnnounceInfo 0 NoBlockInfoMeta rsz (fromMerkleHash root)
                         let ann = BlockAnnounce @Fake info
                         request @Fake p0 ann

hbs2/Main.hs

@@ -7,6 +7,7 @@ import HBS2.Prelude
 import HBS2.Prelude.Plated
 import HBS2.Merkle
 import HBS2.Data.Types
+import HBS2.Data.Detect
 import HBS2.Defaults
 
 
@@ -74,11 +75,6 @@ newtype NewRefOpts =
   }
   deriving stock (Data)
 
-data BlobType =  Merkle (Hash HbSync)
-               | AnnRef (Hash HbSync)
-               | Blob (Hash HbSync)
-               deriving (Show,Data)
-
 runCat :: Data opts => opts -> SimpleStorage HbSync -> IO ()
 runCat opts ss = do
 
@@ -90,11 +86,7 @@ runCat opts ss = do
 
     obj <- MaybeT $ getBlock ss mhash
 
-    let mbLink   = deserialiseOrFail @AnnotatedHashRef obj >> pure (AnnRef mhash)
-    let mbMerkle = deserialiseOrFail @(MTree [HashRef]) obj >> pure (Merkle mhash)
-    let orBlob   = Blob mhash
-
-    let q = rights [mbLink, mbMerkle] & headDef orBlob
+    let q = tryDetect mhash obj
 
     liftIO $ do
 
@@ -120,31 +112,6 @@ runCat opts ss = do
           maybe (error "empty ref") walk mbHead
 
 
-    -- case q of
-    --   Merkle h -> liftIO do
-    --      walkMerkle h (getBlock ss) $ \(hr :: [HashRef]) -> do
-    --        forM_ hr $ \(HashRef h) -> do
-    --          if honly then do
-    --            print $ pretty h
-    --          else do
-    --            mblk <- getBlock ss h
-    --            case mblk of
-    --              Nothing  -> error $ show $ "missed block: " <+> pretty h
-    --              Just blk -> LBS.putStr blk
-
-
-    -- case q of
-
-    -- realHash <- MaybeT $ case mbLink of
-    --   Left _    -> pure $ Just mhash
-    --   Right lnk -> do
-    --     pure $ headMay [ h
-    --                    | HashRefMerkle (HashRefObject (HashRef h) _) <- universeBi lnk
-    --                    ]
-
-    -- -- FIXME: if merkle?
-
-
 runStore :: Data opts => opts -> SimpleStorage HbSync -> IO ()
 
 runStore opts ss | justInit = do