From b4772f83ad66061c165995674e3e31e462ac9424 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sat, 20 Jul 2024 10:21:22 +0300 Subject: [PATCH] wip --- hbs2-cli/app/Main.hs | 121 ---------------------- hbs2-cli/hbs2-cli.cabal | 1 + hbs2-cli/lib/HBS2/CLI/Prelude.hs | 2 + hbs2-cli/lib/HBS2/CLI/Run/Internal.hs | 16 +++ hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs | 138 ++++++++++++++++++++++++++ 5 files changed, 157 insertions(+), 121 deletions(-) create mode 100644 hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs diff --git a/hbs2-cli/app/Main.hs b/hbs2-cli/app/Main.hs index 2e8c9351..f665fc0b 100644 --- a/hbs2-cli/app/Main.hs +++ b/hbs2-cli/app/Main.hs @@ -100,40 +100,6 @@ mkRefLogUpdateFrom mbs reflog = do pure $ mkForm "cbor:base58" [ mkStr s ] -metaFromSyntax :: [Syntax c] -> HashMap Text Text -metaFromSyntax syn = - HM.fromList [ (t k, t v) | (ListVal [ k, v ]) <- syn ] - where - t x = Text.pack (show $ pretty x) - -createTreeWithMetadata :: (MonadUnliftIO m) - => HashMap Text Text - -> LBS.ByteString - -> m HashRef -createTreeWithMetadata meta lbs = do - debug "create fucking metadata" - -- TODO: set-hbs2-peer - so <- detectRPC `orDie` "hbs2-peer not found" - - let mt = vcat [ pretty k <> ":" <+> pretty v | (k,v) <- HM.toList meta ] - & show & Text.pack - - withRPC2 @StorageAPI @UNIX so $ \caller -> do - let sto = AnyStorage (StorageClient caller) - - t0 <- writeAsMerkle sto lbs - >>= getBlock sto - >>= orThrowUser "can't read merkle tree just written" - <&> deserialiseOrFail @(MTree [HashRef]) - >>= orThrowUser "merkle tree corrupted/invalid" - - -- FIXME: support-encryption - let mann = MTreeAnn (ShortMetadata mt) NullEncryption t0 - - putBlock sto (serialise mann) - >>= orThrowUser "can't write tree" - <&> HashRef - helpList :: MonadUnliftIO m => Maybe String -> RunM c m () helpList p = do @@ -148,7 +114,6 @@ helpList p = do display_ $ vcat (fmap pretty ks) - main :: IO () main = do @@ -238,92 +203,6 @@ main = do _ -> throwIO (BadFormException @C nil) - entry $ bindMatch "str:read-stdin" $ \case - [] -> liftIO getContents <&> mkStr @C - - _ -> throwIO (BadFormException @C nil) - - entry $ bindMatch "str:read-file" $ \case - [StringLike fn] -> liftIO (readFile fn) <&> mkStr @C - - _ -> throwIO (BadFormException @C nil) - - entry $ bindMatch "str:save" $ nil_ \case - [StringLike fn, StringLike what] -> - liftIO (writeFile fn what) - - _ -> throwIO (BadFormException @C nil) - - - entry $ bindMatch "hbs2:tree:metadata:get" $ \case - [ SymbolVal how, StringLike hash ] -> do - - -- FIXME: put-to-the-state - so <- detectRPC `orDie` "hbs2-peer not found" - - r <- withRPC2 @StorageAPI @UNIX so $ \caller -> do - let sto = AnyStorage (StorageClient caller) - - runMaybeT do - - headBlock <- getBlock sto (fromString hash) - >>= toMPlus - <&> deserialiseOrFail @(MTreeAnn [HashRef]) - >>= toMPlus - - case headBlock of - MTreeAnn { _mtaMeta = ShortMetadata s } -> do - pure $ mkStr @C s - - MTreeAnn { _mtaMeta = AnnHashRef h } -> do - getBlock sto h - >>= toMPlus - <&> LBS.toStrict - <&> TE.decodeUtf8 - <&> mkStr @C - - _ -> mzero - - - case (how, r) of - ("parsed", Just (LitStrVal r0)) -> do - - - let xs = parseTop r0 - & fromRight mempty - - pure $ mkForm @C "dict" xs - - _ -> pure $ fromMaybe nil r - - _ -> throwIO (BadFormException @C nil) - - entry $ bindMatch "hbs2:tree:metadata:create" $ \syn -> do - - case syn of - - (LitStrVal s : meta) -> do - let lbs = fromString (Text.unpack s) :: LBS.ByteString - h <- createTreeWithMetadata (metaFromSyntax meta) lbs - pure $ mkStr (show $ pretty h) - - (ListVal [SymbolVal "from-file", StringLike fn ] : meta) -> do - lbs <- liftIO $ LBS.readFile fn - h <- createTreeWithMetadata (metaFromSyntax meta) lbs - pure $ mkStr (show $ pretty h) - - (ListVal [SymbolVal "from-stdin"] : meta) -> do - lbs <- liftIO $ LBS.getContents - h <- createTreeWithMetadata (metaFromSyntax meta) lbs - pure $ mkStr (show $ pretty h) - - _ -> throwIO (BadFormException @C nil) - - entry $ bindMatch "cbor:base58" $ \case - [ LitStrVal x ] -> do - pure $ mkForm "cbor:base58" [mkStr x] - - _ -> throwIO (BadFormException @C nil) case cli of diff --git a/hbs2-cli/hbs2-cli.cabal b/hbs2-cli/hbs2-cli.cabal index 60c8e0f9..fc412109 100644 --- a/hbs2-cli/hbs2-cli.cabal +++ b/hbs2-cli/hbs2-cli.cabal @@ -104,6 +104,7 @@ library HBS2.CLI.Run HBS2.CLI.Run.Internal HBS2.CLI.Run.KeyMan + HBS2.CLI.Run.MetaData HBS2.CLI.Run.Help build-depends: base diff --git a/hbs2-cli/lib/HBS2/CLI/Prelude.hs b/hbs2-cli/lib/HBS2/CLI/Prelude.hs index cfb73f73..5d24c687 100644 --- a/hbs2-cli/lib/HBS2/CLI/Prelude.hs +++ b/hbs2-cli/lib/HBS2/CLI/Prelude.hs @@ -1,5 +1,6 @@ module HBS2.CLI.Prelude ( module HBS2.Prelude.Plated + , module HBS2.OrDie , module UnliftIO , module Data.Config.Suckless , module Data.HashMap.Strict @@ -8,6 +9,7 @@ module HBS2.CLI.Prelude ) where import HBS2.Prelude.Plated +import HBS2.OrDie import Data.HashMap.Strict import Data.Config.Suckless diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs index 0d667837..a9e974f6 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs @@ -329,5 +329,21 @@ internalEntries = do [ sy ] -> display sy >> liftIO (putStrLn "") ss -> mapM_ display ss >> liftIO (putStrLn "") + entry $ bindMatch "str:read-stdin" $ \case + [] -> liftIO getContents <&> mkStr @C + + _ -> throwIO (BadFormException @C nil) + + entry $ bindMatch "str:read-file" $ \case + [StringLike fn] -> liftIO (readFile fn) <&> mkStr @C + + _ -> throwIO (BadFormException @C nil) + + entry $ bindMatch "str:save" $ nil_ \case + [StringLike fn, StringLike what] -> + liftIO (writeFile fn what) + + _ -> throwIO (BadFormException @C nil) + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs new file mode 100644 index 00000000..1a835f28 --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs @@ -0,0 +1,138 @@ +module HBS2.CLI.Run.MetaData where + +import HBS2.CLI.Prelude +import HBS2.CLI.Run.Internal + +import HBS2.Data.Types.Refs +import HBS2.Merkle +import HBS2.System.Logger.Simple.ANSI as All + +import HBS2.Storage +import HBS2.Storage.Operations.ByteString +import HBS2.Peer.CLI.Detect +import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.API.Storage +import HBS2.Peer.RPC.Client.StorageClient + +import HBS2.Net.Auth.Schema() + +import Codec.Serialise +import Control.Monad.Trans.Maybe +import Data.ByteString.Lazy qualified as LBS +import Data.Either +import Data.HashMap.Strict qualified as HM +import Data.Maybe +import Data.Text.Encoding qualified as TE +import Data.Text qualified as Text + +metaFromSyntax :: [Syntax c] -> HashMap Text Text +metaFromSyntax syn = + HM.fromList [ (t k, t v) | (ListVal [ k, v ]) <- syn ] + where + t x = Text.pack (show $ pretty x) + +createTreeWithMetadata :: (MonadUnliftIO m) + => HashMap Text Text + -> LBS.ByteString + -> m HashRef +createTreeWithMetadata meta lbs = do + debug "create fucking metadata" + -- TODO: set-hbs2-peer + so <- detectRPC `orDie` "hbs2-peer not found" + + let mt = vcat [ pretty k <> ":" <+> pretty v | (k,v) <- HM.toList meta ] + & show & Text.pack + + withRPC2 @StorageAPI @UNIX so $ \caller -> do + let sto = AnyStorage (StorageClient caller) + + t0 <- writeAsMerkle sto lbs + >>= getBlock sto + >>= orThrowUser "can't read merkle tree just written" + <&> deserialiseOrFail @(MTree [HashRef]) + >>= orThrowUser "merkle tree corrupted/invalid" + + -- FIXME: support-encryption + let mann = MTreeAnn (ShortMetadata mt) NullEncryption t0 + + putBlock sto (serialise mann) + >>= orThrowUser "can't write tree" + <&> HashRef + + + + +metaDataEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m () +metaDataEntries = do + + entry $ bindMatch "hbs2:tree:metadata:get" $ \case + [ SymbolVal how, StringLike hash ] -> do + + -- FIXME: put-to-the-state + so <- detectRPC `orDie` "hbs2-peer not found" + + r <- withRPC2 @StorageAPI @UNIX so $ \caller -> do + let sto = AnyStorage (StorageClient caller) + + runMaybeT do + + headBlock <- getBlock sto (fromString hash) + >>= toMPlus + <&> deserialiseOrFail @(MTreeAnn [HashRef]) + >>= toMPlus + + case headBlock of + MTreeAnn { _mtaMeta = ShortMetadata s } -> do + pure $ mkStr s + + MTreeAnn { _mtaMeta = AnnHashRef h } -> do + getBlock sto h + >>= toMPlus + <&> LBS.toStrict + <&> TE.decodeUtf8 + <&> mkStr + + _ -> mzero + + + case (how, r) of + ("parsed", Just (LitStrVal r0)) -> do + + + let xs = parseTop r0 + & fromRight mempty + + pure $ mkForm "dict" xs + + _ -> pure $ fromMaybe nil r + + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "hbs2:tree:metadata:create" $ \syn -> do + + case syn of + + (LitStrVal s : meta) -> do + let lbs = fromString (Text.unpack s) :: LBS.ByteString + h <- createTreeWithMetadata (metaFromSyntax meta) lbs + pure $ mkStr (show $ pretty h) + + (ListVal [SymbolVal "from-file", StringLike fn ] : meta) -> do + lbs <- liftIO $ LBS.readFile fn + h <- createTreeWithMetadata (metaFromSyntax meta) lbs + pure $ mkStr (show $ pretty h) + + (ListVal [SymbolVal "from-stdin"] : meta) -> do + lbs <- liftIO $ LBS.getContents + h <- createTreeWithMetadata (metaFromSyntax meta) lbs + pure $ mkStr (show $ pretty h) + + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "cbor:base58" $ \case + [ LitStrVal x ] -> do + pure $ mkForm "cbor:base58" [mkStr x] + + _ -> throwIO (BadFormException @c nil) + +