diff --git a/hbs2-core/lib/HBS2/Merkle/MetaData.hs b/hbs2-core/lib/HBS2/Merkle/MetaData.hs index a935da13..c4590ae2 100644 --- a/hbs2-core/lib/HBS2/Merkle/MetaData.hs +++ b/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 + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs index bb6319ec..47b985c9 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs +++ b/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 parts) + (Set.fromList trees) encrypted creds <- cmLoadCredentials (fst sender)