Watch direct messages using local state diffs

Changelog: API: Replaced `watchReceivedDirectMessages` with `watchDirectMessageThreads`

2 files changed, 27 insertions, 24 deletions

diff --git a/main/Main.hs b/main/Main.hs
index 974038f..d95e766 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -369,16 +369,20 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do
 
     _ <- liftIO $ do
         tzone <- getCurrentTimeZone
-        watchReceivedDirectMessages erebosHead $ \smsg -> do
-            let msg = fromStored smsg
-            extPrintLn $ formatDirectMessage tzone msg
-            case optDmBotEcho opts of
-                Nothing -> return ()
-                Just prefix -> do
-                    res <- runExceptT $ flip runReaderT erebosHead $ sendDirectMessage (msgFrom msg) (prefix <> msgText msg)
-                    case res of
-                        Right reply -> extPrintLn $ formatDirectMessage tzone $ fromStored reply
-                        Left err -> extPrintLn $ "Failed to send dm echo: " <> err
+        let self = finalOwner $ headLocalIdentity erebosHead
+        watchDirectMessageThreads erebosHead $ \prev cur -> do
+            forM_ (reverse $ dmThreadToListSince prev cur) $ \msg -> do
+                extPrintLn $ formatDirectMessage tzone msg
+                case optDmBotEcho opts of
+                    Just prefix
+                        | not (msgFrom msg `sameIdentity` self)
+                        -> do
+                            void $ forkIO $ do
+                                res <- runExceptT $ flip runReaderT erebosHead $ sendDirectMessage (msgFrom msg) (prefix <> msgText msg)
+                                case res of
+                                    Right _ -> return ()
+                                    Left err -> extPrintLn $ "Failed to send dm echo: " <> err
+                    _ -> return ()
 
     peers <- liftIO $ newMVar []
     contextOptions <- liftIO $ newMVar []
@@ -682,11 +686,7 @@ cmdSend :: Command
 cmdSend = void $ do
     text <- asks ciLine
     conv <- getSelectedConversation
-    sendMessage conv (T.pack text) >>= \case
-        Just msg -> do
-            tzone <- liftIO $ getCurrentTimeZone
-            cmdPutStrLn $ formatMessage tzone msg
-        Nothing -> return ()
+    void $ sendMessage conv (T.pack text)
 
 cmdDelete :: Command
 cmdDelete = void $ do
diff --git a/main/Test.hs b/main/Test.hs
index fd6258d..323b240 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -232,14 +232,16 @@ discoveryAttributes = (defaultServiceAttributes Proxy)
     { discoveryProvideTunnel = \_ _ -> False
     }
 
-dmReceivedWatcher :: Output -> Stored DirectMessage -> IO ()
-dmReceivedWatcher out smsg = do
-    let msg = fromStored smsg
-    outLine out $ unwords
-        [ "dm-received"
-        , "from", maybe "<unnamed>" T.unpack $ idName $ msgFrom msg
-        , "text", T.unpack $ msgText msg
-        ]
+dmThreadWatcher :: ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO ()
+dmThreadWatcher self out prev cur = do
+    forM_ (reverse $ dmThreadToListSince prev cur) $ \msg -> do
+        outLine out $ unwords
+            [ if sameIdentity self (msgFrom msg)
+                 then "dm-sent"
+                 else "dm-received"
+            , "from", maybe "<unnamed>" T.unpack $ idName $ msgFrom msg
+            , "text", T.unpack $ msgText msg
+            ]
 
 
 newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT ErebosError IO)) a)
@@ -456,7 +458,8 @@ cmdHeadUnwatch = do
 
 initTestHead :: Head LocalState -> Command
 initTestHead h = do
-    _ <- liftIO . watchReceivedDirectMessages h . dmReceivedWatcher =<< asks tiOutput
+    let self = finalOwner $ headLocalIdentity h
+    _ <- liftIO . watchDirectMessageThreads h . dmThreadWatcher self =<< asks tiOutput
     modify $ \s -> s { tsHead = Just h }
 
 loadTestHead :: CommandM (Head LocalState)