request-block-size

hbs2-peer/app/Brains.hs

@@ -623,7 +623,7 @@ SAVEPOINT zzz1;
 
 DELETE FROM ancestors WHERE strftime('%s','now') - strftime('%s', ts) > 600;
 DELETE FROM seenby WHERE strftime('%s','now') - strftime('%s', ts) > 600;
-DELETE FROM blocksize WHERE strftime('%s','now') - strftime('%s', ts) > 1200;
+DELETE FROM blocksize WHERE strftime('%s','now') - strftime('%s', ts) > (86400*7);
 DELETE FROM statedb.pexinfo where seen <  datetime('now', '-7 days');
 DELETE FROM seen where ts < datetime('now');
 
@@ -805,9 +805,9 @@ newBasicBrains cfg = liftIO do
   brains <- runReaderT (cfgValue @PeerBrainsDb @(Maybe String)) cfg
               <&> fromMaybe ":memory:"
 
-  unless ( brains == ":memory:" ) do
+  -- unless ( brains == ":memory:" ) do
-    here <- doesFileExist brains
+  --   here <- doesFileExist brains
-    when here $ do removeFile brains
+    -- when here $ do removeFile brains
 
   conn <- open brains
 
@@ -867,6 +867,15 @@ newBasicBrains cfg = liftIO do
     , primary key (block,peer))
   |]
 
+  execute_ conn [qc|
+    create table if not exists blocksize2
+    ( block text not null
+    , peer text not null
+    , size int
+    , ts DATE DEFAULT (datetime('now','localtime'))
+    , primary key (block,peer))
+  |]
+
   execute_ conn [qc|
     create table if not exists tcpclient
     ( peer text not null

hbs2-peer/app/PeerMain.hs

@@ -612,13 +612,23 @@ runCLI = do
 
     pDoScript = do
       rpc <- pRpcCommon
+
+      w    <- option (auto @Double) ( short 'w'
+                                     <> long "timeout"
+                                     <> value 1.00
+                                     <> help "timeout in seconds (float)"
+                                     <> showDefault
+                                    )
+
       argz <- many (strArgument (metavar "TERM" <> help "script terms"))
+
       pure do
         let s = unlines $ unwords <$> splitForms argz
 
+
         withMyRPC @PeerAPI rpc $ \caller -> do
 
-           r <- callRpcWaitRetry @RpcRunScript (TimeoutSec 1) 3 caller (Text.pack s)
+           r <- callRpcWaitRetry @RpcRunScript (TimeoutSec (realToFrac w)) 3 caller (Text.pack s)
                   >>= orThrowUser "rpc timeout"
 
            for_ (parseTop r & fromRight mempty) \sexy -> do
@@ -1039,6 +1049,11 @@ runPeer opts = respawnOnError opts $ do
 
               addPeers @e pl ps
 
+              -- subscribe @e (BlockSizeEventKey h) $ \case
+              --   BlockSizeEvent (that, hx, sz) -> do
+              --     debug $ "FUCKING GOT BLOCK SIZE!" <+> pretty (AsBase58 hx) <+> pretty sz
+                  -- atomically $ writeTQueue answ (sz, that)
+
               subscribe @e PeerAnnounceEventKey $ \(PeerAnnounceEvent pip nonce) -> do
                unless (nonce == pnonce) $ do
                  debug $ "Got peer announce!" <+> pretty pip

hbs2-peer/app/RPC2.hs

@@ -11,13 +11,16 @@ module RPC2
 
 
 import HBS2.Prelude.Plated
+import HBS2.Events
 import HBS2.Net.Proto.Service
 import HBS2.Net.Proto.Sessions
 
 import HBS2.Base58
 import HBS2.Data.Types.Peer
+import HBS2.Data.Types.Refs
 import HBS2.Actors.Peer
 import HBS2.Peer.Proto.Peer
+import HBS2.Peer.Proto.BlockInfo
 import HBS2.Clock
 import HBS2.Net.Auth.Schema
 
@@ -39,11 +42,14 @@ import PeerInfo
 
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Cont
+import Control.Concurrent.STM (flushTQueue)
 import Data.Text qualified as Text
 import Data.Either
 import Data.Maybe
+import Data.Coerce
 import Numeric
 import UnliftIO
+import Streaming.Prelude qualified as S
 
 instance (e ~ L4Proto, MonadUnliftIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcRunScript where
   handleMethod top = do
@@ -85,6 +91,43 @@ instance (e ~ L4Proto, MonadUnliftIO m, HasRpcContext PeerAPI RPC2Context m) =>
 
           _ -> pure nil
 
+
+        entry $ bindMatch "request-block-size" \case
+          [LitScientificVal w,  HashLike blk] -> do
+
+            let h = coerce blk
+
+            liftIO $ withPeerM rpcPeerEnv do
+
+              answ <- newTQueueIO
+
+              forKnownPeers @e $ \p _ -> do
+
+                subscribe @e (BlockSizeEventKey p) $ \case
+                  BlockSizeEvent (that, hx, sz) | hx == h -> do
+                    debug $ "FUCKING GOT BLOCK SIZE!" <+> pretty (HashRef hx) <+> pretty p
+                    atomically $ writeTQueue answ (sz, that)
+
+                  _ -> none
+
+                request p (GetBlockSize @e h)
+
+              pause @'Seconds (realToFrac w)
+
+              r <- atomically do
+                     x <- readTQueue answ
+                     xs <- flushTQueue answ
+                     pure (x:xs)
+
+              rr <- S.toList_ $ for_ r $ \(s,p) -> do
+                      S.yield $ mkList @C [ mkSym "size", mkInt s, mkSym (show $ pretty p) ]
+
+              debug $ "WTF?!" <+> pretty rr
+              pure $ mkList rr
+
+          _ -> do
+            pure nil
+
         entry $ bindMatch "peer-info" $ const do
 
           now <- getTimeCoarse

hbs2-peer/lib/HBS2/Peer/Proto/BlockInfo.hs

@@ -1,3 +1,4 @@
+{-# Language UndecidableInstances #-}
 module HBS2.Peer.Proto.BlockInfo where
 
 import HBS2.Prelude.Plated
@@ -9,7 +10,9 @@ import HBS2.Hash
 
 import HBS2.System.Logger.Simple
 
+import Data.Hashable
 import Data.Maybe
+import Data.ByteString (ByteString)
 
 data BlockInfo e = GetBlockSize (Hash HbSync)
                  | NoBlock (Hash HbSync)
@@ -51,12 +54,12 @@ blockSizeProto getBlockSize evHasBlock onNoBlock =
 
     NoBlock h       -> do
       that <- thatPeer @proto
-      emit @e (BlockSizeEventKey h) (NoBlockEvent that)
+      emit @e (BlockSizeEventKey that) (NoBlockEvent (that, h))
       evHasBlock ( that, h, Nothing )
 
     BlockSize h sz  -> do
       that <- thatPeer @proto
-      emit @e (BlockSizeEventKey h) (BlockSizeEvent (that, h, sz))
+      emit @e (BlockSizeEventKey @e that) (BlockSizeEvent (that, h, sz))
       evHasBlock ( that, h, Just sz )
 
 newtype instance SessionKey e (BlockInfo e) =
@@ -64,16 +67,17 @@ newtype instance SessionKey e (BlockInfo e) =
   deriving stock (Typeable,Eq,Show)
   deriving newtype (Hashable,IsString)
 
-
 newtype instance EventKey e (BlockInfo e) =
-  BlockSizeEventKey (Hash HbSync)
+  BlockSizeEventKey (Peer e)
-  deriving stock (Typeable, Eq,Generic)
+  deriving stock (Typeable, Generic)
 
-deriving  instance Hashable (EventKey e (BlockInfo e))
+deriving stock instance Eq (Peer e) => Eq (EventKey e (BlockInfo e))
+
+instance (Eq (Peer e), Hashable (Peer e)) => Hashable (EventKey e (BlockInfo e))
 
 data instance Event e (BlockInfo e) =
     BlockSizeEvent (Peer e, Hash HbSync, Integer)
-  | NoBlockEvent (Peer e)
+  | NoBlockEvent (Peer e, Hash HbSync)
   deriving stock (Typeable)