wip

hbs2-peer/app/CLI/LWWRef.hs

@@ -1,24 +1,43 @@
 module CLI.LWWRef where
 
 import HBS2.Prelude.Plated
+import HBS2.Net.Proto.Service
+import HBS2.Net.Auth.Schema
 import HBS2.Peer.Proto.LWWRef
 
+import HBS2.Peer.RPC.API.LWWRef
+
 import CLI.Common
 import RPC2()
 import PeerLogger hiding (info)
 
+import System.Exit
+
 import Options.Applicative
 
 pLwwRef :: Parser (IO ())
 pLwwRef = hsubparser (   command "fetch" (info pLwwRefFetch (progDesc "fetch lwwref"))
-                      <> command "get" (info pLwwRefGet (progDesc "get lwwref"))
+                      <> command "get"   (info pLwwRefGet (progDesc "get lwwref"))
                      )
 pLwwRefFetch :: Parser (IO ())
-pLwwRefFetch = pure do
-  pure ()
+pLwwRefFetch = do
+  rpc <- pRpcCommon
+  ref <- strArgument (metavar "LWWREF")
+  pure $ withMyRPC @LWWRefAPI rpc $ \caller -> do
+    callService @RpcLWWRefFetch caller ref >>= \case
+      Left e  -> err (viaShow e) >> exitFailure
+      Right{} -> pure ()
+
+lwwRef :: ReadM (LWWRefKey HBS2Basic)
+lwwRef = maybeReader (fromStringMay @(LWWRefKey HBS2Basic))
 
 pLwwRefGet :: Parser (IO ())
-pLwwRefGet = pure do
-  pure ()
+pLwwRefGet = do
+  rpc <- pRpcCommon
+  ref <- strArgument (metavar "LWWREF")
+  pure $ withMyRPC @LWWRefAPI rpc $ \caller -> do
+    callService @RpcLWWRefGet caller ref >>= \case
+      Left e  -> err (viaShow e) >> exitFailure
+      Right r -> print $ pretty r
 
 

hbs2-peer/app/PeerMain.hs

@@ -67,6 +67,7 @@ import HBS2.Peer.RPC.API.Storage
 import HBS2.Peer.RPC.API.Peer
 import HBS2.Peer.RPC.API.RefLog
 import HBS2.Peer.RPC.API.RefChan
+import HBS2.Peer.RPC.API.LWWRef
 import HBS2.Peer.Notify
 import HBS2.Peer.RPC.Client.StorageClient
 
@@ -1160,6 +1161,7 @@ runPeer opts = Exception.handle (\e -> myException e
       , makeResponse (makeServer @RefLogAPI)
       , makeResponse (makeServer @RefChanAPI)
       , makeResponse (makeServer @StorageAPI)
+      , makeResponse (makeServer @LWWRefAPI)
       , makeResponse (makeNotifyServer @(RefChanEvents L4Proto) env)
       , makeResponse (makeNotifyServer @(RefLogEvents L4Proto) envrl)
       ]

hbs2-peer/app/RPC2.hs

@@ -2,10 +2,12 @@ module RPC2
   ( module RPC2.Peer
   , module RPC2.RefLog
   , module RPC2.RefChan
+  , module RPC2.LWWRef
   ) where
 
 
 import RPC2.Peer
 import RPC2.RefLog
 import RPC2.RefChan
+import RPC2.LWWRef
 

hbs2-peer/app/RPC2/LWWRef.hs

@@ -1 +1,64 @@
-module RPC2.LWWRef where
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# Language UndecidableInstances #-}
+module RPC2.LWWRef where
+
+
+import HBS2.Peer.Prelude
+
+import HBS2.Actors.Peer
+import HBS2.Data.Types.SignedBox
+import HBS2.Peer.Proto
+import HBS2.Peer.Proto.LWWRef
+import HBS2.Storage
+import HBS2.Net.Messaging.Unix
+
+import PeerTypes
+
+import HBS2.Peer.RPC.Internal.Types
+import HBS2.Peer.RPC.API.LWWRef
+
+import Lens.Micro.Platform
+import Control.Monad.Reader
+import Control.Monad.Trans.Maybe
+
+type LWWRefContext m = (MonadIO m, HasRpcContext LWWRefAPI RPC2Context m)
+
+instance (Monad m)
+  => HasRpcContext LWWRefAPI RPC2Context (ResponseM UNIX (ReaderT RPC2Context m)) where
+  getRpcContext = lift ask
+
+instance (LWWRefContext m) => HandleMethod m RpcLWWRefGet where
+
+  handleMethod key = do
+    co <- getRpcContext @LWWRefAPI
+    debug "rpc.LWWRefContext"
+
+    let penv = rpcPeerEnv co
+    liftIO $ withPeerM penv $ do
+      sto <- getStorage
+      runMaybeT do
+        rv <- getRef sto key >>= toMPlus
+        val <- getBlock sto rv >>= toMPlus
+                <&> unboxSignedBox @(LWWRef L4Proto) @L4Proto
+                >>= toMPlus
+
+        pure $ snd val
+
+instance LWWRefContext m => HandleMethod m RpcLWWRefFetch where
+
+  handleMethod key = do
+    co <- getRpcContext @LWWRefAPI
+    debug $ "rpc.LWWRefFetch" <+> pretty key
+
+    let penv = rpcPeerEnv co
+    liftIO $ withPeerM penv $ do
+      gossip (LWWRefProto1 @L4Proto (LWWProtoGet key))
+
+instance LWWRefContext m => HandleMethod m RpcLWWRefUpdate where
+
+  handleMethod box = do
+    -- co <- getRpcContext @LWWRefAPI
+    debug "rpc.LWWRefUpdate"
+    pure ()
+
+

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

@@ -10,6 +10,7 @@ import HBS2.Data.Types.Refs
 import HBS2.Net.Proto.Types
 import HBS2.Net.Auth.Schema()
 
+import Data.ByteString (ByteString)
 import Data.Hashable hiding (Hashed)
 import Data.Maybe
 import Data.Word
@@ -26,9 +27,9 @@ data LWWRefProto e =
 
 data LWWRef e =
   LWWRef
-  { lwwSeq   :: Word64
-  , lwwProof :: Maybe HashRef
-  , lwwValue :: HashRef
+  { lwwSeq      :: Word64
+  , lwwProof    :: Maybe HashRef
+  , lwwValue    :: HashRef
   }
   deriving stock (Generic)
 
@@ -41,7 +42,7 @@ instance ForLWWRefProto e => Serialise (LWWRef e)
 
 newtype LWWRefKey s =
   LWWRefKey
-  { lwwRefKey :: PubKey 'Sign s
+  { fromLwwRefKey :: PubKey 'Sign s
   }
   deriving stock (Generic)
 
@@ -70,3 +71,12 @@ instance Pretty (AsBase58 (PubKey 'Sign s )) => Pretty (AsBase58 (LWWRefKey s))
 instance Pretty (AsBase58 (PubKey 'Sign s )) => Pretty (LWWRefKey s) where
   pretty (LWWRefKey k) = pretty (AsBase58 k)
 
+
+instance Pretty (LWWRef e) where
+  pretty (LWWRef{..}) = braces $ "lwwref" <> line
+                          <> indent 2
+                               ( "seq" <+> pretty lwwSeq <> line
+                                 <> "val" <+> pretty lwwValue <> line
+                                 <> "proof" <+> pretty lwwProof <> line
+                               )
+

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

@@ -63,7 +63,9 @@ lwwRefProto pkt@(LWWRefProto1 req) = do
 
     LWWProtoSet key box -> void $ runMaybeT do
 
-      (_, lww) <- MaybeT $ pure $ unboxSignedBox0 box
+      (puk, lww) <- MaybeT $ pure $ unboxSignedBox0 box
+
+      guard ( puk == fromLwwRefKey key )
 
       deferred @proto do
 

hbs2-peer/lib/HBS2/Peer/RPC/API/LWWRef.hs

@@ -11,25 +11,30 @@ import HBS2.Peer.Proto.RefLog (RefLogUpdate)
 import Data.ByteString.Lazy (ByteString)
 import Codec.Serialise
 
-data LWWRefGet
-data LWWRefUpdate
+data RpcLWWRefGet
+data RpcLWWRefUpdate
+data RpcLWWRefFetch
 
-type LWWRefAPI = '[ LWWRefGet    -- may be done via storage
-                  , LWWRefUpdate --
+type LWWRefAPI = '[ RpcLWWRefGet    -- may be done via storage
+                  , RpcLWWRefUpdate --
+                  , RpcLWWRefFetch  --
                   ]
 
-
 instance HasProtocol UNIX  (ServiceProto LWWRefAPI UNIX) where
   type instance ProtocolId (ServiceProto LWWRefAPI UNIX) = 16267229472009458342
   type instance Encoded UNIX = ByteString
   decode = either (const Nothing) Just . deserialiseOrFail
   encode = serialise
 
-type instance Input LWWRefGet   = LWWRefKey HBS2Basic
-type instance Output LWWRefGet  = Maybe (LWWRef L4Proto)
+type instance Input RpcLWWRefGet   = LWWRefKey HBS2Basic
+type instance Output RpcLWWRefGet  = Maybe (LWWRef L4Proto)
+
+type instance Input RpcLWWRefFetch   = LWWRefKey HBS2Basic
+type instance Output RpcLWWRefFetch  = ()
+
+type instance Input RpcLWWRefUpdate = SignedBox (LWWRef L4Proto) L4Proto
+type instance Output RpcLWWRefUpdate = ()
 
-type instance Input LWWRefUpdate = SignedBox (LWWRef L4Proto) L4Proto
-type instance Output LWWRefUpdate = ()