From 8e37ae86ce1593c11137e888b845039cfbc69300 Mon Sep 17 00:00:00 2001 From: voidlizard Date: Mon, 4 Nov 2024 08:04:21 +0300 Subject: [PATCH] request-block-size --- hbs2-peer/app/Brains.hs | 17 +++++++-- hbs2-peer/app/PeerMain.hs | 17 ++++++++- hbs2-peer/app/RPC2.hs | 43 ++++++++++++++++++++++ hbs2-peer/lib/HBS2/Peer/Proto/BlockInfo.hs | 18 +++++---- 4 files changed, 83 insertions(+), 12 deletions(-) diff --git a/hbs2-peer/app/Brains.hs b/hbs2-peer/app/Brains.hs index 8fa0d4a9..b9abdb33 100644 --- a/hbs2-peer/app/Brains.hs +++ b/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 - here <- doesFileExist brains - when here $ do removeFile brains + -- unless ( brains == ":memory:" ) do + -- here <- doesFileExist 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 diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index f79eb8f0..fbc9f1ba 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/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 diff --git a/hbs2-peer/app/RPC2.hs b/hbs2-peer/app/RPC2.hs index 7ed4ae4e..40d2b65c 100644 --- a/hbs2-peer/app/RPC2.hs +++ b/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 diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/BlockInfo.hs b/hbs2-peer/lib/HBS2/Peer/Proto/BlockInfo.hs index 672105e3..11a9b357 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/BlockInfo.hs +++ b/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) - deriving stock (Typeable, Eq,Generic) + BlockSizeEventKey (Peer e) + 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)