From 1af1c060d07522a9855efeb420e5beed292831ac Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 1 Aug 2024 14:06:38 +0300 Subject: [PATCH] wip --- hbs2-cli/lib/HBS2/CLI/Run/Help.hs | 17 ++- hbs2-cli/lib/HBS2/CLI/Run/Internal.hs | 3 + hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs | 148 ++++++++++++++++++-------- 3 files changed, 121 insertions(+), 47 deletions(-) diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Help.hs b/hbs2-cli/lib/HBS2/CLI/Run/Help.hs index 119fe3d9..a0dc909a 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Help.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Help.hs @@ -9,18 +9,23 @@ import Data.Text qualified as Text {- HLINT ignore "Functor law" -} -helpList :: MonadUnliftIO m => Maybe String -> RunM c m () -helpList p = do +helpList :: MonadUnliftIO m => Bool -> Maybe String -> RunM c m () +helpList hasDoc p = do let match = maybe (const True) (Text.isPrefixOf . Text.pack) p d <- ask >>= readTVarIO let ks = [k | Id k <- List.sort (HM.keys d) , match k + , not hasDoc || docDefined (HM.lookup (Id k) d) ] display_ $ vcat (fmap pretty ks) + where + docDefined (Just (Bind (Just w) _)) = True + docDefined _ = False + helpEntries :: (MonadUnliftIO m, IsContext c) => MakeDictM c m () helpEntries = do @@ -29,8 +34,12 @@ helpEntries = do display_ $ "hbs2-cli tool" <> line case syn of + + [StringLike "--documented"] -> do + helpList True Nothing + (StringLike p : _) -> do - helpList (Just p) + helpList False (Just p) [ListVal (SymbolVal "builtin:lambda" : SymbolVal what : _ )] -> do man <- ask >>= readTVarIO @@ -39,5 +48,5 @@ helpEntries = do liftIO $ hPutDoc stdout (pretty man) - _ -> helpList Nothing + _ -> helpList False Nothing diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs index c614ec1a..e328efd8 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs @@ -439,6 +439,9 @@ arg = ManApplyArg args :: [ManApplyArg] -> MakeDictM c m () -> MakeDictM c m () args argList = censor (HM.map (addSynopsis (ManSynopsis (ManApply argList)))) +opt :: Doc a -> Doc a -> Doc a +opt n d = n <+> "-" <+> d + examples :: ManExamples -> MakeDictM c m () -> MakeDictM c m () examples (ManExamples s) = censor (HM.map setExamples ) where diff --git a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs index 4003fc6f..4910951f 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs @@ -152,67 +152,129 @@ metaDataEntries = do _ -> throwIO (BadFormException @c nil) - entry $ bindMatch "hbs2:tree:metadata:create" $ \syn -> do + brief "creates a merkle tree with metadata" + $ returns "string" "hash" + $ args [ arg "list-of-options" "..." ] + $ desc ( "options:" <> line + <> indent 4 ( + vcat [ opt ":stdin" "read data from stdin" + , opt ":auto" "create metadata from file using libmagic" + , opt "[kw [encrypted group-key-hash]]" "encrypt metadata with given group key" + , opt "dict" "custom metadata dictionary" + , opt "filename : string-like" "file name, ignored if stdin option set" + ]) + ) + $ examples [qc| +Create not encrypted merkle tree for string from stdin without metadata - case syn of +$ echo TEST | hbs2-cli hbs2:tree:metadata:create :stdin +7dGqTtoehsgn7bADcVTyp93tq2FfuQgtBuVvYL46jdyz - args -> do - opts' <- for args $ \case - SymbolVal "stdin" -> pure [Stdin] +;; empty metadata - SymbolVal "auto" -> pure [Auto] +hbs2-cli hbs2:tree:metadata:get :raw 7dGqTtoehsgn7bADcVTyp93tq2FfuQgtBuVvYL46jdyz - ListVal (SymbolVal "dict" : [ListVal [SymbolVal "encrypted", StringLike key]]) - -> do - pure [Encrypted key] +Create merkle tree with custom metadata - ListVal (SymbolVal "dict" : w) -> do - pure [MetaDataEntry x y | ListVal [SymbolVal x, StringLike y] <- w ] +$ echo TEST | hbs2-cli hbs2:tree:metadata:create :stdin [kw hello world] +2ASBLBPRUMrHoSkNYsRWwJQiiXuSGDZTaCXAdDTdeJY6 - StringLike rest -> do - pure [MetaDataFile rest] +$ hbs2-cli hbs2:tree:metadata:get :raw 2ASBLBPRUMrHoSkNYsRWwJQiiXuSGDZTaCXAdDTdeJY6 +hello: "world" - _ -> pure mempty +$ hbs2-cli hbs2:tree:metadata:create :auto ./lambda.svg +3fv5ym8NhY8zat37NaTvY9PDcwJqMLUD73ewHxtHysWg - let opts = mconcat opts' & Set.fromList - let inFile = headMay [ x | MetaDataFile x <- universeBi opts ] +$ hbs2-cli hbs2:tree:metadata:get :raw 3fv5ym8NhY8zat37NaTvY9PDcwJqMLUD73ewHxtHysWg +mime-type: "image/svg+xml; charset=us-ascii" +file-name: "lambda.svg" - lbs <- case (Set.member Stdin opts, inFile) of - (True, _) -> liftIO LBS.getContents - (False, Just fn) -> liftIO (LBS.readFile fn) - (_, Nothing) -> liftIO LBS.getContents +Create encrypted tree metadata with a new groupkey - meta0 <- if not (Set.member Auto opts) || isNothing inFile then - pure (mempty :: HashMap Text Text) - else liftIO do - let fn = fromJust inFile - magic <- magicOpen [MagicMimeType,MagicMime,MagicMimeEncoding] - magicLoadDefault magic - mime <- magicFile magic fn - pure $ HM.fromList [ ("file-name", Text.pack (takeFileName fn)) - , ("mime-type", Text.pack mime) - ] +$ hbs2-cli [define pks [list EiwWxY3xwTfnLKJdzzxNMZgA2ZvYAZd9e8B8pFeCtnrn]] \ + and [define gk [hbs2:groupkey:store [hbs2:groupkey:create pks]]] \ + and [hbs2:tree:metadata:create :auto [kw :encrypted gk] ./lambda.svg] - let meta1 = HM.fromList [ (txt n, txt e) | MetaDataEntry n e <- universeBi opts ] +BFLcbpNEqngsJ8gzx3ps4ETXfpUMGgjEETNEVgR18KG4 - let enc = headMay [ e | x@(Encrypted e) <- universeBi opts ] +Check group key - gk <- runMaybeT do - s <- toMPlus enc - g <- lift $ loadGroupKey (fromString s) - toMPlus g +$ hbs2-cli hbs2:tree:metadata:get-gk BFLcbpNEqngsJ8gzx3ps4ETXfpUMGgjEETNEVgR18KG4y - when (isJust enc && isNothing gk) do - error $ show $ "Can't load group key" <+> pretty enc +GixS4wssCD4x7LzvHve2JhFCghW1Hwia2tiGTfTTef1u - flip runContT pure do +Check metadata - sto <- ContT withPeerStorage +$ hbs2-cli hbs2:tree:metadata:get :raw BFLcbpNEqngsJ8gzx3ps4ETXfpUMGgjEETNEVgR18KG4y - href <- lift (createTreeWithMetadata sto gk (meta0 <> meta1) lbs) - `orDie` "encryption error" +mime-type: "image/svg+xml; charset=us-ascii" +file-name: "lambda.svg" - pure $ mkStr (show $ pretty href) +List group key + +$ hbs2-cli hbs2:groupkey:list-public-keys [hbs2:groupkey:load GixS4wssCD4x7LzvHve2JhFCghW1Hwia2tiGTfTTef1u] +("EiwWxY3xwTfnLKJdzzxNMZgA2ZvYAZd9e8B8pFeCtnrn") + |] + $ entry $ bindMatch "hbs2:tree:metadata:create" $ \syn -> do + case syn of + + args -> do + opts' <- for args $ \case + SymbolVal "stdin" -> pure [Stdin] + + SymbolVal "auto" -> pure [Auto] + + ListVal (SymbolVal "dict" : [ListVal [SymbolVal "encrypted", StringLike key]]) + -> do + pure [Encrypted key] + + ListVal (SymbolVal "dict" : w) -> do + pure [MetaDataEntry x y | ListVal [SymbolVal x, StringLike y] <- w ] + + StringLike rest -> do + pure [MetaDataFile rest] + + _ -> pure mempty + + let opts = mconcat opts' & Set.fromList + let inFile = headMay [ x | MetaDataFile x <- universeBi opts ] + + lbs <- case (Set.member Stdin opts, inFile) of + (True, _) -> liftIO LBS.getContents + (False, Just fn) -> liftIO (LBS.readFile fn) + (_, Nothing) -> liftIO LBS.getContents + + meta0 <- if not (Set.member Auto opts) || isNothing inFile then + pure (mempty :: HashMap Text Text) + else liftIO do + let fn = fromJust inFile + magic <- magicOpen [MagicMimeType,MagicMime,MagicMimeEncoding] + magicLoadDefault magic + mime <- magicFile magic fn + pure $ HM.fromList [ ("file-name", Text.pack (takeFileName fn)) + , ("mime-type", Text.pack mime) + ] + + let meta1 = HM.fromList [ (txt n, txt e) | MetaDataEntry n e <- universeBi opts ] + + let enc = headMay [ e | x@(Encrypted e) <- universeBi opts ] + + gk <- runMaybeT do + s <- toMPlus enc + g <- lift $ loadGroupKey (fromString s) + toMPlus g + + when (isJust enc && isNothing gk) do + error $ show $ "Can't load group key" <+> pretty enc + + flip runContT pure do + + sto <- ContT withPeerStorage + + href <- lift (createTreeWithMetadata sto gk (meta0 <> meta1) lbs) + `orDie` "encryption error" + + pure $ mkStr (show $ pretty href) entry $ bindMatch "cbor:base58" $ \case [ LitStrVal x ] -> do