From 3207a48968d509205450f957c501ea7d9b28fe8e Mon Sep 17 00:00:00 2001 From: Sergey Ivanov Date: Thu, 16 Mar 2023 05:40:30 +0400 Subject: [PATCH] lref-list --- docs/devlog.md | 5 +-- hbs2-core/lib/HBS2/Base58.hs | 1 - hbs2-core/lib/HBS2/Data/Types/Refs.hs | 4 ++ hbs2-core/lib/HBS2/Merkle.hs | 6 +++ hbs2-peer/app/PeerMain.hs | 57 ++++++++++++++++++++++----- hbs2-peer/app/RPC.hs | 6 +++ 6 files changed, 65 insertions(+), 14 deletions(-) diff --git a/docs/devlog.md b/docs/devlog.md index a268e951..e79f4c9e 100644 --- a/docs/devlog.md +++ b/docs/devlog.md @@ -845,9 +845,8 @@ FIXME: RPC, cli для линейных ссылок * [x] lref-get через rpc пира get * [x] lref-new через rpc пира new -* [ ] lref-update через rpc пира update - -* [ ] lref-list через rpc пира list +* [x] lref-update через rpc пира update +* [x] lref-list через rpc пира list * [ ] cli на запрос значений ссылки у всех нод * [ ] cli на запрос всех ссылок ноды diff --git a/hbs2-core/lib/HBS2/Base58.hs b/hbs2-core/lib/HBS2/Base58.hs index 060ea813..c0a84278 100644 --- a/hbs2-core/lib/HBS2/Base58.hs +++ b/hbs2-core/lib/HBS2/Base58.hs @@ -24,4 +24,3 @@ fromBase58 = decodeBase58 bitcoinAlphabet instance Pretty (AsBase58 ByteString) where pretty (AsBase58 bs) = pretty $ BS8.unpack $ toBase58 bs - diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index 48f52c43..dce93461 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs +++ b/hbs2-core/lib/HBS2/Data/Types/Refs.hs @@ -67,6 +67,10 @@ data RefGenesis e = RefGenesis } deriving stock (Generic) +instance (Pretty (AsBase58 (PubKey 'Sign e))) => Pretty (RefGenesis e) where + pretty RefGenesis {..} = + parens ( "RefGenesis" <+> pretty (AsBase58 refOwner) <+> pretty (show refName) <+> pretty refMeta) + instance (Serialise (PubKey 'Sign e)) => Serialise (RefGenesis e) data RefForm diff --git a/hbs2-core/lib/HBS2/Merkle.hs b/hbs2-core/lib/HBS2/Merkle.hs index f8e3f36c..1fb8b39c 100644 --- a/hbs2-core/lib/HBS2/Merkle.hs +++ b/hbs2-core/lib/HBS2/Merkle.hs @@ -80,6 +80,12 @@ instance Serialise MNodeData data AnnMetaData = NoMetaData | ShortMetadata Text | AnnHashRef (Hash HbSync) deriving stock (Generic,Data,Show) +instance Pretty AnnMetaData where + pretty = \case + NoMetaData -> "NoMetaData" + ShortMetadata t -> "ShortMetadata" <+> pretty (show t) + AnnHashRef h -> "AnnHashRef" <+> pretty h + instance Serialise AnnMetaData data MTreeAnn a = MTreeAnn diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 73aa9a4a..c48e04c4 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -179,6 +179,7 @@ data RPCCommand = | SETLOG SetLogging | LREFANN (Hash HbSync) | LREFNEW (PubKey 'Sign UDP) Text + | LREFLIST | LREFGET (Hash HbSync) | LREFUPDATE (PrivKey 'Sign UDP) (PubKey 'Sign UDP) (Hash HbSync) (Hash HbSync) @@ -245,7 +246,7 @@ runCLI = join . customExecParser (prefs showHelpOnError) $ <> command "log" (info pLog (progDesc "set logging level")) <> command "lref-ann" (info pLRefAnn (progDesc "announce linear ref")) <> command "lref-new" (info pLRefNew (progDesc "generates a new linear ref")) - -- <> command "lref-list" (info pLRefList (progDesc "list node linear refs")) + <> command "lref-list" (info pLRefList (progDesc "list node linear refs")) <> command "lref-get" (info pLRefGet (progDesc "get a linear ref")) <> command "lref-update" (info pLRefUpdate (progDesc "updates a linear ref")) ) @@ -333,10 +334,10 @@ runCLI = join . customExecParser (prefs showHelpOnError) $ `orDie` "can't parse credential file" runRpcCommand rpc (LREFNEW (_peerSignPk cred) t) - -- pLRefList = do - -- rpc <- pRpcCommon - -- pure $ do - -- runRpcCommand rpc (LREFLIST) + pLRefList = do + rpc <- pRpcCommon + pure $ do + runRpcCommand rpc (LREFLIST) pLRefGet = do rpc <- pRpcCommon @@ -817,6 +818,21 @@ runPeer opts = Exception.handle myException $ do request who (RPCLRefNewAnswer @e h) debug $ "lrefNewAction sent" <+> pretty h + let lrefListAction h = do + debug $ "lrefListAction" <+> pretty h + who <- thatPeer (Proxy @(RPC e)) + void $ liftIO $ async $ withPeerM penv $ do + st <- getStorage + hs :: [Hash HbSync] <- liftIO $ readNodeLinearRefList @e st (_peerSignPk pc) + lrefs <- catMaybes <$> forM hs \chh -> runMaybeT do + g :: RefGenesis [Hash HbSync] <- MaybeT $ + ((either (const Nothing) Just . deserialiseOrFail) =<<) + <$> (liftIO $ getBlock st chh) + mlrefVal <- ((either (const Nothing) Just . deserialiseOrFail) =<<) + <$> (liftIO $ readLinkRaw st chh) + lift $ request who (RPCLRefListAnswer @e (g, mlrefVal)) + debug $ "lrefListAction sent" <+> pretty (length lrefs) + let lrefGetAction h = do debug $ "lrefGetAction" <+> pretty h who <- thatPeer (Proxy @(RPC e)) @@ -832,9 +848,11 @@ runPeer opts = Exception.handle myException $ do void $ liftIO $ async $ withPeerM penv $ do st <- getStorage let cred = PeerCredentials @e sk pk mempty + -- FIXME: do not increment counter if value is the same liftIO $ modifyLinearRef st cred lrefId \_ -> pure valh mlref <- getLRefValAction st lrefId request who (RPCLRefUpdateAnswer @e mlref) + -- FIXME: maybe fire rpc command to announce new lref value debug $ "lrefUpdateAction sent" <+> pretty mlref let arpc = RpcAdapter @@ -850,6 +868,8 @@ runPeer opts = Exception.handle myException $ do , rpcOnLRefAnn = lrefAnnAction , rpcOnLRefNew = lrefNewAction , rpcOnLRefNewAnswer = dontHandle + , rpcOnLRefList = lrefListAction + , rpcOnLRefListAnswer = dontHandle , rpcOnLRefGet = lrefGetAction , rpcOnLRefGetAnswer = dontHandle , rpcOnLRefUpdate = lrefUpdateAction @@ -925,6 +945,8 @@ withRPC o cmd = do lrefNewQ <- newTQueueIO + lrefListQ <- newTQueueIO + lrefGetQ <- newTQueueIO lrefUpdateQ <- newTQueueIO @@ -947,6 +969,9 @@ withRPC o cmd = do , rpcOnLRefNew = const $ liftIO exitSuccess , rpcOnLRefNewAnswer = liftIO . atomically . writeTQueue lrefNewQ -- + , rpcOnLRefList = const $ liftIO exitSuccess + , rpcOnLRefListAnswer = liftIO . atomically . writeTQueue lrefListQ + -- , rpcOnLRefGet = const $ liftIO exitSuccess , rpcOnLRefGetAnswer = liftIO . atomically . writeTQueue lrefGetQ -- @@ -993,11 +1018,22 @@ withRPC o cmd = do RPCLRefAnn{} -> pause @'Seconds 0.1 >> liftIO exitSuccess - RPCLRefNew{} -> - void $ liftIO $ void $ race (pause @'Seconds 5 >> exitFailure) do - pa <- liftIO $ atomically $ readTQueue lrefNewQ - Log.info $ "got RPCLRefNewAnswer" <+> pretty pa - exitSuccess + RPCLRefNew{} -> do + fix \go -> do + r <- liftIO $ race (pause @'Seconds 5) + (atomically $ readTQueue lrefNewQ) + case r of + Left _ -> pure () + Right pa -> do + Log.info $ "got RPCLRefNewAnswer" <+> pretty pa + go + liftIO exitSuccess + + RPCLRefList{} -> + void $ liftIO $ void $ race (pause @'Seconds 5 >> exitSuccess) do + forever do + (g, lrefVal) <- liftIO $ atomically $ readTQueue lrefListQ + Log.info $ "got RPCLRefListAnswer" <+> pretty g <+> pretty lrefVal RPCLRefGet{} -> void $ liftIO $ void $ race (pause @'Seconds 5 >> exitFailure) do @@ -1027,6 +1063,7 @@ runRpcCommand opt = \case SETLOG s -> withRPC opt (RPCLogLevel s) LREFANN h -> withRPC opt (RPCLRefAnn h) LREFNEW pk title -> withRPC opt (RPCLRefNew pk title) + LREFLIST -> withRPC opt RPCLRefList LREFGET h -> withRPC opt (RPCLRefGet h) LREFUPDATE sk pk lrefId h -> do -- FIXME LREFUPDATE implementation diff --git a/hbs2-peer/app/RPC.hs b/hbs2-peer/app/RPC.hs index 49f2a011..dcbcda36 100644 --- a/hbs2-peer/app/RPC.hs +++ b/hbs2-peer/app/RPC.hs @@ -36,6 +36,8 @@ data RPC e = | RPCLRefAnn (Hash HbSync) | RPCLRefNew (PubKey 'Sign e) Text | RPCLRefNewAnswer (Hash HbSync) + | RPCLRefList + | RPCLRefListAnswer (RefGenesis [Hash HbSync], Maybe (Signed 'SignaturePresent (MutableRef e 'LinearRef))) | RPCLRefGet (Hash HbSync) | RPCLRefGetAnswer (Maybe (Signed 'SignaturePresent (MutableRef e 'LinearRef))) -- | RPCLRefUpdate (Signed 'SignaturePresent (MutableRef e 'LinearRef)) @@ -78,6 +80,8 @@ data RpcAdapter e m = , rpcOnLRefAnn :: Hash HbSync -> m () , rpcOnLRefNew :: (PubKey 'Sign e, Text) -> m () , rpcOnLRefNewAnswer :: Hash HbSync -> m () + , rpcOnLRefList :: () -> m () + , rpcOnLRefListAnswer :: (RefGenesis [Hash HbSync], Maybe (Signed 'SignaturePresent (MutableRef e 'LinearRef))) -> m () , rpcOnLRefGet :: Hash HbSync -> m () , rpcOnLRefGetAnswer :: Maybe (Signed 'SignaturePresent (MutableRef e 'LinearRef)) -> m () -- , rpcOnLRefUpdate :: (Signed 'SignaturePresent (MutableRef e 'LinearRef)) -> m () @@ -135,6 +139,8 @@ rpcHandler adapter = \case (RPCLRefAnn h) -> rpcOnLRefAnn adapter h (RPCLRefNew pk t) -> rpcOnLRefNew adapter (pk, t) (RPCLRefNewAnswer h) -> rpcOnLRefNewAnswer adapter h + RPCLRefList -> rpcOnLRefList adapter () + (RPCLRefListAnswer lrefVal) -> rpcOnLRefListAnswer adapter lrefVal (RPCLRefGet h) -> rpcOnLRefGet adapter h (RPCLRefGetAnswer hval) -> rpcOnLRefGetAnswer adapter hval -- (RPCLRefUpdate upd) -> rpcOnLRefUpdate adapter upd