From 7f13629498031d58618f6a273a9847bca22e2ab7 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Mon, 29 Jul 2024 10:57:56 +0300 Subject: [PATCH] wip --- hbs2-cli/app/Main.hs | 6 +- hbs2-cli/hbs2-cli.cabal | 1 + hbs2-cli/lib/HBS2/CLI/Run/Internal.hs | 19 +++++ hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs | 109 ++++++++++++++++++++++++++ hbs2-cli/lib/HBS2/CLI/Run/Peer.hs | 43 +++++++++- 5 files changed, 174 insertions(+), 4 deletions(-) create mode 100644 hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs diff --git a/hbs2-cli/app/Main.hs b/hbs2-cli/app/Main.hs index 9e94b679..ba994d6d 100644 --- a/hbs2-cli/app/Main.hs +++ b/hbs2-cli/app/Main.hs @@ -11,6 +11,7 @@ import HBS2.CLI.Run.Sigil import HBS2.CLI.Run.MetaData import HBS2.CLI.Run.Peer import HBS2.CLI.Run.RefLog +import HBS2.CLI.Run.LWWRef import HBS2.Peer.RPC.Client.Unix @@ -78,6 +79,7 @@ main = do metaDataEntries peerEntries reflogEntries + lwwRefEntries entry $ bindMatch "help" $ nil_ $ \syn -> do @@ -103,11 +105,11 @@ main = do [ListVal [SymbolVal "stdin"]] -> do what <- getContents >>= either (error.show) pure . parseTop - void $ run dict what + run dict what >>= eatNil display [] -> do void $ run dict [mkForm "help" []] _ -> do - void $ run dict cli + run dict cli >>= eatNil display diff --git a/hbs2-cli/hbs2-cli.cabal b/hbs2-cli/hbs2-cli.cabal index 291ad4a3..e7b771f2 100644 --- a/hbs2-cli/hbs2-cli.cabal +++ b/hbs2-cli/hbs2-cli.cabal @@ -112,6 +112,7 @@ library HBS2.CLI.Run.MetaData HBS2.CLI.Run.Peer HBS2.CLI.Run.RefLog + HBS2.CLI.Run.LWWRef HBS2.CLI.Run.Sigil HBS2.CLI.Run.Help diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs index 888f3ed6..d41f4519 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs @@ -38,6 +38,8 @@ pattern StringLikeList e <- (stringLikeList -> e) pattern BlobLike :: forall {c} . ByteString -> Syntax c pattern BlobLike s <- (blobLike -> Just s) +pattern Nil :: forall {c} . Syntax c +pattern Nil <- ListVal [] class Display a where display :: MonadIO m => a -> m () @@ -104,6 +106,11 @@ isFalse = \case ListVal [] -> True _ -> False +eatNil :: Monad m => (Syntax c -> m a) -> Syntax c -> m () +eatNil f = \case + Nil -> pure () + x -> void $ f x + class IsContext c => MkInt c s where mkInt :: s -> Syntax c @@ -462,6 +469,18 @@ internalEntries = do let wat = [ mkList @c [mkSym i, e] | (i,e) <- optlist syn ] pure $ mkForm "dict" wat + entry $ bindMatch "iterate" $ nil_ $ \syn -> do + case syn of + [ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do + mapM_ (apply @c fn . List.singleton) rs + + [Lambda decl body, ListVal args] -> do + mapM_ (applyLambda decl body . List.singleton) args + + _ -> do + throwIO (BadFormException @C nil) + + entry $ bindMatch "map" $ \syn -> do case syn of [ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do diff --git a/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs b/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs new file mode 100644 index 00000000..727254a0 --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs @@ -0,0 +1,109 @@ +module HBS2.CLI.Run.LWWRef where + +import HBS2.CLI.Prelude +import HBS2.CLI.Run.Internal +import HBS2.CLI.Run.Internal.KeyMan + +import HBS2.Data.Types.Refs +import HBS2.Storage +import HBS2.Peer.CLI.Detect +import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.API.Peer +import HBS2.Peer.RPC.API.RefLog +import HBS2.Peer.RPC.API.LWWRef + +import HBS2.Peer.Proto hiding (request) +import HBS2.Base58 +import HBS2.Net.Auth.Credentials +import HBS2.Net.Auth.Schema() + +import HBS2.KeyMan.Keys.Direct +import HBS2.KeyMan.App.Types + +import Codec.Serialise +import Data.Coerce +import Data.Either +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BS8 +import Data.ByteString (ByteString) +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.ByteString.Lazy qualified as LBS +import Data.Text.Encoding qualified as TE +import Data.Text qualified as Text +import Control.Monad.Trans.Cont + + +lwwRefEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m () +lwwRefEntries = do + + entry $ bindMatch "hbs2:lwwref:create" $ \case + [] -> do + reflog <- keymanNewCredentials (Just "lwwref") 0 + + flip runContT pure do + so <- detectRPC `orDie` "rpc not found" + api <- ContT $ withRPC2 @PeerAPI @UNIX so + void $ callService @RpcPollAdd api (reflog, "lwwref", 31) + pure $ mkStr (show $ pretty (AsBase58 reflog)) + + _ -> throwIO (BadFormException @C nil) + + + -- entry $ bindMatch "hbs2:reflog:tx:annhashref:create" $ \case + -- [StringLike puk, StringLike hash] -> do + -- flip runContT pure do + -- reflog <- orThrowUser "bad reflog key" (fromStringMay puk) + -- sto <- ContT withPeerStorage + -- hashref <- orThrowUser "bad hash" (fromStringMay @HashRef hash) + -- void $ hasBlock sto (fromHashRef hashref) `orDie` "no block" + -- let sref = AnnotatedHashRef Nothing hashref + -- rlu <- lift $ mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise + -- pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)] + + -- _ -> throwIO (BadFormException @C nil) + + + -- entry $ bindMatch "hbs2:reflog:tx:post" $ nil_ \case + -- [BlobLike blob] -> do + -- so <- detectRPC `orDie` "no rpc found" + -- withRPC2 @RefLogAPI so $ \caller -> do + -- wtf <- deserialiseOrFail @(RefLogUpdate L4Proto) (LBS.fromStrict blob) + -- & orThrowUser "invalid tx" + -- void $ callService @RpcRefLogPost caller wtf + + -- _ -> throwIO (BadFormException @C nil) + + -- entry $ bindMatch "hbs2:reflog:tx:seqref:create" $ \case + -- [StringLike puk, LitIntVal sn, StringLike hash] -> do + -- flip runContT pure do + -- reflog <- orThrowUser "bad reflog key" (fromStringMay puk) + -- sto <- ContT withPeerStorage + -- hashref <- orThrowUser "bad hash" (fromStringMay @HashRef hash) + -- void $ hasBlock sto (fromHashRef hashref) `orDie` "no block" + -- let sref = SequentialRef sn (AnnotatedHashRef Nothing hashref) + -- rlu <- lift $ mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise + -- pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)] + + -- _ -> throwIO (BadFormException @C nil) + + -- entry $ bindMatch "hbs2:reflog:tx:create-raw" $ \case + -- [SymbolVal "stdin", StringLike rlo] -> do + -- reflog <- orThrowUser "bad reflog" (fromStringMay rlo) + + -- rlu <- mkRefLogUpdateFrom reflog ( liftIO BS.getContents ) + -- <&> serialise + + -- pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)] + + -- [LitStrVal s, StringLike rlo] -> do + -- reflog <- orThrowUser "bad reflog" (fromStringMay rlo) + + -- rlu <- mkRefLogUpdateFrom reflog ( pure (BS8.pack (Text.unpack s)) ) + -- <&> serialise + + -- pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)] + + -- _ -> throwIO (BadFormException @C nil) + + + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs b/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs index 0630b1f0..b0938a67 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs @@ -11,6 +11,7 @@ import HBS2.Peer.CLI.Detect import HBS2.Peer.RPC.Client.Unix import HBS2.Peer.RPC.API.Peer import HBS2.Peer.RPC.API.RefLog +import HBS2.Peer.RPC.API.LWWRef import HBS2.Net.Auth.Schema() import Data.List qualified as L @@ -22,7 +23,6 @@ import Lens.Micro.Platform {- HLINT ignore "Functor law" -} - putTextLit :: forall c m . (IsContext c, MonadUnliftIO m) => AnyStorage -> Text @@ -112,7 +112,6 @@ peerEntries = do _ -> throwIO (BadFormException @C nil) - entry $ bindMatch "hbs2:peer:reflog:fetch" $ \case [StringLike puk] -> do flip runContT pure do @@ -134,3 +133,43 @@ peerEntries = do pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r _ -> throwIO (BadFormException @C nil) + + + entry $ bindMatch "hbs2:peer:lwwref:list" $ \case + [] -> do + flip runContT pure do + so <- detectRPC `orDie` "rpc not found" + api <- ContT $ withRPC2 @PeerAPI @UNIX so + r <- callService @RpcPollList2 api (Just "lwwref", Nothing) + >>= orThrowUser "can't get lwwref list" + pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r + + _ -> throwIO (BadFormException @C nil) + + + entry $ bindMatch "hbs2:peer:lwwref:fetch" $ \case + [StringLike puk] -> do + flip runContT pure do + lww <- orThrowUser "bad reflog key" (fromStringMay puk) + so <- detectRPC `orDie` "rpc not found" + api <- ContT $ withRPC2 @LWWRefAPI @UNIX so + void $ callService @RpcLWWRefFetch api lww + pure $ mkStr "okay" + + _ -> throwIO (BadFormException @C nil) + + + entry $ bindMatch "hbs2:peer:lwwref:get" $ \case + [StringLike puk] -> do + + flip runContT pure do + ref <- orThrowUser "bad reflog key" (fromStringMay puk) + so <- detectRPC `orDie` "rpc not found" + api <- ContT $ withRPC2 @LWWRefAPI @UNIX so + what <- callService @RpcLWWRefGet api ref + >>= orThrowUser "can't get reflog" + pure $ mkStr (show $ pretty what) + + _ -> throwIO (BadFormException @C nil) + +