storage w. AnyProbe

hbs2-core/lib/HBS2/Merkle/MetaData.hs

@@ -1,18 +1,26 @@
+{-# Language AllowAmbiguousTypes #-}
+{-# Language UndecidableInstances #-}
+{-# Language FunctionalDependencies #-}
 module HBS2.Merkle.MetaData where
 
 import HBS2.Prelude
 import HBS2.OrDie
 import HBS2.Data.Types.Refs
 import HBS2.Merkle
+import HBS2.Hash
 import HBS2.Storage
 import HBS2.Data.Types.SmallEncryptedBlock
 import HBS2.Net.Auth.GroupKeySymm as G
 import HBS2.Storage.Operations.Class
+import HBS2.Storage.Operations.ByteString (readChunkedBS)
 
 import Data.Coerce
 import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Lazy (ByteString)
+import Data.ByteString qualified as BS
 import Codec.Serialise
 import Data.Text.Encoding qualified as TE
+import Control.Exception
 import Control.Monad.Except
 import Control.Monad.Trans.Maybe
 
@@ -78,4 +86,48 @@ loadGroupKeyForTree sto h = do
 
     G.loadGroupKeyMaybe sto gkh >>= toMPlus
 
+class ForGroupKeySymm s => ForEncryptedTree s a  | a -> s where
+  getNonce     :: Monad m => a -> m BS.ByteString
+
+  getContent   :: a -> ByteString
+  getMetaData  :: a -> Text
+
+  getBlockSize :: a -> Int
+  getBlockSize _ = 256 * 1024
+
+data DefaultEncryptedTreeSource (s :: CryptoScheme) = DefSource Text LBS.ByteString
+
+instance ForGroupKeySymm s => ForEncryptedTree s (DefaultEncryptedTreeSource s) where
+  getContent (DefSource _ lbs) = lbs
+
+  getMetaData (DefSource m _) = m
+
+  getNonce (DefSource _ lbs) = do
+    let s0 = LBS.take ( 1024 * 1024 ) lbs
+    let (HbSyncHash nonce) = hashObject @HbSync s0
+    pure nonce
+
+createEncryptedTree :: forall s a m . ( ForEncryptedTree s a, MonadIO m )
+                     => AnyStorage
+                     -> GroupSecret
+                     -> GroupKey 'Symm s
+                     -> a
+                     -> m HashRef
+createEncryptedTree sto gks gk what = do
+
+
+  nonce <- getNonce @s what
+  let lbs = getContent @s what
+
+  let segments = readChunkedBS lbs (getBlockSize what)
+
+  seb <- encryptBlock sto gks (Right gk) (Just nonce) (ShortMetadata (getMetaData @s what))
+
+  hmeta <- putBlock sto (serialise seb)
+             >>= orThrow StorageError
+
+  let source = ToEncryptSymmBS gks (Right gk) nonce segments  (AnnHashRef hmeta) Nothing
+
+  runExceptT (writeAsMerkle sto source <&> HashRef) >>= orThrowPassIO
+