wip, cli refchan head get

hbs2-peer/app/PeerMain.hs

@@ -427,6 +427,7 @@ respawn opts = case view peerRespawn opts of
 runPeer :: forall e s . ( e ~ L4Proto
                         , FromStringMaybe (PeerAddr e)
                         , s ~ Encryption e
+                        , Block ByteString ~ ByteString
                         ) => PeerOpts -> IO ()
 
 runPeer opts = U.handle (\e -> myException e
@@ -991,6 +992,14 @@ runPeer opts = U.handle (\e -> myException e
               let msg = RefChanHead k (RefChanHeadBlockTran (HashRef h))
               runResponseM me $ refChanHeadProto @e True refChanHeadAdapter msg
 
+  let refChanHeadGetAction puk = do
+        trace $ "refChanHeadGetAction" <+> pretty (AsBase58 puk)
+        who <- thatPeer (Proxy @(RPC e))
+        void $ liftIO $ async $ withPeerM penv $ do
+          sto <- getStorage
+          h <- liftIO $ getRef sto (RefChanHeadKey @(Encryption e) puk)
+          request who (RPCRefChanHeadGetAnsw @e  h)
+
   let arpc = RpcAdapter pokeAction
                         dieAction
                         dontHandle
@@ -1007,6 +1016,8 @@ runPeer opts = U.handle (\e -> myException e
                         reflogGetAction
                         dontHandle
                         refChanHeadSendAction -- rpcOnRefChanHeadSend
+                        refChanHeadGetAction
+                        dontHandle
 
   rpc <- async $ runRPC udp1 do
                    runProto @e

hbs2-peer/app/RPC.hs

@@ -35,6 +35,8 @@ import Network.Socket
 import System.Exit
 import System.IO
 import UnliftIO.Async as U
+import Control.Concurrent.MVar
+
 data PeerRpcKey
 
 instance HasCfgKey PeerRpcKey (Maybe String) where
@@ -60,6 +62,7 @@ data RPCCommand =
   | REFLOGFETCH (PubKey 'Sign (Encryption L4Proto))
   | REFLOGGET (PubKey 'Sign (Encryption L4Proto))
   | REFCHANHEADSEND (Hash HbSync)
+  | REFCHANHEADGET (PubKey 'Sign (Encryption L4Proto))
 
 data RPC e =
     RPCDie
@@ -78,6 +81,9 @@ data RPC e =
   | RPCRefLogGet (PubKey 'Sign (Encryption e))
   | RPCRefLogGetAnswer (Maybe (Hash HbSync))
   | RPCRefChanHeadSend (Hash HbSync)
+  | RPCRefChanHeadGet (PubKey 'Sign (Encryption e))
+  | RPCRefChanHeadGetAnsw (Maybe (Hash HbSync))
+
   deriving stock (Generic)
 
 instance (Serialise (PeerAddr e), Serialise (PubKey 'Sign (Encryption e))) => Serialise (RPC e)
@@ -115,6 +121,8 @@ data RpcAdapter e m =
   , rpcOnRefLogGet     :: PubKey 'Sign (Encryption e) -> m ()
   , rpcOnRefLogGetAnsw :: Maybe (Hash HbSync) -> m ()
   , rpcOnRefChanHeadSend :: Hash HbSync -> m ()
+  , rpcOnRefChanHeadGet :: PubKey 'Sign (Encryption e) -> m ()
+  , rpcOnRefChanHeadGetAnsw :: Maybe (Hash HbSync) -> m ()
   }
 
 newtype RpcM m a = RpcM { fromRpcM :: ReaderT RPCEnv m a }
@@ -171,6 +179,8 @@ rpcHandler adapter = \case
     (RPCRefLogGet e)   -> rpcOnRefLogGet adapter e
     (RPCRefLogGetAnswer s)   -> rpcOnRefLogGetAnsw adapter s
     (RPCRefChanHeadSend s)   -> rpcOnRefChanHeadSend adapter s
+    (RPCRefChanHeadGet s)   -> rpcOnRefChanHeadGet adapter s
+    (RPCRefChanHeadGetAnsw s)   -> rpcOnRefChanHeadGetAnsw adapter s
 
 data RPCOpt =
   RPCOpt
@@ -194,6 +204,7 @@ runRpcCommand opt = \case
   REFLOGFETCH k -> withRPC opt (RPCRefLogFetch k)
   REFLOGGET k -> withRPC opt (RPCRefLogGet k)
   REFCHANHEADSEND h -> withRPC opt (RPCRefChanHeadSend h)
+  REFCHANHEADGET s -> withRPC opt (RPCRefChanHeadGet s)
 
   _ -> pure ()
 
@@ -226,6 +237,8 @@ withRPC o cmd = rpcClientMain o $ runResourceT do
 
   refQ <- liftIO newTQueueIO
 
+  rchanheadMVar <- liftIO newEmptyMVar
+
   let  adapter =
         RpcAdapter dontHandle
                    dontHandle
@@ -249,6 +262,10 @@ withRPC o cmd = rpcClientMain o $ runResourceT do
 
                    dontHandle
 
+                   dontHandle -- rpcOnRefChanHeadGet
+
+                   (liftIO . putMVar rchanheadMVar) -- rpcOnRefChanHeadGetAnsw
+
   prpc <- async $ runRPC udp1 do
                     env <- ask
                     proto <- liftIO $ async $ continueWithRPC env $ do
@@ -313,6 +330,17 @@ withRPC o cmd = rpcClientMain o $ runResourceT do
                         pause @'Seconds 0.25
                         exitSuccess
 
+                      RPCRefChanHeadGet {} -> liftIO do
+
+                        r <- race (pause @'Seconds 2) do
+                                withMVar rchanheadMVar $ \v -> do
+                                  pure v
+
+                        case r of
+                          Right (Just x) -> print (pretty x) >> exitSuccess
+
+                          _ -> exitFailure
+
                       _ -> pure ()
 
                     void $ liftIO $ waitAnyCancel [proto]