diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index 55f43170..fb0025c5 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs +++ b/hbs2-core/lib/HBS2/Data/Types/Refs.hs @@ -114,6 +114,9 @@ data instance Signed SignaturePresent (MutableRef e 'LinearRef) instance Serialise (Signature e) => Serialise (Signed 'SignaturePresent (MutableRef e 'LinearRef)) +instance Show (Signature e) => + Show (Signed 'SignaturePresent (MutableRef e 'LinearRef)) + data instance Signed 'SignatureVerified (MutableRef e 'LinearRef) = LinearMutableRefSignatureVerified { lmrefVSignature :: Signature e diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 8a6fdc8e..87dc04c4 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -145,12 +145,13 @@ makeLenses 'RPCOpt data RPCCommand = POKE | ANNOUNCE (Hash HbSync) - | ANNLREF (Hash HbSync) | PING (PeerAddr UDP) (Maybe (Peer UDP)) | CHECK PeerNonce (PeerAddr UDP) (Hash HbSync) | FETCH (Hash HbSync) | PEERS | SETLOG SetLogging + | LREFANN (Hash HbSync) + | LREFGET (Hash HbSync) data PeerOpts = PeerOpts @@ -209,11 +210,15 @@ runCLI = join . customExecParser (prefs showHelpOnError) $ <> command "run" (info pRun (progDesc "run peer")) <> command "poke" (info pPoke (progDesc "poke peer by rpc")) <> command "announce" (info pAnnounce (progDesc "announce block")) - <> command "annlref" (info pAnnLRef (progDesc "announce linear ref")) <> command "ping" (info pPing (progDesc "ping another peer")) <> command "fetch" (info pFetch (progDesc "fetch block")) <> 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-get" (info pLRefGet (progDesc "get a linear ref")) + -- <> command "lref-update" (info pUpdateLRef (progDesc "updates a linear ref")) ) confOpt = strOption ( long "config" <> short 'c' <> help "config" ) @@ -254,11 +259,6 @@ runCLI = join . customExecParser (prefs showHelpOnError) $ h <- strArgument ( metavar "HASH" ) pure $ runRpcCommand rpc (ANNOUNCE h) - pAnnLRef = do - rpc <- pRpcCommon - h <- strArgument ( metavar "HASH" ) - pure $ runRpcCommand rpc (ANNLREF h) - pFetch = do rpc <- pRpcCommon h <- strArgument ( metavar "HASH" ) @@ -289,6 +289,16 @@ runCLI = join . customExecParser (prefs showHelpOnError) $ pref <- optional $ strArgument ( metavar "DIR" ) pure $ peerConfigInit pref + pLRefAnn = do + rpc <- pRpcCommon + h <- strArgument ( metavar "HASH" ) + pure $ runRpcCommand rpc (LREFANN h) + + pLRefGet = do + rpc <- pRpcCommon + h <- strArgument ( metavar "REF-ID" ) + pure $ runRpcCommand rpc (LREFGET h) + myException :: SomeException -> IO () myException e = die ( show e ) >> exitFailure @@ -634,13 +644,6 @@ runPeer opts = Exception.handle myException $ do debug $ "send single-cast announces" <+> pretty p request @e p announce - ANNLREF h -> do - debug $ "got annlref rpc" <+> pretty h - st <- getStorage - void $ runMaybeT do - slref <- MaybeT $ getLRefValAction st h - lift $ broadcastMsgAction' env (AnnLRef @e h slref :: LRefProto UDP) - CHECK nonce pa h -> do pip <- fromPeerAddr @e pa @@ -679,6 +682,16 @@ runPeer opts = Exception.handle myException $ do withDownload denv $ do processBlock h + LREFANN h -> do + debug $ "got lrefann rpc" <+> pretty h + st <- getStorage + void $ runMaybeT 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 () @@ -704,9 +717,6 @@ runPeer opts = Exception.handle myException $ do let annAction h = do liftIO $ atomically $ writeTQueue rpcQ (ANNOUNCE h) - let annLRefAction h = do - liftIO $ atomically $ writeTQueue rpcQ (ANNLREF h) - let pingAction pa = do that <- thatPeer (Proxy @(RPC e)) liftIO $ atomically $ writeTQueue rpcQ (PING pa (Just that)) @@ -743,16 +753,31 @@ runPeer opts = Exception.handle myException $ do trace "TraceOff" setLoggingOff @TRACE + let lrefAnnAction h = do + liftIO $ atomically $ writeTQueue rpcQ (LREFANN h) + + let lrefGetAction h = do + debug $ "lrefGetAction" <+> pretty h + who <- thatPeer (Proxy @(RPC e)) + void $ liftIO $ async $ withPeerM penv $ do + st <- getStorage + mhval <- getLRefValAction st h + forM_ mhval \hval -> + request who (RPCLRefGetAnswer @e h hval) + + let arpc = RpcAdapter pokeAction dontHandle annAction - annLRefAction pingAction dontHandle fetchAction peersAction dontHandle logLevelAction + lrefAnnAction + lrefGetAction + (\h hval -> pure ()) rpc <- async $ runRPC udp1 do runProto @e @@ -833,8 +858,6 @@ withRPC o cmd = do case cmd of RPCAnnounce{} -> pause @'Seconds 0.1 >> liftIO exitSuccess - RPCAnnLRef{} -> pause @'Seconds 0.1 >> liftIO exitSuccess - RPCFetch{} -> pause @'Seconds 0.1 >> liftIO exitSuccess RPCPing{} -> do @@ -860,6 +883,10 @@ withRPC o cmd = do RPCLogLevel{} -> liftIO exitSuccess + RPCLRefAnn{} -> pause @'Seconds 0.1 >> liftIO exitSuccess + + RPCLRefGet{} -> pause @'Seconds 1 >> liftIO exitSuccess + _ -> pure () void $ liftIO $ waitAnyCatchCancel [proto] @@ -871,7 +898,6 @@ withRPC o cmd = do dontHandle (liftIO . atomically . writeTQueue pq) (const $ liftIO exitSuccess) - (const $ liftIO exitSuccess) (const $ notice "ping?") (liftIO . atomically . writeTQueue q) dontHandle @@ -882,15 +908,20 @@ withRPC o cmd = do dontHandle + (const $ liftIO exitSuccess) + (const $ liftIO exitSuccess) + (\h hval -> Log.info $ pretty h <+> viaShow hval) + runRpcCommand :: RPCOpt -> RPCCommand -> IO () runRpcCommand opt = \case POKE -> withRPC opt RPCPoke PING s _ -> withRPC opt (RPCPing s) ANNOUNCE h -> withRPC opt (RPCAnnounce h) - ANNLREF h -> withRPC opt (RPCAnnLRef h) FETCH h -> withRPC opt (RPCFetch h) PEERS -> withRPC opt RPCPeers SETLOG s -> withRPC opt (RPCLogLevel s) + LREFANN h -> withRPC opt (RPCLRefAnn h) + LREFGET h -> withRPC opt (RPCLRefGet h) _ -> pure () diff --git a/hbs2-peer/app/RPC.hs b/hbs2-peer/app/RPC.hs index d7860680..ef8dbe2b 100644 --- a/hbs2-peer/app/RPC.hs +++ b/hbs2-peer/app/RPC.hs @@ -2,6 +2,7 @@ {-# Language UndecidableInstances #-} module RPC where +import HBS2.Data.Types.Refs import HBS2.Prelude.Plated import HBS2.Net.Proto import HBS2.Hash @@ -28,15 +29,20 @@ data RPC e = | RPCPong (PeerAddr e) | RPCPokeAnswer (PubKey 'Sign e) | RPCAnnounce (Hash HbSync) - | RPCAnnLRef (Hash HbSync) | RPCFetch (Hash HbSync) | RPCPeers | RPCPeersAnswer (PeerAddr e) (PubKey 'Sign e) | RPCLogLevel SetLogging + | RPCLRefAnn (Hash HbSync) + | RPCLRefGet (Hash HbSync) + | RPCLRefGetAnswer (Hash HbSync) (Signed SignaturePresent (MutableRef e 'LinearRef)) deriving stock (Generic) -instance Serialise (PeerAddr e) => Serialise (RPC e) +instance ( + Serialise (PeerAddr e) + , Serialise (Signature e) + ) => Serialise (RPC e) instance HasProtocol UDP (RPC UDP) where type instance ProtocolId (RPC UDP) = 0xFFFFFFE0 @@ -58,13 +64,15 @@ data RpcAdapter e m = { rpcOnPoke :: RPC e -> m () , rpcOnPokeAnswer :: PubKey 'Sign e -> m () , rpcOnAnnounce :: Hash HbSync -> m () - , rpcOnAnnLRef :: Hash HbSync -> m () , rpcOnPing :: PeerAddr e -> m () , rpcOnPong :: PeerAddr e -> m () , rpcOnFetch :: Hash HbSync -> m () , rpcOnPeers :: RPC e -> m () , rpcOnPeersAnswer :: (PeerAddr e, PubKey 'Sign e) -> m () , rpcOnLogLevel :: SetLogging -> m () + , rpcOnLRefAnn :: Hash HbSync -> m () + , rpcOnLRefGet :: Hash HbSync -> m () + , rpcOnLRefGetAnswer :: Hash HbSync -> Signed SignaturePresent (MutableRef e 'LinearRef) -> m () } newtype RpcM m a = RpcM { fromRpcM :: ReaderT RPCEnv m a } @@ -108,11 +116,13 @@ rpcHandler adapter = \case p@RPCPoke{} -> rpcOnPoke adapter p (RPCPokeAnswer k) -> rpcOnPokeAnswer adapter k (RPCAnnounce h) -> rpcOnAnnounce adapter h - (RPCAnnLRef h) -> rpcOnAnnLRef adapter h (RPCPing pa) -> rpcOnPing adapter pa (RPCPong pa) -> rpcOnPong adapter pa (RPCFetch h) -> rpcOnFetch adapter h p@RPCPeers{} -> rpcOnPeers adapter p (RPCPeersAnswer pa k) -> rpcOnPeersAnswer adapter (pa,k) (RPCLogLevel l) -> rpcOnLogLevel adapter l + (RPCLRefAnn h) -> rpcOnLRefAnn adapter h + (RPCLRefGet h) -> rpcOnLRefGet adapter h + (RPCLRefGetAnswer h hval) -> rpcOnLRefGetAnswer adapter h hval