lref-new command

2023-03-15 08:38:09 +04:00 · 2023-03-15 08:38:09 +04:00 · 95fd2f2c0a
parent 70ef552bd3
commit 95fd2f2c0a
4 changed files with 91 additions and 15 deletions
--- a/hbs2-core/lib/HBS2/Refs/Linear.hs
+++ b/hbs2-core/lib/HBS2/Refs/Linear.hs
@ -7,6 +7,7 @@ import HBS2.Data.Types.Refs
 import HBS2.Defaults
 import HBS2.Events
 import HBS2.Hash
+import HBS2.Merkle
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Messaging
 import HBS2.Net.PeerLocator
@ -147,6 +148,21 @@ readNodeLinearRefList ss pk = do
          fromMaybe mempty . ((either (const Nothing) Just . deserialiseOrFail) =<<)
              <$> getBlock ss (lrefVal ref)

+nodeRefListNew :: forall e.
+    ( Signatures e
+    , Serialise (Signature e)
+    , Serialise (PubKey 'Sign e)
+    , Eq (PubKey 'Sign e)
+    , Block LBS.ByteString ~ LBS.ByteString
+    )
+    => AnyStorage -> PeerCredentials e -> PubKey 'Sign e -> Text -> AnnMetaData -> IO (Hash HbSync)
+nodeRefListNew st nodeCred ownerPk title meta = do
+  -- полученный хэш будет хэшем ссылки на созданный канал владельца c ownerCred
+  chh <- (putBlock st . serialise) (RefGenesis @e ownerPk title meta)
+      `orDie` "can not put channel genesis block"
+  nodeRefListAdd st nodeCred chh
+  pure chh
+
 nodeRefListAdd :: forall e.
    ( Signatures e
    , Serialise (Signature e)
@ -155,8 +171,8 @@ nodeRefListAdd :: forall e.
    , Block LBS.ByteString ~ LBS.ByteString
    )
    => AnyStorage -> PeerCredentials e -> Hash HbSync -> IO ()
-nodeRefListAdd ss nodeCred chh = do
+nodeRefListAdd st nodeCred chh = do
  -- полученный хэш будет хэшем ссылки на список референсов ноды
-  lrh <- (putBlock ss . serialise) (nodeLinearRefsRef @e (_peerSignPk nodeCred))
+  lrh <- (putBlock st . serialise) (nodeLinearRefsRef @e (_peerSignPk nodeCred))
      `orDie` "can not create node refs genesis"
-  modifyNodeLinearRefList ss nodeCred lrh $ Set.toList . Set.insert chh . Set.fromList
+  modifyNodeLinearRefList st nodeCred lrh $ Set.toList . Set.insert chh . Set.fromList
--- a/hbs2-peer/app/PeerMain.hs
+++ b/hbs2-peer/app/PeerMain.hs
@ -12,6 +12,7 @@ import HBS2.Data.Types.Refs
 import HBS2.Defaults
 import HBS2.Events
 import HBS2.Hash
+import HBS2.Merkle
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.IP.Addr
 import HBS2.Net.Messaging.UDP
@ -90,6 +91,7 @@ data PeerBlackListKey
 data PeerStorageKey
 data PeerAcceptAnnounceKey
 data PeerTraceKey
+data PeerAcceptLRefFromKey

 data AcceptAnnounce = AcceptAnnounceAll
                    | AcceptAnnounceFrom (Set (PubKey 'Sign UDP))
@ -132,6 +134,31 @@ instance HasCfgValue PeerAcceptAnnounceKey AcceptAnnounce where
                          ]
      kk = key @PeerAcceptAnnounceKey @AcceptAnnounce

+---
+
+data AcceptLRefFrom = AcceptLRefFromAll
+                    | AcceptLRefFrom (Set (PubKey 'Sign UDP))
+
+instance Pretty AcceptLRefFrom where
+  pretty = \case
+    AcceptLRefFromAll -> parens ("accept-lref-from" <+> "*")
+
+    AcceptLRefFrom xs -> parens ("accept-lref-from" <+> pretty (fmap AsBase58 (Set.toList xs)))
+
+instance HasCfgKey PeerAcceptLRefFromKey AcceptLRefFrom where
+  key = "accept-lref-from"
+
+instance HasCfgValue PeerAcceptLRefFromKey AcceptLRefFrom where
+  cfgValue (PeerConfig syn) = fromMaybe (AcceptLRefFrom lst) fromAll
+    where
+      fromAll = headMay [ AcceptLRefFromAll | ListVal @C (Key s [SymbolVal "*"]) <- syn, s == kk ]
+      lst = Set.fromList $
+                catMaybes [ fromStringMay @(PubKey 'Sign UDP) (Text.unpack e)
+                          | ListVal @C (Key s [LitStrVal e]) <- syn, s == kk
+                          ]
+      kk = key @PeerAcceptLRefFromKey @AcceptLRefFrom
+
+---

 data RPCOpt =
  RPCOpt
@ -151,6 +178,7 @@ data RPCCommand =
  | PEERS
  | SETLOG SetLogging
  | LREFANN (Hash HbSync)
+  | LREFNEW (PubKey 'Sign UDP) Text
  | LREFGET (Hash HbSync)

 data PeerOpts =
@ -215,10 +243,10 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
                        <> command "peers"     (info pPeers (progDesc "show known peers"))
                        <> command "log"       (info pLog   (progDesc "set logging level"))
                        <> command "lref-ann"  (info pLRefAnn (progDesc "announce linear ref"))
-                        -- <> command "lref-new"  (info pNewLRef (progDesc "generates a new linear ref"))
-                        -- <> command "lref-list" (info pListLRef (progDesc "list node linear refs"))
+                        <> command "lref-new"  (info pLRefNew (progDesc "generates a new linear ref"))
+                        -- <> command "lref-list" (info pLRefList (progDesc "list node linear refs"))
                        <> command "lref-get"  (info pLRefGet (progDesc "get a linear ref"))
-                        -- <> command "lref-update" (info pUpdateLRef (progDesc "updates a linear ref"))
+                        -- <> command "lref-update" (info pLRefUpdate (progDesc "updates a linear ref"))
                        )

    confOpt = strOption ( long "config"  <> short 'c' <> help "config" )
@ -294,6 +322,15 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
      h   <- strArgument ( metavar "HASH" )
      pure $ runRpcCommand rpc (LREFANN h)

+    pLRefNew = do
+      rpc <- pRpcCommon
+      credFile <- strOption ( short 'k' <> long "key" <> help "author keys file" )
+      t <- strArgument ( metavar "TEXT" )
+      pure $ do
+          cred <- (LBS.readFile credFile
+                    <&> parseCredentials @UDP . AsCredFile . LBS.toStrict . LBS.take 4096)
+              `orDie` "can't parse credential file"
+          runRpcCommand rpc (LREFNEW (_peerSignPk cred) t)
    pLRefGet = do
      rpc <- pRpcCommon
      h   <- strArgument ( metavar "REF-ID" )
@ -689,9 +726,6 @@ runPeer opts = Exception.handle myException $ do
                                  slref <- MaybeT $ getLRefValAction st h
                                  lift $ broadcastMsgAction' env (AnnLRef @e h slref :: LRefProto UDP)

-                            LREFGET h -> do
-                              debug $ "got lrefget rpc" <+> pretty h
-
                            _ -> pure ()


@ -756,6 +790,15 @@ runPeer opts = Exception.handle myException $ do
  let lrefAnnAction h = do
        liftIO $ atomically $ writeTQueue rpcQ (LREFANN h)

+  let lrefNewAction q@(pk, t) = do
+        debug $ "lrefNewAction" <+> viaShow q
+        who <- thatPeer (Proxy @(RPC e))
+        void $ liftIO $ async $ withPeerM penv $ do
+            st <- getStorage
+            h <- liftIO $ nodeRefListNew st pc pk t NoMetaData
+            request who (RPCLRefNewAnswer @e h)
+            debug $ "lrefNewAction sent" <+> pretty h
+
  let lrefGetAction h = do
        debug $ "lrefGetAction" <+> pretty h
        who <- thatPeer (Proxy @(RPC e))
@ -765,7 +808,6 @@ runPeer opts = Exception.handle myException $ do
            request who (RPCLRefGetAnswer @e hval)
            debug $ "lrefGetAction sent" <+> pretty h

-
  let arpc = RpcAdapter pokeAction
                        dontHandle
                        annAction
@ -776,6 +818,8 @@ runPeer opts = Exception.handle myException $ do
                        dontHandle
                        logLevelAction
                        lrefAnnAction
+                        lrefNewAction
+                        dontHandle
                        lrefGetAction
                        dontHandle

@ -846,6 +890,8 @@ withRPC o cmd = do

  pokeQ <- newTQueueIO

+  lrefNewQ <- newTQueueIO
+
  lrefGetQ <- newTQueueIO

  let rpcAdapter = RpcAdapter
@ -863,6 +909,10 @@ withRPC o cmd = do
          dontHandle

          (const $ liftIO exitSuccess)
+
+          (const $ liftIO exitSuccess)
+          (liftIO . atomically . writeTQueue lrefNewQ)
+
          (const $ liftIO exitSuccess)
          (liftIO . atomically . writeTQueue lrefGetQ)

@ -905,6 +955,12 @@ 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
+
                      RPCLRefGet{} ->
                        void $ liftIO $ void $ race (pause @'Seconds 5 >> exitFailure) do
                                 pa <- liftIO $ atomically $ readTQueue lrefGetQ
@ -926,6 +982,7 @@ runRpcCommand opt = \case
  PEERS -> withRPC opt RPCPeers
  SETLOG s -> withRPC opt (RPCLogLevel s)
  LREFANN h -> withRPC opt (RPCLRefAnn h)
+  LREFNEW pk title -> withRPC opt (RPCLRefNew pk title)
  LREFGET h -> withRPC opt (RPCLRefGet h)

  _ -> pure ()
--- a/hbs2-peer/app/RPC.hs
+++ b/hbs2-peer/app/RPC.hs
@ -34,6 +34,8 @@ data RPC e =
  | RPCPeersAnswer (PeerAddr e) (PubKey 'Sign e)
  | RPCLogLevel SetLogging
  | RPCLRefAnn (Hash HbSync)
+  | RPCLRefNew (PubKey 'Sign e) Text
+  | RPCLRefNewAnswer (Hash HbSync)
  | RPCLRefGet (Hash HbSync)
  | RPCLRefGetAnswer (Maybe (Signed 'SignaturePresent (MutableRef e 'LinearRef)))
  deriving stock (Generic)
@ -71,6 +73,8 @@ data RpcAdapter e m =
  , rpcOnPeersAnswer :: (PeerAddr e, PubKey 'Sign e) -> m ()
  , rpcOnLogLevel    :: SetLogging -> m ()
  , rpcOnLRefAnn     :: Hash HbSync -> m ()
+  , rpcOnLRefNew     :: (PubKey 'Sign e, Text) -> m ()
+  , rpcOnLRefNewAnswer :: Hash HbSync -> m ()
  , rpcOnLRefGet     :: Hash HbSync -> m ()
  , rpcOnLRefGetAnswer :: Maybe (Signed 'SignaturePresent (MutableRef e 'LinearRef)) -> m ()
  }
@ -123,6 +127,8 @@ rpcHandler adapter = \case
    (RPCPeersAnswer pa k) -> rpcOnPeersAnswer adapter (pa,k)
    (RPCLogLevel l)    -> rpcOnLogLevel adapter l
    (RPCLRefAnn h)     -> rpcOnLRefAnn adapter h
+    (RPCLRefNew pk t)     -> rpcOnLRefNew adapter (pk, t)
+    (RPCLRefNewAnswer h) -> rpcOnLRefNewAnswer adapter h
    (RPCLRefGet h)     -> rpcOnLRefGet adapter h
    (RPCLRefGetAnswer hval) -> rpcOnLRefGetAnswer adapter hval

--- a/hbs2/Main.hs
+++ b/hbs2/Main.hs
@ -327,11 +327,8 @@ runNewLRef nf uf refName (AnyStorage -> st) = do
      `orDie` "bad node keyring file"
  ownerCred <- (parseCredentials @UDP . AsCredFile <$> BS.readFile uf)
      `orDie` "bad ref owner keyring file"
-  -- полученный хэш будет хэшем ссылки на созданный канал владельца c ownerCred
-  -- Это тоже перенести в Refs.hs ?
-  chh <- (putBlock st . serialise) (RefGenesis (_peerSignPk ownerCred) refName NoMetaData)
-      `orDie` "can not put channel genesis block"
-  nodeRefListAdd st nodeCred chh
+  hPrint stdout . pretty
+      =<< nodeRefListNew st nodeCred (_peerSignPk ownerCred) refName NoMetaData

 runListLRef :: FilePath -> SimpleStorage HbSync -> IO ()
 runListLRef nf (AnyStorage -> st) = do