lref-list

docs/devlog.md

@@ -845,9 +845,8 @@ FIXME: RPC, cli для линейных ссылок
 
 * [x] lref-get через rpc пира get
 * [x] lref-new через rpc пира new
-* [ ] lref-update через rpc пира update
+* [x] lref-update через rpc пира update
-
+* [x] lref-list через rpc пира list
-* [ ] lref-list через rpc пира list
 
 * [ ] cli на запрос значений ссылки у всех нод
 * [ ] cli на запрос всех ссылок ноды

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
-

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

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

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
+    pLRefList = do
-      -- rpc <- pRpcCommon
+      rpc <- pRpcCommon
-      -- pure $ do
+      pure $ do
-      --     runRpcCommand rpc (LREFLIST)
+          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{} ->
+                      RPCLRefNew{} -> do
-                        void $ liftIO $ void $ race (pause @'Seconds 5 >> exitFailure) do
+                          fix \go -> do
-                                 pa <- liftIO $ atomically $ readTQueue lrefNewQ
+                              r <- liftIO $ race (pause @'Seconds 5)
-                                 Log.info $ "got RPCLRefNewAnswer" <+> pretty pa
+                                      (atomically $ readTQueue lrefNewQ)
-                                 exitSuccess
+                              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

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