diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index 888f808b..225cca84 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer.hs @@ -249,21 +249,23 @@ instance ( HasProtocol e p , Hashable (EventKey e p) , Eq (EventKey e p) , Typeable (EventHandler e p (PeerM e IO)) + , Pretty (Peer e) ) => EventEmitter e p (PeerM e IO) where emit k d = do + me <- ownPeer @e se <- asks (view envEvents) let sk = newSKey @(EventKey e p) k void $ runMaybeT $ do - liftIO $ print "GOOD" + liftIO $ print $ "GOOD" <+> pretty me <+> pretty (hash sk) subs <- MaybeT $ liftIO $ atomically $ readTVar se <&> HashMap.lookup sk - liftIO $ print "VERY GOOD" + liftIO $ print $ "VERY GOOD" <+> pretty me void $ liftIO $ atomically $ modifyTVar' se (HashMap.delete sk) for_ subs $ \r -> do ev <- MaybeT $ pure $ fromDynamic @(EventHandler e p (PeerM e IO)) r lift $ ev d - liftIO $ print "FINE" + liftIO $ print $ "FINE" <+> pretty me runPeerM :: (MonadIO m, Pretty (Peer e)) => AnyStorage -> Fabriq e -> Peer e -> PeerM e m a -> m () runPeerM s bus p f = do @@ -380,4 +382,3 @@ instance ( MonadIO m - diff --git a/hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs b/hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs index cbe1ea4f..e8e560c9 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs @@ -64,8 +64,9 @@ instance Serialise (BlockChunks e) newtype instance EventKey e (BlockChunks e) = BlockChunksEventKey (Hash HbSync) - deriving stock (Typeable, Eq) - deriving newtype (Hashable) + deriving stock (Typeable, Eq, Generic) + +deriving instance Hashable (EventKey e (BlockChunks e)) newtype instance Event e (BlockChunks e) = BlockReady (Hash HbSync) diff --git a/hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs b/hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs index 8075771a..e87d876a 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs @@ -52,8 +52,9 @@ newtype instance SessionKey e (BlockSize e) = newtype instance EventKey e (BlockSize e) = BlockSizeEventKey (Hash HbSync) - deriving stock (Typeable, Eq) - deriving newtype (Hashable) + deriving stock (Typeable, Eq,Generic) + +deriving instance Hashable (EventKey e (BlockSize e)) newtype instance Event e (BlockSize e) = BlockSizeEvent (Peer e, Hash HbSync, Integer) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Sessions.hs b/hbs2-core/lib/HBS2/Net/Proto/Sessions.hs index 42186a24..7f6b260e 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Sessions.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Sessions.hs @@ -6,9 +6,10 @@ import HBS2.Net.Proto.Types import Data.Typeable import Data.Dynamic import Data.Hashable +import Type.Reflection import Data.Kind -data SKey = forall a . (Unkey a, Eq a, Hashable a) => SKey (Proxy a) Dynamic +data SKey = forall a . (Unkey a, Eq a, Hashable a) => SKey (Proxy a) SomeTypeRep Dynamic class Typeable a => Unkey a where unKey :: Proxy a -> Dynamic -> Maybe a @@ -17,15 +18,18 @@ instance Typeable a => Unkey a where unKey _ = fromDynamic @a newSKey :: forall a . (Eq a, Typeable a, Unkey a, Hashable a) => a -> SKey -newSKey s = SKey (Proxy @a) (toDyn s) +newSKey s = SKey (Proxy @a) (someTypeRep (Proxy @a)) (toDyn s) instance Hashable SKey where - hashWithSalt s (SKey p d) = hashWithSalt s (unKey p d) + hashWithSalt s (SKey p t d) = hashWithSalt s (p, t, unKey p d) instance Eq SKey where - (==) (SKey p1 a) (SKey p2 b) = unKey p1 a == unKey p1 b + (==) (SKey p1 ty1 a) (SKey p2 ty2 b) = + ty1 == ty2 + && unKey p1 a == unKey p1 b + && unKey p2 a == unKey p2 b data family SessionKey e p :: Type diff --git a/hbs2-core/test/HasProtocol.hs b/hbs2-core/test/HasProtocol.hs index db7b49d9..abb0f0cb 100644 --- a/hbs2-core/test/HasProtocol.hs +++ b/hbs2-core/test/HasProtocol.hs @@ -2,12 +2,10 @@ module HasProtocol ( module HBS2.Net.Proto.Types , module HBS2.Net.Messaging , module HBS2.Net.Messaging.Fake - , module HBS2.Net.Peer ) where import HBS2.Net.Messaging import HBS2.Net.Messaging.Fake -import HBS2.Net.Peer import HBS2.Net.Proto.Types diff --git a/hbs2-tests/test/Peer2Main.hs b/hbs2-tests/test/Peer2Main.hs index 76f8a86f..fe7869c7 100644 --- a/hbs2-tests/test/Peer2Main.hs +++ b/hbs2-tests/test/Peer2Main.hs @@ -161,6 +161,7 @@ blockDownloadLoop :: forall e . ( HasProtocol e (BlockSize e) , Request e (BlockChunks e) (PeerM e IO) , EventListener e (BlockSize e) (PeerM e IO) , EventListener e (BlockChunks e) (PeerM e IO) + , EventEmitter e (BlockChunks e) (PeerM e IO) , Sessions e (BlockSize e) (PeerM e IO) , Sessions e (BlockChunks e) (PeerM e IO) , Num (Peer e) @@ -169,19 +170,23 @@ blockDownloadLoop :: forall e . ( HasProtocol e (BlockSize e) blockDownloadLoop = do let blks = [ "5KP4vM6RuEX6RA1ywthBMqZV5UJDLANC17UrF6zuWdRt" - , "81JeD7LNR6Q7RYfyWBxfjJn1RsWzvegkUXae6FUNgrMZ" - , "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA" + -- , "81JeD7LNR6Q7RYfyWBxfjJn1RsWzvegkUXae6FUNgrMZ" + -- , "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA" ] for_ blks $ \h -> do debug $ "subscribing to" <+> pretty h + -- let wtf1 = newSKey (BlockChunksEventKey h) + + -- emit @e (BlockChunksEventKey (head blks)) (BlockReady (head blks)) + subscribe @e (BlockChunksEventKey h) $ \(BlockReady _) -> do debug $ "GOT BLOCK!" <+> pretty h pure () - subscribe @e @(BlockSize e) (BlockSizeEventKey h) $ \(BlockSizeEvent (p,h,s)) -> do + subscribe @e (BlockSizeEventKey h) $ \(BlockSizeEvent (p,h,s)) -> do debug $ "can't believe this shit works" <+> pretty h coo <- genCookie (p,h) let key = DownloadSessionKey (p, coo) @@ -198,6 +203,8 @@ blockDownloadLoop = do fix \next -> do liftIO $ print "piu!" + -- emit @e (BlockChunksEventKey (head blks)) (BlockReady (head blks)) + pause ( 0.85 :: Timeout 'Seconds ) next @@ -258,6 +265,16 @@ mkAdapter cww = do && written >= mbSize when mbDone $ lift do + emit @e @(BlockChunks e) (BlockChunksEventKey h) (BlockReady h) + + -- ВОТ ЖЕ БЛЯДЬ! СЧИТАТЬ ХЭШ ДОЛГО. + -- ЗАМОРОЗИМСЯ ЗДЕСЬ. + -- + -- ЕСЛИ СОБЫТИЕ ПОШЛЁМ РАНЬЕ -- ОНО ПРИШЛО, + -- А БЛОКА НЕТ + -- + -- А ПОШЛЁМ ИЗ DEFERRED - ТИП БУДЕТ ДРУГОЙ + -- СУКА! deferred (Proxy @(BlockChunks e)) $ do h1 <- liftIO $ getHash cww cKey h @@ -267,10 +284,11 @@ mkAdapter cww = do when ( h1 == h ) $ do liftIO $ commitBlock cww cKey h expire cKey - debug $ "BLOCK IS READY" <+> pretty h - emit @e (BlockChunksEventKey h) (BlockReady h) - -- FIXME: return this event! - -- lift $ runEngineM env $ emitBlockReadyEvent ev h -- TODO: fix this crazy shit + -- WTF!! THIS IS A DIFFERENT MONAD FROM OUTSIDE, + -- SO EVENTS EMITTED HERE WILL HAVE ANOTHER + -- TYPE SIGNATURES AND WILL NOT BE DECODED + -- WHEREVER THEIR ARE LISTENED + -- HOLY SHIT when (written > mbSize * defBlockDownloadThreshold) $ do debug $ "SESSION DELETED BECAUSE THAT PEER IS JERK:" <+> pretty p