fix proxy-fetch-for

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

@@ -28,11 +28,12 @@ blockSizeProto :: forall e m  . ( MonadIO m
                                 )
                => GetBlockSize  HbSync m
                -> HasBlockEvent HbSync e m
+               -> ( (Peer e, Hash HbSync) -> m () )
                -> BlockInfo e
                -> m ()
 
 -- FIXME: with-auth-combinator
-blockSizeProto getBlockSize evHasBlock =
+blockSizeProto getBlockSize evHasBlock onNoBlock =
   \case
     GetBlockSize h -> do
       -- liftIO $ print "GetBlockSize"
@@ -42,7 +43,9 @@ blockSizeProto getBlockSize evHasBlock =
         deferred (Proxy @(BlockInfo e))$ do
           getBlockSize h >>= \case
             Just size -> response (BlockSize @e h size)
-            Nothing   -> response (NoBlock @e h)
+            Nothing   -> do
+              onNoBlock (p, h)
+              response (NoBlock @e h)
 
     NoBlock h       -> do
       that <- thatPeer (Proxy @(BlockInfo e))

hbs2-peer/app/PeerMain.hs

@@ -73,6 +73,7 @@ import System.Directory
 import System.Exit
 import System.IO
 import System.Metrics
+import Data.Cache qualified as Cache
 
 
 -- TODO: write-workers-to-config
@@ -97,6 +98,7 @@ data PeerWhiteListKey
 data PeerStorageKey
 data PeerAcceptAnnounceKey
 data PeerTraceKey
+data PeerProxyFetchKey
 
 data AcceptAnnounce = AcceptAnnounceAll
                     | AcceptAnnounceFrom (Set (PubKey 'Sign UDP))
@@ -129,6 +131,9 @@ instance HasCfgKey PeerBlackListKey (Set String) where
 instance HasCfgKey PeerWhiteListKey (Set String) where
   key = "whitelist"
 
+instance HasCfgKey PeerProxyFetchKey (Set String) where
+  key = "proxy-fetch-for"
+
 instance HasCfgKey PeerAcceptAnnounceKey AcceptAnnounce where
   key = "accept-block-announce"
 
@@ -443,6 +448,7 @@ runPeer opts = Exception.handle myException $ do
                                 ] :: Set (PubKey 'Sign UDP)
   let blkeys = toKeys bls
   let wlkeys = toKeys (whs `Set.difference` bls)
+  let helpFetchKeys = cfgValue @PeerProxyFetchKey conf & toKeys
 
   let accptAnn = cfgValue @PeerAcceptAnnounceKey conf :: AcceptAnnounce
 
@@ -476,6 +482,7 @@ runPeer opts = Exception.handle myException $ do
   s <- simpleStorageInit @HbSync (Just pref)
   let blk = liftIO . hasBlock s
 
+
   w <- replicateM defStorageThreads $ async $ simpleStorageWorker s
 
   localMulticast <- (headMay <$> parseAddr (fromString defLocalMulticast)
@@ -511,6 +518,23 @@ runPeer opts = Exception.handle myException $ do
 
   penv <- newPeerEnv (AnyStorage s) (Fabriq mess) (getOwnPeer mess)
 
+  nbcache <- liftIO $ Cache.newCache (Just $ toTimeSpec ( 600 :: Timeout 'Seconds))
+
+  void $ async $ forever do
+    pause @'Seconds 600
+    liftIO $ Cache.purgeExpired nbcache
+
+  let onNoBlock (p, h) = do
+        already <- liftIO $ Cache.lookup nbcache (p,h) <&> isJust
+        unless already do
+          pd' <- find (KnownPeerKey p) id
+          maybe1 pd' none $ \pd -> do
+            let pk = view peerSignKey pd
+            when (Set.member pk helpFetchKeys) do
+              liftIO $ Cache.insert nbcache (p,h) ()
+              -- debug  $ "onNoBlock" <+> pretty p <+> pretty h
+              withPeerM penv $ withDownload denv (addDownload mzero h)
+
   loop <- async do
 
             runPeerM penv $ do
@@ -731,7 +755,7 @@ runPeer opts = Exception.handle myException $ do
 
                 peerThread do
                   runProto @e
-                    [ makeResponse (blockSizeProto blk dontHandle)
+                    [ makeResponse (blockSizeProto blk dontHandle onNoBlock)
                     , makeResponse (blockChunksProto adapter)
                     , makeResponse blockAnnounceProto
                     , makeResponse (withCredentials pc . peerHandShakeProto)