wip

hbs2-peer/app/CLI/Common.hs

@@ -1,10 +1,12 @@
 {-# Language TemplateHaskell #-}
 module CLI.Common where
 
+import HBS2.Prelude
 import HBS2.Clock
 import HBS2.Net.Messaging.Unix
 import HBS2.Net.Proto
 import HBS2.Net.Proto.Service
+import HBS2.Net.Auth.Schema
 
 import PeerConfig
 
@@ -58,3 +60,6 @@ pRpcCommon :: Parser RPCOpt
 pRpcCommon = do
   RPCOpt <$> optional confOpt
          <*> optional rpcOpt
+
+pPubKey :: ReadM (PubKey 'Sign HBS2Basic)
+pPubKey = maybeReader fromStringMay

hbs2-peer/app/CLI/LWWRef.hs

@@ -1,11 +1,15 @@
 module CLI.LWWRef where
 
 import HBS2.Prelude.Plated
+import HBS2.OrDie
 import HBS2.Net.Proto.Service
+import HBS2.Net.Auth.Credentials
+import HBS2.Data.Types.SignedBox
 import HBS2.Net.Auth.Schema
 import HBS2.Peer.Proto.LWWRef
 
 import HBS2.Peer.RPC.API.LWWRef
+import HBS2.KeyMan.Keys.Direct
 
 import CLI.Common
 import RPC2()
@@ -14,10 +18,13 @@ import PeerLogger hiding (info)
 import System.Exit
 
 import Options.Applicative
+import Data.Word
+import Lens.Micro.Platform
 
 pLwwRef :: Parser (IO ())
-pLwwRef = hsubparser (   command "fetch" (info pLwwRefFetch (progDesc "fetch lwwref"))
+pLwwRef = hsubparser (   command "fetch"  (info pLwwRefFetch  (progDesc "fetch lwwref"))
-                      <> command "get"   (info pLwwRefGet (progDesc "get lwwref"))
+                      <> command "get"    (info pLwwRefGet    (progDesc "get lwwref"))
+                      <> command "update" (info pLwwRefUpdate (progDesc "update lwwref"))
                      )
 pLwwRefFetch :: Parser (IO ())
 pLwwRefFetch = do
@@ -40,4 +47,18 @@ pLwwRefGet = do
       Left e  -> err (viaShow e) >> exitFailure
       Right r -> print $ pretty r
 
+pLwwRefUpdate :: Parser (IO ())
+pLwwRefUpdate = do
+  rpc <- pRpcCommon
+  puk <- argument pPubKey (metavar "LWWREF")
+  seq <- option @Word64 auto (short 's' <> long "seq" <> help "seqno" <>metavar "SEQ")
+  val <- option (maybeReader fromStringMay) (short 'v' <> long "value" <> help "value" <> metavar "VALUE")
+  pure $ withMyRPC @LWWRefAPI rpc $ \caller -> do
+    (sk,pk) <- liftIO $ runKeymanClient do
+                 creds  <- loadCredentials puk >>= orThrowUser "can't load credentials"
+                 pure ( view peerSignSk  creds, view peerSignPk creds )
+    let box =  makeSignedBox @L4Proto pk sk (LWWRef @L4Proto seq val Nothing)
+    callService @RpcLWWRefUpdate caller box >>= \case
+      Left e  -> err (viaShow e) >> exitFailure
+      Right r -> print $ pretty r
 

hbs2-peer/app/RPC2/LWWRef.hs

@@ -9,6 +9,7 @@ import HBS2.Actors.Peer
 import HBS2.Data.Types.SignedBox
 import HBS2.Peer.Proto
 import HBS2.Peer.Proto.LWWRef
+import HBS2.Peer.Proto.LWWRef.Internal
 import HBS2.Storage
 import HBS2.Net.Messaging.Unix
 
@@ -57,8 +58,17 @@ instance LWWRefContext m => HandleMethod m RpcLWWRefFetch where
 instance LWWRefContext m => HandleMethod m RpcLWWRefUpdate where
 
   handleMethod box = do
-    -- co <- getRpcContext @LWWRefAPI
+    co <- getRpcContext @LWWRefAPI
     debug "rpc.LWWRefUpdate"
-    pure ()
+
+    let penv = rpcPeerEnv co
+
+    void $ runMaybeT do
+      (puk, _) <- unboxSignedBox0 box & toMPlus
+
+      liftIO $ withPeerM penv do
+        me <- ownPeer @L4Proto
+        runResponseM me $ do
+          lwwRefProto (LWWRefProto1 (LWWProtoSet @L4Proto (LWWRefKey puk) box))
 
 

hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs

@@ -28,8 +28,8 @@ data LWWRefProto e =
 data LWWRef e =
   LWWRef
   { lwwSeq      :: Word64
-  , lwwProof    :: Maybe HashRef
   , lwwValue    :: HashRef
+  , lwwProof    :: Maybe HashRef
   }
   deriving stock (Generic)
 
@@ -73,10 +73,13 @@ instance Pretty (AsBase58 (PubKey 'Sign s )) => Pretty (LWWRefKey s) where
 
 
 instance Pretty (LWWRef e) where
-  pretty (LWWRef{..}) = braces $ "lwwref" <> line
+  pretty (LWWRef{..}) = parens ( "lwwref" <> line
-                          <> indent 2
+                          <> indent 2 ( seqno <> line <> val <> line <> proof)
-                               ( "seq" <+> pretty lwwSeq <> line
+                        )
-                                 <> "val" <+> pretty lwwValue <> line
+    where
-                                 <> "proof" <+> pretty lwwProof <> line
+      seqno = parens ( "seq" <+> pretty lwwSeq )
-                               )
+      val   = parens ( "value" <+> pretty lwwValue )
+      proof | isNothing lwwProof = mempty
+            | otherwise = parens ( "proof" <+> pretty lwwProof)
+