mirror of https://github.com/voidlizard/hbs2
wtf?
This commit is contained in:
Dmitry Zuikov
parent
069bc1ef28
commit
1893123ccb
|
|
@ -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
|
|||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue