diff --git a/docs/devlog.md b/docs/devlog.md index 9084ad0d..ab549b54 100644 --- a/docs/devlog.md +++ b/docs/devlog.md @@ -843,8 +843,8 @@ FIXME: Обработка ошибок в асинхронном приложе FIXME: RPC, cli для линейных ссылок +* [x] lref-get через rpc пира get * [ ] lref-new через rpc пира new -* [ ] lref-get через rpc пира get * [ ] lref-update через rpc пира update * [ ] lref-list через rpc пира list diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index fb0025c5..48f52c43 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs +++ b/hbs2-core/lib/HBS2/Data/Types/Refs.hs @@ -96,6 +96,10 @@ data instance MutableRef e 'LinearRef } deriving stock (Generic, Show) +instance Pretty (MutableRef e 'LinearRef) where + pretty LinearMutableRef {..} = + parens ( "LinearMutableRef" <+> pretty lrefId <+> pretty lrefHeight <+> pretty lrefVal) + instance Serialise (MutableRef e 'LinearRef) --- @@ -114,8 +118,10 @@ 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)) +instance (Show (Signature e), Pretty (MutableRef e 'LinearRef) + ) => Pretty (Signed 'SignaturePresent (MutableRef e 'LinearRef)) where + pretty LinearMutableRefSigned {..} = + parens ( "LinearMutableRefSigned" <+> viaShow lmrefSignature <+> pretty lmrefSignedRef) data instance Signed 'SignatureVerified (MutableRef e 'LinearRef) = LinearMutableRefSignatureVerified diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 233e71f4..21d70f99 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -762,7 +762,7 @@ runPeer opts = Exception.handle myException $ do void $ liftIO $ async $ withPeerM penv $ do st <- getStorage hval <- getLRefValAction st h - request who (RPCLRefGetAnswer @e h hval) + request who (RPCLRefGetAnswer @e hval) debug $ "lrefGetAction sent" <+> pretty h @@ -846,11 +846,31 @@ withRPC o cmd = do pokeQ <- newTQueueIO + lrefGetQ <- newTQueueIO + + let rpcAdapter = RpcAdapter + dontHandle + (liftIO . atomically . writeTQueue pokeQ) + (const $ liftIO exitSuccess) + (const $ notice "ping?") + (liftIO . atomically . writeTQueue pingQ) + dontHandle + dontHandle + + (\(pa, k) -> Log.info $ pretty (AsBase58 k) <+> pretty pa + ) + + dontHandle + + (const $ liftIO exitSuccess) + (const $ liftIO exitSuccess) + (liftIO . atomically . writeTQueue lrefGetQ) + prpc <- async $ runRPC udp1 do env <- ask proto <- liftIO $ async $ continueWithRPC env $ do runProto @UDP - [ makeResponse (rpcHandler (adapter pingQ pokeQ)) + [ makeResponse (rpcHandler rpcAdapter) ] request rpc cmd @@ -885,7 +905,11 @@ withRPC o cmd = do RPCLRefAnn{} -> pause @'Seconds 0.1 >> liftIO exitSuccess - RPCLRefGet{} -> pause @'Seconds 1 >> liftIO exitSuccess + RPCLRefGet{} -> + void $ liftIO $ void $ race (pause @'Seconds 5 >> exitFailure) do + pa <- liftIO $ atomically $ readTQueue lrefGetQ + Log.info $ "got RPCLRefGetAnswer" <+> pretty pa + exitSuccess _ -> pure () @@ -893,25 +917,6 @@ withRPC o cmd = do void $ waitAnyCatchCancel [mrpc, prpc] - where - adapter q pq = RpcAdapter - dontHandle - (liftIO . atomically . writeTQueue pq) - (const $ liftIO exitSuccess) - (const $ notice "ping?") - (liftIO . atomically . writeTQueue q) - dontHandle - dontHandle - - (\(pa, k) -> Log.info $ pretty (AsBase58 k) <+> pretty pa - ) - - 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 diff --git a/hbs2-peer/app/RPC.hs b/hbs2-peer/app/RPC.hs index c234c742..5e468947 100644 --- a/hbs2-peer/app/RPC.hs +++ b/hbs2-peer/app/RPC.hs @@ -35,7 +35,7 @@ data RPC e = | RPCLogLevel SetLogging | RPCLRefAnn (Hash HbSync) | RPCLRefGet (Hash HbSync) - | RPCLRefGetAnswer (Hash HbSync) (Maybe (Signed 'SignaturePresent (MutableRef e 'LinearRef))) + | RPCLRefGetAnswer (Maybe (Signed 'SignaturePresent (MutableRef e 'LinearRef))) deriving stock (Generic) @@ -72,7 +72,7 @@ data RpcAdapter e m = , rpcOnLogLevel :: SetLogging -> m () , rpcOnLRefAnn :: Hash HbSync -> m () , rpcOnLRefGet :: Hash HbSync -> m () - , rpcOnLRefGetAnswer :: (Hash HbSync, Maybe (Signed 'SignaturePresent (MutableRef e 'LinearRef))) -> m () + , rpcOnLRefGetAnswer :: Maybe (Signed 'SignaturePresent (MutableRef e 'LinearRef)) -> m () } newtype RpcM m a = RpcM { fromRpcM :: ReaderT RPCEnv m a } @@ -124,5 +124,5 @@ rpcHandler adapter = \case (RPCLogLevel l) -> rpcOnLogLevel adapter l (RPCLRefAnn h) -> rpcOnLRefAnn adapter h (RPCLRefGet h) -> rpcOnLRefGet adapter h - (RPCLRefGetAnswer h hval) -> rpcOnLRefGetAnswer adapter (h, hval) + (RPCLRefGetAnswer hval) -> rpcOnLRefGetAnswer adapter hval