process-only-subscribed-reflogs

hbs2-core/lib/HBS2/Net/Proto/RefLog.hs

@@ -17,6 +17,7 @@ import HBS2.Data.Types.Refs
 
 import HBS2.System.Logger.Simple
 
+import Control.Monad.Trans.Maybe
 import Data.Maybe
 import Data.Hashable hiding (Hashed)
 import Data.ByteString (ByteString)
@@ -48,8 +49,13 @@ instance Pretty (AsBase58 (PubKey 'Sign s )) => Pretty (RefLogKey s) where
 
 
 data RefLogRequest e =
-    RefLogRequest  (PubKey 'Sign (Encryption e))
-  | RefLogResponse (PubKey 'Sign (Encryption e)) (Hash HbSync)
+    RefLogRequest
+    { refLog :: PubKey 'Sign (Encryption e)
+    }
+  | RefLogResponse
+    { refLog      :: PubKey 'Sign (Encryption e)
+    , refLogValue :: Hash HbSync
+    }
   deriving stock (Generic)
 
 deriving instance
@@ -148,6 +154,7 @@ data RefLogRequestI e m =
   RefLogRequestI
   { onRefLogRequest :: (Peer e, PubKey 'Sign (Encryption e)) -> m (Maybe (Hash HbSync))
   , onRefLogResponse :: (Peer e, PubKey 'Sign (Encryption e), Hash HbSync) -> m ()
+  , isRefLogSubscribed :: PubKey 'Sign (Encryption e) -> m Bool
   }
 
 refLogRequestProto :: forall e s m . ( MonadIO m
@@ -164,23 +171,22 @@ refLogRequestProto :: forall e s m . ( MonadIO m
                   => RefLogRequestI e m -> RefLogRequest e -> m ()
 
 refLogRequestProto adapter cmd = do
-
   p <- thatPeer proto
-  auth <- find (KnownPeerKey p) id <&> isJust
 
-  when auth do
+  void $ runMaybeT do
 
-    -- FIXME: asap-only-accept-response-if-we-have-asked
+    guard =<< lift (find (KnownPeerKey p) id <&> isJust)
+    guard =<< lift (isRefLogSubscribed adapter (refLog cmd))
 
     case cmd of
-      (RefLogRequest pk) -> do
+      (RefLogRequest pk) -> lift do
          trace $ "got RefLogUpdateRequest for" <+> pretty (AsBase58 pk)
          pip <- thatPeer proto
          answ' <- onRefLogRequest adapter (pip,pk)
          maybe1 answ' none $ \answ -> do
           response (RefLogResponse @e pk answ)
 
-      (RefLogResponse pk h) -> do
+      (RefLogResponse pk h) -> lift do
          trace $ "got RefLogResponse for" <+> pretty (AsBase58 pk) <+> pretty h
          pip <- thatPeer proto
          emit RefLogReqAnswerKey (RefLogReqAnswerData @e pk h)

hbs2-peer/app/PeerMain.hs

@@ -778,7 +778,7 @@ runPeer opts = U.handle (\e -> myException e
             runPeerM penv $ do
               adapter <- mkAdapter
 
-              reflogReqAdapter <- RefLog.mkRefLogRequestAdapter @e
+              reflogReqAdapter <- RefLog.mkRefLogRequestAdapter @e (SomeBrains brains)
 
               let doDownload h = do
                     pro <- isReflogProcessed @e brains h

hbs2-peer/app/RefLog.hs

@@ -66,10 +66,11 @@ mkRefLogRequestAdapter :: forall e s m . ( MonadIO m
                                          , Pretty (AsBase58 (PubKey 'Sign s))
                                          , s ~ Encryption e
                                          )
-          => m (RefLogRequestI e (ResponseM e m ))
-mkRefLogRequestAdapter = do
+          => SomeBrains e -> m (RefLogRequestI e (ResponseM e m ))
+mkRefLogRequestAdapter brains = do
   sto <- getStorage
-  pure $ RefLogRequestI (doOnRefLogRequest sto) dontHandle
+  pure $ RefLogRequestI (doOnRefLogRequest sto) dontHandle (isPolledRef @e brains)
+
 
 -- FIXME: check-if-subscribed
 --   не дергать диск для неизвестных ссылок
@@ -82,7 +83,8 @@ doOnRefLogRequest :: forall e s m . ( MonadIO m
                                     )
                    =>  AnyStorage -> (Peer e, PubKey 'Sign s) -> m (Maybe (Hash HbSync))
 
-doOnRefLogRequest sto (_,pk) = liftIO $ getRef sto (RefLogKey @s pk)
+doOnRefLogRequest sto (_,pk) = do
+  liftIO $ getRef sto (RefLogKey @s pk)
 
 
 data RefLogWorkerAdapter e =
@@ -164,6 +166,7 @@ reflogWorker conf brains adapter = do
     -- TODO: ASAP-start-only-one-instance-for-link-monitor
     -- TODO: ASAP-dont-do-if-already-done
 
+    -- TODO: use-download-mon
     here <- liftIO $ readTVarIO reflogMon <&> HashSet.member h
     unless here do
       liftIO $ atomically $ modifyTVar' reflogMon (HashSet.insert h)