wip

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

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) =>
+instance (Show (Signature e), Pretty (MutableRef e 'LinearRef)
-    Show (Signed 'SignaturePresent (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

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

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