diff --git a/hbs2-core/lib/HBS2/Refs/Linear.hs b/hbs2-core/lib/HBS2/Refs/Linear.hs index f7c2d9b4..5001c1e5 100644 --- 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 diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 21d70f99..ca180cfb 100644 --- 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 () diff --git a/hbs2-peer/app/RPC.hs b/hbs2-peer/app/RPC.hs index 5e468947..f07375ef 100644 --- 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 diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 22900e0f..47230e17 100644 --- 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