wip

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

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

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

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"
+
+

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,7 +153,11 @@ 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
+
+          sto <- ContT withPeerStorage
+
+          href <- lift $ createTreeWithMetadata sto  gk (meta0 <> meta1) lbs
 
           pure $ mkStr (show $ pretty href)