wtf?

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
 
 
 
-

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 stock (Typeable, Eq, Generic)
-  deriving newtype (Hashable)
+
+deriving instance Hashable (EventKey e (BlockChunks e))
 
 newtype instance Event e (BlockChunks e) =
   BlockReady (Hash HbSync)

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 stock (Typeable, Eq,Generic)
-  deriving newtype (Hashable)
+
+deriving  instance Hashable (EventKey e (BlockSize e))
 
 newtype instance Event e (BlockSize e) =
   BlockSizeEvent (Peer e, Hash HbSync, Integer)

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

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
 
 

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"
+             -- , "81JeD7LNR6Q7RYfyWBxfjJn1RsWzvegkUXae6FUNgrMZ"
-             , "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
+             -- , "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
+              -- WTF!! THIS IS A DIFFERENT MONAD FROM OUTSIDE,
-              emit @e (BlockChunksEventKey h) (BlockReady h)
+              --       SO EVENTS EMITTED HERE WILL HAVE ANOTHER
-              -- FIXME: return this event!
+              --       TYPE SIGNATURES AND WILL NOT BE DECODED
-              -- lift $ runEngineM env $ emitBlockReadyEvent ev h -- TODO: fix this crazy shit
+              --       WHEREVER THEIR ARE LISTENED
+              --       HOLY SHIT
 
         when (written > mbSize * defBlockDownloadThreshold) $ do
           debug $ "SESSION DELETED BECAUSE THAT PEER IS JERK:" <+> pretty p