wip, create multipart message

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
+
 

hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs

@@ -9,6 +9,7 @@ import HBS2.Peer.Proto.Mailbox.Types
 import HBS2.Data.Types.SmallEncryptedBlock
 import HBS2.Net.Auth.Credentials.Sigil
 import HBS2.Net.Auth.GroupKeySymm
+import HBS2.Merkle.MetaData
 
 import HBS2.OrDie
 import HBS2.Base58
@@ -21,17 +22,14 @@ import HBS2.Net.Auth.Schema()
 
 import Control.Monad.Except
 import Data.ByteString (ByteString)
-import Data.Set
+import Data.ByteString.Lazy qualified as LBS
+import Data.Text qualified as Text
 import Data.Set qualified as Set
-import Data.Word
+import Data.HashMap.Strict qualified as HM
 import Lens.Micro.Platform
 import Streaming.Prelude qualified as S
 import UnliftIO
 
--- TODO: mailbox-proto-handler
-
--- TODO: mailbox-proto-test?
-
 
 data CreateMessageError =
     SenderNotSet
@@ -65,7 +63,7 @@ createMessage :: forall s m . (MonadUnliftIO m , s ~ HBS2Basic)
               -> Maybe GroupSecret
               -> Either HashRef (Sigil s)    -- ^ sender
               -> [Either HashRef (Sigil s)]  -- ^ sigil keys (recipients)
-              -> [HashRef]                   -- ^ message parts
+              -> [m ([(Text, Text)], LBS.ByteString)] -- ^ message parts
               -> ByteString                  -- ^ payload
               -> m (Message s)
 createMessage CreateMessageServices{..} _ gks sender' rcpts' parts bs = do
@@ -90,12 +88,21 @@ createMessage CreateMessageServices{..} _ gks sender' rcpts' parts bs = do
 
   encrypted <- encryptBlock cmStorage gks (Right gk) Nothing  bs
 
+  trees <- for parts $ \mpart -> do
+    (meta, lbs) <- mpart
+
+    let mt = vcat [ pretty k <> ":" <+> dquotes (pretty v)
+                  | (k,v) <- HM.toList (HM.fromList meta)
+                  ]
+               & show & Text.pack
+
+    createEncryptedTree cmStorage gks gk (DefSource mt lbs)
+
   let content = MessageContent @s
                   flags
                   (Set.fromList (fmap fst recipients))
                   (Right gk)
-                  -- TODO: check-if-parts-exists
+                  (Set.fromList trees)
-                  (Set.fromList parts)
                   encrypted
 
   creds <- cmLoadCredentials (fst sender)