diff --git a/.fixme/log b/.fixme/log index c32c41d4..16eaf9da 100644 --- a/.fixme/log +++ b/.fixme/log @@ -98,3 +98,6 @@ fixme-del "C6oPMevzw4" fixme-del "AMJFUVwbxy" fixme-del "6DBdanQ5zn" + +fixme-set "resolution" "done" "F7whmzJkZX" + diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index 2bfe9e0c..90e46e25 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer.hs @@ -66,9 +66,16 @@ data Fabriq e = forall bus . (Messaging bus e (Encoded e)) => Fabriq bus class HasFabriq e m where getFabriq :: m (Fabriq e) -class Messaging (Fabriq e) e (AnyMessage (Encoded e) e) => PeerMessaging e +class ( Messaging (Fabriq e) e (AnyMessage (Encoded e) e) + , Eq (Encoded e) + , Hashable (Encoded e) + ) => PeerMessaging e -instance Messaging (Fabriq e) e (AnyMessage (Encoded e) e) => PeerMessaging e +instance ( Messaging (Fabriq e) e (AnyMessage (Encoded e) e) + , Eq (Encoded e) + , Hashable (Encoded e) + ) + => PeerMessaging e class ( Eq (SessionKey e a) , Hashable (SessionKey e a) @@ -133,7 +140,7 @@ data PeerEnv e = , _envEvents :: TVar (HashMap SKey [Dynamic]) , _envExpireTimes :: Cache SKey () , _envSweepers :: TVar (HashMap SKey [PeerM e IO ()]) - , _envReqLimit :: Cache (Peer e, Integer) () + , _envReqLimit :: Cache (Peer e, Integer, Encoded e) () } newtype PeerM e m a = PeerM { fromPeerM :: ReaderT (PeerEnv e) m a } @@ -229,23 +236,26 @@ instance ( MonadIO m se <- asks (view envSessions) liftIO $ Cache.delete se (newSKey @(SessionKey e p) k) -class HasProtocol e p => HasTimeLimits e p m where - withTimeLimit :: Peer e -> m () -> m () +class (HasProtocol e p) => HasTimeLimits e p m where + withTimeLimit :: Peer e -> p -> m () -> m () instance {-# OVERLAPPABLE #-} (Monad m, HasProtocol e p) => HasTimeLimits e p m where - withTimeLimit _ m = m + withTimeLimit _ p m = m -instance (MonadIO m, HasProtocol e p) +instance (MonadIO m, HasProtocol e p, Hashable (Encoded e)) => HasTimeLimits e p (PeerM e m) where - withTimeLimit peer m = case requestMinPeriod @e @p of + withTimeLimit peer msg m = case requestMinPeriod @e @p of Nothing -> m + Just lim -> do let proto = protoId @e @p (Proxy @p) ex <- asks (view envReqLimit) - here <- liftIO $ Cache.lookup ex (peer, proto) <&> isJust + let bin = encode @e msg + let key = (peer, proto, bin) + here <- liftIO $ Cache.lookup ex key <&> isJust unless here $ do - liftIO $ Cache.insert' ex (Just (toTimeSpec lim)) (peer, proto) () + liftIO $ Cache.insert' ex (Just (toTimeSpec lim)) key () m instance ( MonadIO m @@ -265,7 +275,8 @@ instance ( MonadIO m -- -- TODO: where to store the timeout? -- TODO: where the timeout come from? - withTimeLimit @e @p p $ do + withTimeLimit @e @p p msg $ do + -- liftIO $ print "request!" sendTo pipe (To p) (From me) (AnyMessage @(Encoded e) @e proto (encode msg)) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs index 6bfe147e..9177a103 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs @@ -55,7 +55,7 @@ instance HasProtocol UDP (BlockInfo UDP) where -- FIXME: requestMinPeriod-breaks-fast-block-download -- - requestMinPeriod = Nothing + requestMinPeriod = Just 10 instance HasProtocol UDP (BlockChunks UDP) where type instance ProtocolId (BlockChunks UDP) = 2 diff --git a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs index 36f8d243..a28cfc54 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs @@ -53,6 +53,8 @@ newtype instance SessionKey e (PeerHandshake e) = type instance SessionData e (PeerHandshake e) = PingNonce +-- FIXME: enormous-request-amount-during-handshake + sendPing :: forall e m . ( MonadIO m , Request e (PeerHandshake e) m , Sessions e (PeerHandshake e) m