diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs b/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs index 6d1191aa..30876456 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs @@ -9,12 +9,16 @@ import HBS2.Net.Auth.GroupKeySymm import HBS2.Peer.Proto.Mailbox import HBS2.Peer.Proto.Mailbox.Policy.Basic +import HBS2.Base58 +import HBS2.System.Dir import HBS2.Data.Types.Refs import HBS2.Hash import HBS2.Storage import HBS2.KeyMan.Keys.Direct as K import Codec.Serialise +import Data.Text qualified as Text +import Data.Text.Encoding (encodeUtf8) import Control.Monad.Except import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS @@ -23,9 +27,9 @@ import Data.Coerce import Data.Either createShortMessageFromByteString :: forall s m . ( MonadUnliftIO m - , s ~ HBS2Basic - , HasStorage m - ) + , s ~ HBS2Basic + , HasStorage m + ) => LBS8.ByteString -> m (Message s) createShortMessageFromByteString lbs = do @@ -36,10 +40,10 @@ createShortMessageFromByteString lbs = do flagz <- defMessageFlags - sender <- headMay [ Left s | ListVal [SymbolVal "sender:", HashLike s] <- headers ] + sender <- headMay [ Left s | ListVal [SymbolVal "sender", HashLike s] <- headers ] & orThrowUser "sender not defined" - let rcpts = [ Left s | ListVal [SymbolVal "recipient:", HashLike s] <- headers ] + let rcpts = [ Left s | ListVal [SymbolVal "recipient", HashLike s] <- headers ] sto <- getStorage @@ -72,6 +76,115 @@ mailboxEntries = do _ -> throwIO (BadFormException @c nil) + brief "creates a new multipart message" + $ desc [qc| +;; creates multipart message + +hbs2:mailbox:message:create:multipart [kw k1 v1 kn kv] + +WHERE + + k ::= sender | recipient | body | part + + sender ::= HASH(sigil) + body ::= STRING + part ::= FILENAME + + |] + $ examples [qc| + +[hbs2:peer:storage:put +..hbs2:mailbox:message:create:multipart +...[kw sender ghna99Xtm33ncfdUBT3htBUoEyT16wTZGMdm24BQ1kh +.......recipient 4e9moTcp9AW13wRYYWg5F8HWooVH1PuQ7zsf5g2JYPWj +.......body [str:file body.txt] +.......part patch1.patch +...]] + +|] + $ returns "bytes" "message" + $ entry $ bindMatch "hbs2:mailbox:message:create:multipart" $ \syn -> lift do + + sto <- getStorage + let cms = CreateMessageServices + sto + ( runKeymanClientRO . loadCredentials ) + ( runKeymanClientRO . loadKeyRingEntry ) + + + flagz <- defMessageFlags + tsender <- newTVarIO Nothing + tbody <- newTVarIO (mempty :: LBS.ByteString) + trcpt <- newTVarIO mempty + tparts <- newTVarIO mempty + + case syn of + [ListVal (SymbolVal "dict" : parts)] -> do + + for_ parts $ \case + ListVal [StringLike "sender", HashLike ss] -> do + atomically $ writeTVar tsender (Just ss) + + ListVal [StringLike "recipient", HashLike ss] -> do + atomically $ modifyTVar trcpt (ss:) + + ListVal [StringLike "body", StringLike s] -> do + let lbs = encodeUtf8 (fromString s) & LBS.fromStrict + atomically $ modifyTVar tbody (LBS.append lbs) + + ListVal [StringLike "part", StringLike fn] -> do + let what = takeFileName fn & fromString + let rfn = liftIO (LBS.readFile fn) + let meta = [("file-name:", what)] + atomically $ modifyTVar tparts ( [(meta,rfn)] <> ) + + _ -> pure () + + _ -> throwIO (BadFormException @c nil) + + sender <- readTVarIO tsender >>= orThrowUser "sender not set" + rcpt <- readTVarIO trcpt <&> fmap Left + body <- readTVarIO tbody + parts <- readTVarIO tparts + mess <- createMessage cms flagz Nothing + (Left sender) + rcpt + parts + (LBS.toStrict body) + + mkOpaque (serialise mess) + + entry $ bindMatch "hbs2:mailbox:message:dump" $ nil_ \syn -> lift do + lbs <- case syn of + [ HashLike h ] -> do + sto <- getStorage + getBlock sto (coerce h) >>= orThrowUser "message not found" + + [ StringLike fn ] -> do + liftIO $ LBS.readFile fn + + _ -> throwIO (BadFormException @c nil) + + let rms = ReadMessageServices ( liftIO . runKeymanClientRO . extractGroupKeySecret) + + (s,mess,co) <- deserialiseOrFail @(Message HBS2Basic) lbs + & orThrowUser "malformed message" + >>= readMessage rms + + -- TODO: implement-normally + liftIO do + print $ "sender" <+> pretty (AsBase58 s) + + for_ (messageRecipients mess) $ \r -> do + print $ "recipient" <+> pretty (AsBase58 r) + + for_ (messageParts mess) $ \p -> do + print $ "attachment" <+> pretty p + + putStrLn "" + + BS.putStr co + entry $ bindMatch "hbs2:mailbox:message:read:file" $ nil_ \case [StringLike s] -> lift do sto <- getStorage diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs index 47b985c9..2213f473 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Message.hs @@ -63,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) - -> [m ([(Text, Text)], LBS.ByteString)] -- ^ message parts + -> [([(Text, Text)], m LBS.ByteString)] -- ^ message parts -> ByteString -- ^ payload -> m (Message s) createMessage CreateMessageServices{..} _ gks sender' rcpts' parts bs = do @@ -88,14 +88,14 @@ createMessage CreateMessageServices{..} _ gks sender' rcpts' parts bs = do encrypted <- encryptBlock cmStorage gks (Right gk) Nothing bs - trees <- for parts $ \mpart -> do - (meta, lbs) <- mpart + trees <- for parts $ \(meta, lbsRead)-> do let mt = vcat [ pretty k <> ":" <+> dquotes (pretty v) | (k,v) <- HM.toList (HM.fromList meta) ] & show & Text.pack + lbs <- lbsRead createEncryptedTree cmStorage gks gk (DefSource mt lbs) let content = MessageContent @s