diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 17eaef51..55c6ccd0 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/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 diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index 078f7892..693f1d7a 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/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 diff --git a/hbs2-tests/test/Peer2Main.hs b/hbs2-tests/test/Peer2Main.hs index 8607fd71..43089961 100644 --- a/hbs2-tests/test/Peer2Main.hs +++ b/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 diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 450467b1..a61e1aa5 100644 --- a/hbs2/Main.hs +++ b/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