mirror of https://github.com/voidlizard/hbs2
308 lines
9.1 KiB
Haskell
308 lines
9.1 KiB
Haskell
{-# Language MultiWayIf #-}
|
|
|
|
module HBS2.CLI.Run.MetaData
|
|
( metaDataEntries
|
|
, createTreeWithMetadata
|
|
, getTreeContents
|
|
, getGroupKeyHash
|
|
) where
|
|
|
|
import HBS2.CLI.Prelude
|
|
import HBS2.CLI.Run.Internal
|
|
import HBS2.CLI.Run.Internal.GroupKey as G
|
|
import HBS2.CLI.Run.Internal.Merkle
|
|
|
|
import HBS2.Data.Types.Refs
|
|
import HBS2.Merkle
|
|
import HBS2.System.Dir
|
|
import HBS2.Storage
|
|
import HBS2.Storage.Operations.ByteString
|
|
|
|
import HBS2.Net.Auth.Schema()
|
|
|
|
import HBS2.Peer.RPC.API.Storage
|
|
import HBS2.Peer.RPC.Client
|
|
import HBS2.Peer.RPC.Client.Unix
|
|
|
|
import Codec.Serialise
|
|
import Control.Monad.Trans.Maybe
|
|
import Control.Monad.Trans.Cont
|
|
import Data.ByteString.Lazy qualified as LBS
|
|
import Data.ByteString.Lazy (ByteString)
|
|
import Data.ByteString.Char8 qualified as BS8
|
|
import Data.Either
|
|
import Data.Set qualified as Set
|
|
import Data.HashMap.Strict qualified as HM
|
|
import Data.Maybe
|
|
import Data.Text.Encoding qualified as TE
|
|
import Data.Text qualified as Text
|
|
import Data.Text.IO qualified as TIO
|
|
|
|
import Magic.Data
|
|
import Magic.Init (magicLoadDefault,magicOpen)
|
|
import Magic.Operations (magicFile)
|
|
|
|
{- HLINT ignore "Functor law" -}
|
|
|
|
data CreateMetaDataOpt =
|
|
Auto
|
|
| Stdin
|
|
| Encrypted String
|
|
| MetaDataEntry Id String
|
|
| MetaDataFile FilePath
|
|
deriving stock (Eq,Ord,Show,Data,Generic)
|
|
|
|
txt :: Pretty a => a -> Text
|
|
txt a = Text.pack (show $ pretty a)
|
|
|
|
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)
|
|
|
|
|
|
type ForMetadata c m = ( IsContext c
|
|
, MonadUnliftIO m
|
|
, Exception (BadFormException c)
|
|
, HasStorage m
|
|
, HasClientAPI StorageAPI UNIX m
|
|
)
|
|
|
|
metaDataEntries :: forall c m . ( ForMetadata c m
|
|
) => MakeDictM c m ()
|
|
metaDataEntries = do
|
|
|
|
brief "update group key for tree"
|
|
$ args [arg "string" "tree", arg "list" "update-ops"]
|
|
$ desc ( "update-ops is a list of pairs, like" <> line
|
|
<> indent 4 ( parens ("list"
|
|
<+> indent 2 (vcat [ parens "remove . PUBLIC-KEY-ID"
|
|
, parens "add . PUBLIC-KEY-ID"
|
|
]))))
|
|
$ returns "string" "new-tree-hash"
|
|
$ examples [qc|
|
|
|
|
(define gk (hbs2:groupkey:load 6XJGpJszP6f68fmhF17AtJ9PTgE7BKk8RMBHWQ2rXu6N))
|
|
|
|
(hbs2:groupkey:update gk
|
|
(list (remove . CcRDzezX1XQdPxRMuMKzJkfHFB4yG7vGJeTYvScKkbP8)
|
|
(add . EiwWxY3xwTfnLKJdzzxNMZgA2ZvYAZd9e8B8pFeCtnrn)))
|
|
|]
|
|
$ entry $ bindMatch "hbs2:tree:metadata:update-gk" $ \case
|
|
[StringLike tree, ListVal ins] -> do
|
|
|
|
ha <- orThrowUser "invalid hash" (fromStringMay tree)
|
|
|
|
-- 1. load-group-key
|
|
(gkh', headBlk) <- getGroupKeyHash ha
|
|
|
|
gkh <- orThrowUser "not encrypted" gkh'
|
|
|
|
gk <- loadGroupKey gkh
|
|
>>= orThrowUser "can't load gk"
|
|
|
|
gk1 <- modifyGroupKey gk ins
|
|
|
|
sto <- getStorage
|
|
gk1h <- writeAsMerkle sto (serialise gk1)
|
|
|
|
case headBlk of
|
|
w@(MTreeAnn { _mtaCrypt = EncryptGroupNaClSymm _ nonce }) -> do
|
|
let w1 = w { _mtaCrypt = EncryptGroupNaClSymm gk1h nonce }
|
|
|
|
h <- putBlock sto (serialise w1)
|
|
>>= orThrowUser "can't put block"
|
|
|
|
pure $ mkStr (show $ pretty h)
|
|
|
|
_ -> pure nil
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|
|
brief "get group key from encrypted tree"
|
|
$ args [arg "string" "tree-hash"]
|
|
$ returns "group-key-hash" "string"
|
|
$ examples [qc|
|
|
|
|
(hbs2:tree:metadata:get-gk 7J2BZYskBjmDsWZHvVoGGorZDrFYkbbQweRauaYGSTNd)
|
|
5fshZRucawt47YJLuD1rVXRez2dcvCbz17m69YyduTEm
|
|
|
|
|]
|
|
$ entry $ bindMatch "hbs2:tree:metadata:get-gk" $ \case
|
|
[ StringLike hash ] -> flip runContT pure do
|
|
|
|
(gk,_) <- lift $ getGroupKeyHash (fromString hash)
|
|
|
|
case gk of
|
|
Just h -> pure $ mkStr (show $ pretty h)
|
|
_ -> pure nil
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|
|
brief "get metadata from tree"
|
|
$ args [arg "symbol?" "method", arg "string" "tree-hash"]
|
|
$ returns "group-key-hash" "string"
|
|
$ desc ( opt "symbol?" ":parsed" <+> "return metadata as dict" <> line
|
|
<> "if other value or absense then return metadata as string"
|
|
)
|
|
$ examples [qc|
|
|
|
|
(hbs2:tree:metadata:get 7J2BZYskBjmDsWZHvVoGGorZDrFYkbbQweRauaYGSTNd)
|
|
((mime-type: "text/plain; charset=us-ascii") (file-name: "qqq.txt"))
|
|
|
|
(hbs2:tree:metadata:get :raw 7J2BZYskBjmDsWZHvVoGGorZDrFYkbbQweRauaYGSTNd
|
|
mime-type: "text/plain; charset=us-ascii"
|
|
file-name: "qqq.txt"
|
|
|]
|
|
$ entry $ bindMatch "hbs2:tree:metadata:get"
|
|
$ \case
|
|
[ StringLike hash ] -> do
|
|
|
|
r <- flip runContT pure do
|
|
|
|
sto <- getStorage
|
|
|
|
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, _mtaCrypt = NullEncryption } -> do
|
|
getBlock sto h
|
|
>>= toMPlus
|
|
<&> LBS.toStrict
|
|
<&> TE.decodeUtf8
|
|
<&> mkStr
|
|
|
|
MTreeAnn { _mtaMeta = AnnHashRef h } -> do
|
|
getBlock sto h
|
|
>>= toMPlus
|
|
<&> deserialiseOrFail @(SmallEncryptedBlock AnnMetaData)
|
|
>>= toMPlus
|
|
>>= lift . lift . G.decryptBlock sto
|
|
<&> \case
|
|
ShortMetadata s -> mkStr s
|
|
_ -> nil
|
|
|
|
_ -> mzero
|
|
|
|
maybe1 r (pure nil) $ \case
|
|
TextLike r0 -> do
|
|
|
|
let xs = parseTop r0
|
|
& either mempty (fmap fixContext)
|
|
|
|
pure $ mkList xs
|
|
|
|
_ -> pure $ fromMaybe nil r
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|
|
|
|
let metadataCreateMan = brief "creates a tree with metadata"
|
|
let kw = arg "kw" "opts"
|
|
|
|
metadataCreateMan $ args [kw, arg "string" "filename"] $
|
|
entry $ bindMatch "hbs2:tree:metadata:file" $ \case
|
|
[ syn@(ListVal{}), StringLike fn ] -> do
|
|
meta0 <- liftIO do
|
|
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)
|
|
]
|
|
doCreateMetadataTree meta0 syn (liftIO $ LBS.readFile fn)
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|
|
metadataCreateMan $ args [kw] $
|
|
entry $ bindMatch "hbs2:tree:metadata:stdin" $ \case
|
|
[syn@(ListVal{})] -> do
|
|
_reader <- hIsTerminalDevice stdin >>= \case
|
|
_ -> pure (liftIO LBS.getContents)
|
|
|
|
doCreateMetadataTree mempty syn _reader
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|
|
metadataCreateMan $ args [kw, arg "string" "input"] $
|
|
entry $ bindMatch "hbs2:tree:metadata:string" $ \case
|
|
[ syn@(ListVal{}), TextLike content ] -> do
|
|
-- liftIO $ TIO.putStr content
|
|
doCreateMetadataTree mempty syn (pure $ LBS.fromStrict $ TE.encodeUtf8 content)
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|
|
entry $ bindMatch "cbor:base58" $ \case
|
|
[ LitStrVal x ] -> do
|
|
pure $ mkForm "cbor:base58" [mkStr x]
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|
|
|
|
groupKeyFromSyntax :: Syntax c -> Either (Syntax c) (Maybe HashRef)
|
|
groupKeyFromSyntax = \case
|
|
ListVal es -> do
|
|
let mbGk = headMay [ z | z@(ListVal [ TextLike "gk", v ]) <- es ]
|
|
|
|
case mbGk of
|
|
Just (ListVal [ TextLike "gk", HashLike v]) -> Right (Just v)
|
|
Just w@(ListVal [ TextLike "gk", v]) -> Left w
|
|
_ -> Right Nothing
|
|
|
|
_ -> Right Nothing
|
|
|
|
loadGroupKeyFromSyntax :: ( ForMetadata c m )
|
|
=> Syntax c
|
|
-> RunM c m (Maybe (GroupKey 'Symm 'HBS2Basic))
|
|
|
|
loadGroupKeyFromSyntax syn = runMaybeT do
|
|
hash <- case groupKeyFromSyntax syn of
|
|
Right w -> toMPlus w
|
|
Left e -> throwIO (BadFormException e)
|
|
|
|
toMPlus =<< lift (loadGroupKey hash)
|
|
|
|
metadataFromSyntax :: Syntax c -> HashMap Text Text
|
|
metadataFromSyntax = \case
|
|
ListVal es -> HM.fromList [ (k,v) | ListVal [ TextLike k, TextLike v] <- es, k /= "gk" ]
|
|
_ -> mempty
|
|
|
|
|
|
doCreateMetadataTree :: forall c m . ForMetadata c m
|
|
=> HashMap Text Text
|
|
-> Syntax c
|
|
-> m ByteString
|
|
-> RunM c m (Syntax c)
|
|
doCreateMetadataTree meta0 syn getLbs = do
|
|
let meta = metadataFromSyntax syn
|
|
let gkh = groupKeyFromSyntax syn
|
|
|
|
gk <- loadGroupKeyFromSyntax syn
|
|
|
|
-- notice $ "GK" <+> pretty (isRight gkh) <+> pretty gk
|
|
|
|
case (gkh, gk) of
|
|
(Right (Just _), Nothing) -> throwIO (GroupKeyNotFound 1)
|
|
_ -> none
|
|
|
|
sto <- getStorage
|
|
|
|
lbs <- lift getLbs
|
|
|
|
href <- lift (createTreeWithMetadata sto gk (meta0 <> meta) lbs)
|
|
>>= orThrow StorageError
|
|
|
|
pure $ mkStr (show $ pretty href)
|
|
|
|
|
|
|