wip, hbs2📫message:read

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

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