diff --git a/hbs2-cli/hbs2-cli.cabal b/hbs2-cli/hbs2-cli.cabal index fe7f7a18..6d29d0c7 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.Internal.GroupKey + HBS2.CLI.Run.Internal.Merkle HBS2.CLI.Run.GroupKey HBS2.CLI.Run.KeyMan HBS2.CLI.Run.Keyring diff --git a/hbs2-cli/lib/HBS2/CLI/Prelude.hs b/hbs2-cli/lib/HBS2/CLI/Prelude.hs index 5d24c687..6c879130 100644 --- a/hbs2-cli/lib/HBS2/CLI/Prelude.hs +++ b/hbs2-cli/lib/HBS2/CLI/Prelude.hs @@ -5,11 +5,13 @@ module HBS2.CLI.Prelude , module Data.Config.Suckless , module Data.HashMap.Strict , module Control.Monad.Reader + , module HBS2.System.Logger.Simple.ANSI , Generic ) where import HBS2.Prelude.Plated import HBS2.OrDie +import HBS2.System.Logger.Simple.ANSI 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 3a1b867d..22e8b4f0 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs @@ -485,6 +485,11 @@ internalEntries = do e -> throwIO (BadFormException @c nil) +instance MonadUnliftIO m => HasStorage (RunM c m) where + getStorage = do + so <- detectRPC `orDie` "hbs2-peer not found" + withRPC2 @StorageAPI @UNIX so $ \caller -> do + pure $ AnyStorage (StorageClient caller) withPeerStorage :: (IsContext c, MonadUnliftIO m) => (AnyStorage -> RunM c m a) -> RunM c m a withPeerStorage m = do diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs new file mode 100644 index 00000000..aff33bb6 --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs @@ -0,0 +1,56 @@ +module HBS2.CLI.Run.Internal.Merkle where + +import HBS2.CLI.Prelude +import HBS2.CLI.Run.Internal +import HBS2.CLI.Run.Internal.GroupKey + +import HBS2.Data.Types.Refs +import HBS2.Merkle +import HBS2.Storage +import HBS2.Storage.Operations.ByteString +import HBS2.Peer.RPC.Client.Unix +import HBS2.KeyMan.Keys.Direct + +import HBS2.Net.Auth.Schema() + +import Codec.Serialise +import Data.ByteString.Lazy qualified as LBS +import Data.HashMap.Strict qualified as HM +import Data.Text qualified as Text + +-- TODO: client-api-candidate +createTreeWithMetadata :: (MonadUnliftIO m) + => AnyStorage + -> Maybe (GroupKey 'Symm 'HBS2Basic) + -> HashMap Text Text + -> LBS.ByteString + -> m HashRef +createTreeWithMetadata sto mgk meta lbs = do -- flip runContT pure do + + let mt = vcat [ pretty k <> ":" <+> dquotes (pretty v) | (k,v) <- HM.toList meta ] + & show & Text.pack + + case mgk of + Nothing -> createSimpleTree mt + Just gk -> createEncryptedTree gk mt + + where + createSimpleTree mt = do + 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 + + createEncryptedTree gk mt = do + -- 1. + error "oopsie" + + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs index 582830a9..f5e90af0 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs @@ -16,6 +16,7 @@ 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.KeyMan.Keys.Direct import HBS2.Net.Auth.Schema() @@ -53,35 +54,6 @@ metaFromSyntax syn = where t x = Text.pack (show $ pretty x) -createTreeWithMetadata :: (MonadUnliftIO m) - => Maybe (GroupKey 'Symm 'HBS2Basic) - -> HashMap Text Text - -> LBS.ByteString - -> m HashRef -createTreeWithMetadata mgk meta lbs = do - debug "create fucking metadata" - -- TODO: set-hbs2-peer - so <- detectRPC `orDie` "hbs2-peer not found" - - let mt = vcat [ pretty k <> ":" <+> dquotes (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 @@ -181,9 +153,13 @@ metaDataEntries = do when (isJust enc && isNothing gk) do error $ show $ "Can't load group key" <+> pretty enc - href <- createTreeWithMetadata gk (meta0 <> meta1) lbs + flip runContT pure do - pure $ mkStr (show $ pretty href) + sto <- ContT withPeerStorage + + href <- lift $ createTreeWithMetadata sto gk (meta0 <> meta1) lbs + + pure $ mkStr (show $ pretty href) entry $ bindMatch "cbor:base58" $ \case [ LitStrVal x ] -> do