diff --git a/hbs2-peer/app/CLI/LWWRef.hs b/hbs2-peer/app/CLI/LWWRef.hs index 9447dffe..541be78b 100644 --- a/hbs2-peer/app/CLI/LWWRef.hs +++ b/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 diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index dab29c27..646e86ad 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/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) ] diff --git a/hbs2-peer/app/RPC2.hs b/hbs2-peer/app/RPC2.hs index c56ea3f8..e9e10db9 100644 --- a/hbs2-peer/app/RPC2.hs +++ b/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 diff --git a/hbs2-peer/app/RPC2/LWWRef.hs b/hbs2-peer/app/RPC2/LWWRef.hs index 41a8b6dc..a524c381 100644 --- a/hbs2-peer/app/RPC2/LWWRef.hs +++ b/hbs2-peer/app/RPC2/LWWRef.hs @@ -1 +1,64 @@ -module RPC2.LWWRef where \ No newline at end of file +{-# 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 () + + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs b/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs index 2fedf73f..6e9c7530 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs +++ b/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 + ) + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef/Internal.hs b/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef/Internal.hs index 292c6456..7de39732 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef/Internal.hs +++ b/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 diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/LWWRef.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/LWWRef.hs index 267a9007..bf949eba 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/API/LWWRef.hs +++ b/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 = ()