From a3a5c46cc01f4748641121212afb929c131541a3 Mon Sep 17 00:00:00 2001
From: voidlizard <dzuikov@gmail.com>
Date: Sun, 2 Feb 2025 12:51:19 +0300
Subject: [PATCH] wip, grove + webroot

---
 hbs2-cli/lib/HBS2/CLI/Run/Tree.hs | 27 +++++++++++++++++++++++++++
 1 file changed, 27 insertions(+)

diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs b/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs
index eb7e5c45..a868899b 100644
--- a/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs
+++ b/hbs2-cli/lib/HBS2/CLI/Run/Tree.hs
@@ -21,7 +21,9 @@ import HBS2.Peer.RPC.API.Storage
 import HBS2.Peer.RPC.Client
 import HBS2.Peer.RPC.Client.Unix
 
+import Data.Text qualified as Text
 import Control.Monad.Except
+import Codec.Serialise
 
 treeEntries :: forall c m . ( IsContext c
                                 , MonadUnliftIO m
@@ -62,3 +64,28 @@ It's just an easy way to create a such thing, you may browse it by hbs2 cat -H
 
         _ -> throwIO (BadFormException @c nil)
 
+  entry $ bindMatch "hbs2:grove:annotated" $ \case
+    (ListVal ann : HashLikeList hashes@(x:_)) -> lift do
+      sto <- getStorage
+
+      let pt = toPTree (MaxSize defHashListChunk) (MaxNum defTreeChildNum) hashes
+
+      tree <- liftIO (makeMerkle 0 pt $ \(_,_,bss) -> do
+                void $ putBlock sto bss)
+
+      block <- getBlock sto tree
+                  >>= orThrow MissedBlockError
+                  <&> deserialiseOrFail @(MTree [HashRef])
+                  >>= orThrow UnsupportedFormat
+
+      let kwa = Text.unlines $ fmap (Text.pack . show . pretty) ann
+      let mann = MTreeAnn (ShortMetadata kwa) NullEncryption block
+
+      r <- putBlock sto (serialise mann)
+              >>= orThrowUser "can't write tree"
+              <&> HashRef
+
+      pure $ mkSym (show $ pretty r)
+
+    _ -> throwIO (BadFormException @c nil)
+