cli: option to mark shown messages as read (off by default) (#3506)

* cli: option to mark shown messages as read (off by default)

* fix tests

* fix tests

apps/simplex-broadcast-bot/src/Broadcast/Options.hs

@@ -83,5 +83,6 @@ mkChatOpts BroadcastBotOpts {coreOptions} =
       allowInstantFiles = True,
       autoAcceptFileSize = 0,
       muteNotifications = True,
+      markRead = False,
       maintenance = False
     }

apps/simplex-directory-service/src/Directory/Options.hs

@@ -5,10 +5,10 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Directory.Options
- ( DirectoryOpts (..),
+  ( DirectoryOpts (..),
-   getDirectoryOpts,
+    getDirectoryOpts,
-   mkChatOpts,
+    mkChatOpts,
- )
+  )
 where
 
 import Options.Applicative
@@ -35,8 +35,8 @@ directoryOpts appDir defaultDbFileName = do
           <> help "Comma-separated list of super-users in the format CONTACT_ID:DISPLAY_NAME who will be allowed to manage the directory"
       )
   directoryLog <-
-    Just <$>
+    Just
-      strOption
+      <$> strOption
         ( long "directory-file"
             <> metavar "DIRECTORY_FILE"
             <> help "Append only log for directory state"
@@ -81,5 +81,6 @@ mkChatOpts DirectoryOpts {coreOptions} =
       allowInstantFiles = True,
       autoAcceptFileSize = 0,
       muteNotifications = True,
+      markRead = False,
       maintenance = False
     }

src/Simplex/Chat/Options.hs

@@ -42,6 +42,7 @@ data ChatOpts = ChatOpts
     allowInstantFiles :: Bool,
     autoAcceptFileSize :: Integer,
     muteNotifications :: Bool,
+    markRead :: Bool,
     maintenance :: Bool
   }
 
@@ -268,6 +269,12 @@ chatOptsP appDir defaultDbFileName = do
       ( long "mute"
           <> help "Mute notifications"
       )
+  markRead <-
+    switch
+      ( long "mark-read"
+          <> short 'r'
+          <> help "Mark shown messages as read"
+      )
   maintenance <-
     switch
       ( long "maintenance"
@@ -286,6 +293,7 @@ chatOptsP appDir defaultDbFileName = do
         allowInstantFiles,
         autoAcceptFileSize,
         muteNotifications,
+        markRead,
         maintenance
       }
 

src/Simplex/Chat/Terminal.hs

@@ -44,7 +44,7 @@ simplexChatTerminal cfg opts t =
   handle checkDBKeyError . simplexChatCore cfg opts $ \u cc -> do
     ct <- newChatTerminal t opts
     when (firstTime cc) . printToTerminal ct $ chatWelcome u
-    runChatTerminal ct cc
+    runChatTerminal ct cc opts
 
 checkDBKeyError :: SQLError -> IO ()
 checkDBKeyError e = case sqlError e of
@@ -53,5 +53,5 @@ checkDBKeyError e = case sqlError e of
     exitFailure
   _ -> throwIO e
 
-runChatTerminal :: ChatTerminal -> ChatController -> IO ()
+runChatTerminal :: ChatTerminal -> ChatController -> ChatOpts -> IO ()
-runChatTerminal ct cc = raceAny_ [runTerminalInput ct cc, runTerminalOutput ct cc, runInputLoop ct cc]
+runChatTerminal ct cc opts = raceAny_ [runTerminalInput ct cc, runTerminalOutput ct cc opts, runInputLoop ct cc]

src/Simplex/Chat/Terminal/Output.hs

@@ -142,13 +142,13 @@ withTermLock ChatTerminal {termLock} action = do
   action
   atomically $ putTMVar termLock ()
 
-runTerminalOutput :: ChatTerminal -> ChatController -> IO ()
+runTerminalOutput :: ChatTerminal -> ChatController -> ChatOpts -> IO ()
-runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = do
+runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} ChatOpts {markRead} = do
   forever $ do
     (_, outputRH, r) <- atomically $ readTBQueue outputQ
     case r of
-      CRNewChatItem u ci -> markChatItemRead u ci
+      CRNewChatItem u ci -> when markRead $ markChatItemRead u ci
-      CRChatItemUpdated u ci -> markChatItemRead u ci
+      CRChatItemUpdated u ci -> when markRead $ markChatItemRead u ci
       CRRemoteHostConnected {remoteHost = RemoteHostInfo {remoteHostId}} -> getRemoteUser remoteHostId
       CRRemoteHostStopped {remoteHostId_} -> mapM_ removeRemoteUser remoteHostId_
       _ -> pure ()

tests/ChatClient.hs

@@ -82,6 +82,7 @@ testOpts =
       allowInstantFiles = True,
       autoAcceptFileSize = 0,
       muteNotifications = True,
+      markRead = True,
       maintenance = False
     }
 
@@ -174,7 +175,7 @@ startTestChat_ db cfg opts user = do
   t <- withVirtualTerminal termSettings pure
   ct <- newChatTerminal t opts
   cc <- newChatController db (Just user) cfg opts
-  chatAsync <- async . runSimplexChat opts user cc . const $ runChatTerminal ct
+  chatAsync <- async . runSimplexChat opts user cc $ \_u cc' -> runChatTerminal ct cc' opts
   atomically . unless (maintenance opts) $ readTVar (agentAsync cc) >>= \a -> when (isNothing a) retry
   termQ <- newTQueueIO
   termAsync <- async $ readTerminalOutput t termQ

tests/RemoteTests.hs

@@ -162,13 +162,13 @@ storedBindingsTest = testChat2 aliceProfile aliceDesktopProfile $ \mobile deskto
 
   desktop ##> "/list remote hosts"
   desktop <## "Remote hosts:"
-  desktop <## "1. Mobile (connected) [lo 127.0.0.1:52230]"
+  desktop <##. "1. Mobile (connected) ["
   stopDesktop mobile desktop
   desktop ##> "/list remote hosts"
   desktop <## "Remote hosts:"
-  desktop <## "1. Mobile [lo 127.0.0.1:52230]"
+  desktop <##. "1. Mobile ["
 
-  -- TODO: more parser tests
+-- TODO: more parser tests
 
 remoteMessageTest :: HasCallStack => FilePath -> IO ()
 remoteMessageTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> do