From 86271fe109fabb6239938dbb0e4ff0ee95b9d2e6 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 19 Dec 2022 11:16:50 +0000 Subject: [PATCH] terminal: support live messages (#1597) * terminal: toggle live message updates * terminal: send live messages (#1599) * terminal: send live messages * show edited messages * send and continue live message with Alt-Enter * truncate live messages to full words * remove comments * refactor * refactor to avoid clearing live message prompt and show it faster * $ Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com> Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com> Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com> --- src/Simplex/Chat.hs | 53 +++++--- src/Simplex/Chat/Controller.hs | 11 +- src/Simplex/Chat/Messages.hs | 10 ++ src/Simplex/Chat/Store.hs | 19 ++- src/Simplex/Chat/Terminal/Input.hs | 136 +++++++++++++++---- src/Simplex/Chat/Terminal/Output.hs | 34 ++++- src/Simplex/Chat/View.hs | 194 +++++++++++++++++----------- tests/ChatTests.hs | 40 +++--- 8 files changed, 357 insertions(+), 140 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 5670d55d23..a5c5d9ff0d 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -158,7 +158,8 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen expireCIs <- newTVarIO False cleanupManagerAsync <- newTVarIO Nothing timedItemThreads <- atomically TM.empty - pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, incognitoMode, filesFolder, expireCIsAsync, expireCIs, cleanupManagerAsync, timedItemThreads} + showLiveItems <- newTVarIO False + pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, incognitoMode, filesFolder, expireCIsAsync, expireCIs, cleanupManagerAsync, timedItemThreads, showLiveItems} where configServers :: InitialAgentServers configServers = @@ -473,7 +474,7 @@ processChatCommand = \case case (ciContent, itemSharedMsgId) of (CISndMsgContent _, Just itemSharedMId) -> do SndMessage {msgId} <- sendGroupMessage gInfo ms (XMsgUpdate itemSharedMId mc (ciTimedToTTL itemTimed) (justTrue . (live &&) =<< itemLive)) - updCi <- withStore $ \db -> updateGroupChatItem db user groupId itemId (CISndMsgContent mc) live msgId + updCi <- withStore $ \db -> updateGroupChatItem db user groupId itemId (CISndMsgContent mc) live $ Just msgId setActive $ ActiveG gName pure . CRChatItemUpdated $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) updCi _ -> throwChatError CEInvalidChatItemUpdate @@ -905,10 +906,8 @@ processChatCommand = \case RejectContact cName -> withUser $ \User {userId} -> do connReqId <- withStore $ \db -> getContactRequestIdByName db userId cName processChatCommand $ APIRejectContact connReqId - SendMessage chatName msg -> withUser $ \user -> do - chatRef <- getChatRef user chatName - let mc = MCText $ safeDecodeUtf8 msg - processChatCommand . APISendMessage chatRef False $ ComposedMessage Nothing Nothing mc + SendMessage chatName msg -> sendTextMessage chatName msg False + SendLiveMessage chatName msg -> sendTextMessage chatName msg True SendMessageBroadcast msg -> withUser $ \user -> do contacts <- withStore' (`getUserContacts` user) withChatLock "sendMessageBroadcast" . procCmd $ do @@ -936,6 +935,10 @@ processChatCommand = \case editedItemId <- getSentChatItemIdByText user chatRef editedMsg let mc = MCText $ safeDecodeUtf8 msg processChatCommand $ APIUpdateChatItem chatRef editedItemId False mc + UpdateLiveMessage chatName chatItemId live msg -> withUser $ \user -> do + chatRef <- getChatRef user chatName + let mc = MCText $ safeDecodeUtf8 msg + processChatCommand $ APIUpdateChatItem chatRef chatItemId live mc NewGroup gProfile -> withUser $ \user -> do gVar <- asks idsDrg groupInfo <- withStore (\db -> createNewGroup db gVar user gProfile) @@ -1110,14 +1113,21 @@ processChatCommand = \case processChatCommand . APISendMessage (ChatRef CTGroup groupId) False $ ComposedMessage Nothing (Just quotedItemId) mc LastMessages (Just chatName) count search -> withUser $ \user -> do chatRef <- getChatRef user chatName - CRLastMessages . aChatItems . chat <$> processChatCommand (APIGetChat chatRef (CPLast count) search) + CRChatItems . aChatItems . chat <$> processChatCommand (APIGetChat chatRef (CPLast count) search) LastMessages Nothing count search -> withUser $ \user -> withStore $ \db -> - CRLastMessages <$> getAllChatItems db user (CPLast count) search + CRChatItems <$> getAllChatItems db user (CPLast count) search LastChatItemId (Just chatName) index -> withUser $ \user -> do chatRef <- getChatRef user chatName - CRLastChatItemId . fmap aChatItemId . listToMaybe . aChatItems . chat <$> processChatCommand (APIGetChat chatRef (CPLast $ index + 1) Nothing) + CRChatItemId . fmap aChatItemId . listToMaybe . aChatItems . chat <$> processChatCommand (APIGetChat chatRef (CPLast $ index + 1) Nothing) LastChatItemId Nothing index -> withUser $ \user -> withStore $ \db -> - CRLastChatItemId . fmap aChatItemId . listToMaybe <$> getAllChatItems db user (CPLast $ index + 1) Nothing + CRChatItemId . fmap aChatItemId . listToMaybe <$> getAllChatItems db user (CPLast $ index + 1) Nothing + ShowChatItem (Just itemId) -> withUser $ \user -> withStore $ \db -> + CRChatItems . (: []) <$> getAChatItem db user itemId + ShowChatItem Nothing -> withUser $ \user -> withStore $ \db -> + CRChatItems <$> getAllChatItems db user (CPLast 1) Nothing + ShowLiveItems on -> withUser $ \_ -> do + asks showLiveItems >>= atomically . (`writeTVar` on) + pure CRCmdOk SendFile chatName f -> withUser $ \user -> do chatRef <- getChatRef user chatName processChatCommand . APISendMessage chatRef False $ ComposedMessage (Just f) Nothing (MCFile "") @@ -1385,6 +1395,10 @@ processChatCommand = \case ci <- saveSndChatItem user (CDDirectSnd ct) msg content toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci setActive $ ActiveG localDisplayName + sendTextMessage chatName msg live = withUser $ \user -> do + chatRef <- getChatRef user chatName + let mc = MCText $ safeDecodeUtf8 msg + processChatCommand . APISendMessage chatRef live $ ComposedMessage Nothing Nothing mc assertDirectAllowed :: ChatMonad m => User -> MsgDirection -> Contact -> CMEventTag e -> m () assertDirectAllowed user dir ct event = @@ -2462,16 +2476,18 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = -- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete). -- Chat item and update message which created it will have different sharedMsgId in this case... let timed_ = rcvMsgCITimed (contactCITimedTTL ct) ttl - ci <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) msgMeta (CIRcvMsgContent mc) Nothing timed_ live - toView . CRChatItemUpdated $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci + ci <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) msgMeta content Nothing timed_ live + ci' <- withStore $ \db -> updateDirectChatItem db userId contactId (chatItemId' ci) content live Nothing + toView . CRChatItemUpdated $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci' setActive $ ActiveC c _ -> throwError e where + content = CIRcvMsgContent mc live = fromMaybe False live_ updateRcvChatItem = do CChatItem msgDir ChatItem {meta = CIMeta {itemId}} <- withStore $ \db -> getDirectChatItemBySharedMsgId db userId contactId sharedMsgId case msgDir of - SMDRcv -> updateDirectChatItemView userId ct itemId (ACIContent SMDRcv $ CIRcvMsgContent mc) live $ Just msgId + SMDRcv -> updateDirectChatItemView userId ct itemId (ACIContent SMDRcv content) live $ Just msgId SMDSnd -> messageError "x.msg.update: contact attempted invalid message update" messageDelete :: Contact -> SharedMsgId -> RcvMessage -> MsgMeta -> m () @@ -2521,11 +2537,13 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = -- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete). -- Chat item and update message which created it will have different sharedMsgId in this case... let timed_ = rcvMsgCITimed (groupCITimedTTL gInfo) ttl_ - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) msgMeta (CIRcvMsgContent mc) Nothing timed_ live - toView . CRChatItemUpdated $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) msgMeta content Nothing timed_ live + ci' <- withStore $ \db -> updateGroupChatItem db user groupId (chatItemId' ci) content live Nothing + toView . CRChatItemUpdated $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci' setActive $ ActiveG g _ -> throwError e where + content = CIRcvMsgContent mc live = fromMaybe False live_ updateRcvChatItem = do CChatItem msgDir ChatItem {chatDir, meta = CIMeta {itemId}} <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId @@ -2533,7 +2551,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = (SMDRcv, CIGroupRcv m') -> if sameMemberId memberId m' then do - updCi <- withStore $ \db -> updateGroupChatItem db user groupId itemId (CIRcvMsgContent mc) live msgId + updCi <- withStore $ \db -> updateGroupChatItem db user groupId itemId content live $ Just msgId toView . CRChatItemUpdated $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) updCi setActive $ ActiveG g else messageError "x.msg.update: group member attempted to update a message of another member" -- shouldn't happen now that query includes group member id @@ -3634,6 +3652,7 @@ chatCommandP = ("/connect " <|> "/c ") *> (Connect <$> ((Just <$> strP) <|> A.takeByteString $> Nothing)), ("/connect" <|> "/c") $> AddContact, SendMessage <$> chatNameP <* A.space <*> A.takeByteString, + "/live " *> (SendLiveMessage <$> chatNameP <*> (A.space *> A.takeByteString <|> pure "")), (">@" <|> "> @") *> sendMsgQuote (AMsgDirection SMDRcv), (">>@" <|> ">> @") *> sendMsgQuote (AMsgDirection SMDSnd), ("\\ " <|> "\\") *> (DeleteMessage <$> chatNameP <* A.space <*> A.takeByteString), @@ -3642,6 +3661,8 @@ chatCommandP = ("/tail" <|> "/t") *> (LastMessages <$> optional (A.space *> chatNameP) <*> msgCountP <*> pure Nothing), ("/search" <|> "/?") *> (LastMessages <$> optional (A.space *> chatNameP) <*> msgCountP <*> (Just <$> (A.space *> stringP))), "/last_item_id" *> (LastChatItemId <$> optional (A.space *> chatNameP) <*> (A.space *> A.decimal <|> pure 0)), + "/show" *> (ShowLiveItems <$> (A.space *> onOffP <|> pure True)), + "/show " *> (ShowChatItem . Just <$> A.decimal), ("/file " <|> "/f ") *> (SendFile <$> chatNameP' <* A.space <*> filePath), ("/image " <|> "/img ") *> (SendImage <$> chatNameP' <* A.space <*> filePath), ("/fforward " <|> "/ff ") *> (ForwardFile <$> chatNameP' <* A.space <*> A.decimal), diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index e5e541721b..80494b629a 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -126,7 +126,8 @@ data ChatController = ChatController expireCIsAsync :: TVar (Maybe (Async ())), expireCIs :: TVar Bool, cleanupManagerAsync :: TVar (Maybe (Async ())), - timedItemThreads :: TMap (ChatRef, ChatItemId) (TVar (Maybe (Weak ThreadId))) + timedItemThreads :: TMap (ChatRef, ChatItemId) (TVar (Maybe (Weak ThreadId))), + showLiveItems :: TVar Bool } data HelpSection = HSMain | HSFiles | HSGroups | HSMyAddress | HSMarkdown | HSMessages | HSSettings @@ -233,10 +234,12 @@ data ChatCommand | AcceptContact ContactName | RejectContact ContactName | SendMessage ChatName ByteString + | SendLiveMessage ChatName ByteString | SendMessageQuote {contactName :: ContactName, msgDir :: AMsgDirection, quotedMsg :: ByteString, message :: ByteString} | SendMessageBroadcast ByteString | DeleteMessage ChatName ByteString | EditMessage {chatName :: ChatName, editedMsg :: ByteString, message :: ByteString} + | UpdateLiveMessage {chatName :: ChatName, chatItemId :: ChatItemId, liveMessage :: Bool, message :: ByteString} | NewGroup GroupProfile | AddMember GroupName ContactName GroupMemberRole | JoinGroup GroupName @@ -256,6 +259,8 @@ data ChatCommand | SendGroupMessageQuote {groupName :: GroupName, contactName_ :: Maybe ContactName, quotedMsg :: ByteString, message :: ByteString} | LastMessages (Maybe ChatName) Int (Maybe String) | LastChatItemId (Maybe ChatName) Int + | ShowChatItem (Maybe ChatItemId) + | ShowLiveItems Bool | SendFile ChatName FilePath | SendImage ChatName FilePath | ForwardFile ChatName FileTransferId @@ -285,8 +290,8 @@ data ChatResponse | CRChatSuspended | CRApiChats {chats :: [AChat]} | CRApiChat {chat :: AChat} - | CRLastMessages {chatItems :: [AChatItem]} - | CRLastChatItemId (Maybe ChatItemId) + | CRChatItems {chatItems :: [AChatItem]} + | CRChatItemId (Maybe ChatItemId) | CRApiParsedMarkdown {formattedText :: Maybe MarkdownList} | CRUserSMPServers {smpServers :: NonEmpty ServerCfg, presetSMPServers :: NonEmpty SMPServerWithAuth} | CRSmpTestResult {smpTestFailure :: Maybe SMPTestFailure} diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 17d3badd6e..823df7a05d 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -44,6 +44,16 @@ data ChatType = CTDirect | CTGroup | CTContactRequest | CTContactConnection data ChatName = ChatName ChatType Text deriving (Show) +chatTypeStr :: ChatType -> String +chatTypeStr = \case + CTDirect -> "@" + CTGroup -> "#" + CTContactRequest -> "<@" + CTContactConnection -> ":" + +chatNameStr :: ChatName -> String +chatNameStr (ChatName cType name) = chatTypeStr cType <> T.unpack name + data ChatRef = ChatRef ChatType Int64 deriving (Eq, Show, Ord) diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 49797e5822..46dc2b0274 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -189,6 +189,7 @@ module Simplex.Chat.Store getDirectChat, getGroupChat, getAllChatItems, + getAChatItem, getChatItemIdByAgentMsgId, getDirectChatItem, getDirectChatItemBySharedMsgId, @@ -3966,8 +3967,8 @@ getDirectChatItemIdByText db userId contactId msgDir quotedMsg = |] (userId, contactId, msgDir, quotedMsg <> "%") -updateGroupChatItem :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItemId -> CIContent d -> Bool -> MessageId -> ExceptT StoreError IO (ChatItem 'CTGroup d) -updateGroupChatItem db user@User {userId} groupId itemId newContent live msgId = do +updateGroupChatItem :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItemId -> CIContent d -> Bool -> Maybe MessageId -> ExceptT StoreError IO (ChatItem 'CTGroup d) +updateGroupChatItem db user@User {userId} groupId itemId newContent live msgId_ = do ci@ChatItem {meta = CIMeta {itemEdited, itemLive}} <- liftEither . correctDir =<< getGroupChatItem db user groupId itemId currentTs <- liftIO getCurrentTime let newText = ciContentToText newContent @@ -3982,7 +3983,7 @@ updateGroupChatItem db user@User {userId} groupId itemId newContent live msgId = WHERE user_id = ? AND group_id = ? AND chat_item_id = ? |] (newContent, newText, edited', live', currentTs, userId, groupId, itemId) - insertChatItemMessage_ db itemId msgId currentTs + forM_ msgId_ $ \msgId -> insertChatItemMessage_ db itemId msgId currentTs pure ci {content = newContent, meta = (meta ci) {itemText = newText, itemEdited = edited', itemLive = live'}, formattedText = parseMaybeMarkdownList newText} where correctDir :: CChatItem c -> Either StoreError (ChatItem c d) @@ -4143,6 +4144,18 @@ getChatItemByGroupId db user@User {userId} groupId = do (userId, groupId) getAChatItem_ db user itemId chatRef +getAChatItem :: DB.Connection -> User -> ChatItemId -> ExceptT StoreError IO AChatItem +getAChatItem db user@User {userId} itemId = do + chatRef <- + ExceptT . firstRow' toChatRef (SEChatItemNotFound itemId) $ + DB.query db "SELECT contact_id, group_id FROM chat_items WHERE user_id = ? AND chat_item_id = ?" (userId, itemId) + getAChatItem_ db user itemId chatRef + where + toChatRef = \case + (Just contactId, Nothing) -> Right $ ChatRef CTDirect contactId + (Nothing, Just groupId) -> Right $ ChatRef CTGroup groupId + (_, _) -> Left $ SEBadChatItem itemId + getAChatItem_ :: DB.Connection -> User -> ChatItemId -> ChatRef -> ExceptT StoreError IO AChatItem getAChatItem_ db user@User {userId} itemId = \case ChatRef CTDirect contactId -> do diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index 6c7ea54cdb..f4470a73d1 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -1,24 +1,29 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module Simplex.Chat.Terminal.Input where +import Control.Concurrent (forkFinally, forkIO, killThread, mkWeakThreadId, threadDelay) import Control.Monad.Except import Control.Monad.Reader -import Data.List (dropWhileEnd) +import Data.Char (isAlphaNum) +import Data.List (dropWhileEnd, foldl') +import Data.Maybe (isJust, isNothing) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) -import Data.Time.Clock (getCurrentTime) +import GHC.Weak (deRefWeak) import Simplex.Chat import Simplex.Chat.Controller +import Simplex.Chat.Messages import Simplex.Chat.Styled import Simplex.Chat.Terminal.Output -import Simplex.Chat.View -import Simplex.Messaging.Util (safeDecodeUtf8) +import Simplex.Messaging.Util (safeDecodeUtf8, whenM) import System.Exit (exitSuccess) import System.Terminal hiding (insertChars) import UnliftIO.STM @@ -31,7 +36,7 @@ getKey = _ -> getKey runInputLoop :: ChatTerminal -> ChatController -> IO () -runInputLoop ct cc = forever $ do +runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do s <- atomically . readTBQueue $ inputQ cc let bs = encodeUtf8 $ T.pack s cmd = parseChatCommand bs @@ -40,45 +45,131 @@ runInputLoop ct cc = forever $ do case r of CRChatCmdError _ -> when (isMessage cmd) $ echo s _ -> pure () - let testV = testView $ config cc - user <- readTVarIO $ currentUser cc - ts <- getCurrentTime - printToTerminal ct $ responseToView user testV ts r + printRespToTerminal ct cc False r + startLiveMessage cmd r where echo s = printToTerminal ct [plain s] isMessage = \case Right SendMessage {} -> True + Right SendLiveMessage {} -> True Right SendFile {} -> True Right SendMessageQuote {} -> True Right SendGroupMessageQuote {} -> True Right SendMessageBroadcast {} -> True _ -> False + startLiveMessage :: Either a ChatCommand -> ChatResponse -> IO () + startLiveMessage (Right (SendLiveMessage chatName msg)) (CRNewChatItem (AChatItem cType SMDSnd _ ChatItem {meta = CIMeta {itemId}})) = do + whenM (isNothing <$> readTVarIO liveMessageState) $ do + let s = T.unpack $ safeDecodeUtf8 msg + int = case cType of SCTGroup -> 5000000; _ -> 3000000 :: Int + liveThreadId <- mkWeakThreadId =<< runLiveMessage int `forkFinally` const (atomically $ writeTVar liveMessageState Nothing) + promptThreadId <- mkWeakThreadId =<< forkIO blinkLivePrompt + atomically $ do + let lm = LiveMessage {chatName, chatItemId = itemId, livePrompt = True, sentMsg = s, typedMsg = s, liveThreadId, promptThreadId} + writeTVar liveMessageState (Just lm) + modifyTVar termState $ \ts -> ts {inputString = s, inputPosition = length s, inputPrompt = liveInputPrompt lm} + where + liveInputPrompt LiveMessage {chatName = n, livePrompt} = + "> " <> chatNameStr n <> " [" <> (if livePrompt then "LIVE" else " ") <> "] " + runLiveMessage :: Int -> IO () + runLiveMessage int = do + threadDelay int + TerminalState {inputString = s} <- readTVarIO termState + readTVarIO liveMessageState + >>= mapM_ (\lm -> updateLiveMessage s lm >> runLiveMessage int) + blinkLivePrompt = readTVarIO liveMessageState >>= mapM_ updateLivePrompt + where + updateLivePrompt lm = do + atomically $ updatePrompt lm + updateInputView ct + threadDelay 1000000 + blinkLivePrompt + updatePrompt lm = do + writeTVar liveMessageState $ Just lm {livePrompt = not $ livePrompt lm} + modifyTVar termState (\ts -> ts {inputPrompt = liveInputPrompt lm}) + liveMessageToSend t LiveMessage {sentMsg, typedMsg} = + let s = if t /= typedMsg then truncateToWords t else t + in if s /= sentMsg then Just s else Nothing + updateLiveMessage typedMsg lm = case liveMessageToSend typedMsg lm of + Just sentMsg -> + sendUpdatedLiveMessage cc sentMsg lm True >>= \case + CRChatItemUpdated {} -> setLiveMessage lm {sentMsg, typedMsg} + _ -> do + -- TODO print error + setLiveMessage lm {typedMsg} + _ -> setLiveMessage lm {typedMsg} + setLiveMessage :: LiveMessage -> IO () + setLiveMessage = atomically . writeTVar liveMessageState . Just + truncateToWords = fst . foldl' acc ("", "") + where + acc (s, w) c + | isAlphaNum c = (s, c : w) + | otherwise = (s <> reverse (c : w), "") + startLiveMessage _ _ = pure () + +sendUpdatedLiveMessage :: ChatController -> String -> LiveMessage -> Bool -> IO ChatResponse +sendUpdatedLiveMessage cc sentMsg LiveMessage {chatName, chatItemId} live = do + let bs = encodeUtf8 $ T.pack sentMsg + cmd = UpdateLiveMessage chatName chatItemId live bs + either CRChatCmdError id <$> runExceptT (processChatCommand cmd) `runReaderT` cc runTerminalInput :: ChatTerminal -> ChatController -> IO () runTerminalInput ct cc = withChatTerm ct $ do updateInput ct receiveFromTTY cc ct -receiveFromTTY :: MonadTerminal m => ChatController -> ChatTerminal -> m () -receiveFromTTY ChatController {inputQ, activeTo} ct@ChatTerminal {termSize, termState} = - forever $ getKey >>= processKey >> withTermLock ct (updateInput ct) +receiveFromTTY :: forall m. MonadTerminal m => ChatController -> ChatTerminal -> m () +receiveFromTTY cc@ChatController {inputQ, activeTo} ct@ChatTerminal {termSize, termState, liveMessageState} = + forever $ getKey >>= liftIO . processKey >> withTermLock ct (updateInput ct) where - processKey :: MonadTerminal m => (Key, Modifiers) -> m () + processKey :: (Key, Modifiers) -> IO () processKey = \case - (EnterKey, _) -> submitInput + (EnterKey, ms) -> + when (ms == mempty || ms == altKey) $ + atomically (readTVar termState >>= submitInput ms) + >>= mapM_ (uncurry endLiveMessage) key -> atomically $ do ac <- readTVar activeTo - modifyTVar termState $ updateTermState ac (width termSize) key + live <- isJust <$> readTVar liveMessageState + modifyTVar termState $ updateTermState ac live (width termSize) key - submitInput :: MonadTerminal m => m () - submitInput = atomically $ do - ts <- readTVar termState + endLiveMessage :: String -> LiveMessage -> IO () + endLiveMessage sentMsg lm = do + kill liveThreadId + kill promptThreadId + atomically $ writeTVar liveMessageState Nothing + r <- sendUpdatedLiveMessage cc sentMsg lm False + printRespToTerminal ct cc False r + where + kill sel = deRefWeak (sel lm) >>= mapM_ killThread + + submitInput :: Modifiers -> TerminalState -> STM (Maybe (String, LiveMessage)) + submitInput ms ts = do let s = inputString ts - writeTVar termState $ ts {inputString = "", inputPosition = 0, previousInput = s} - writeTBQueue inputQ s + lm_ <- readTVar liveMessageState + case lm_ of + Just LiveMessage {chatName} + | ms == altKey -> do + writeTVar termState ts' {previousInput} + writeTBQueue inputQ $ "/live " <> chatNameStr chatName + | otherwise -> + writeTVar termState ts' {inputPrompt = "> ", previousInput} + where + previousInput = chatNameStr chatName <> " " <> s + _ + | ms == altKey -> when (isSend s) $ do + writeTVar termState ts' {previousInput = s} + writeTBQueue inputQ $ "/live " <> s + | otherwise -> do + writeTVar termState ts' {inputPrompt = "> ", previousInput = s} + writeTBQueue inputQ s + pure $ (s,) <$> lm_ + where + isSend s = length s > 1 && (head s == '@' || head s == '#') + ts' = ts {inputString = "", inputPosition = 0} -updateTermState :: ActiveTo -> Int -> (Key, Modifiers) -> TerminalState -> TerminalState -updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p} = case key of +updateTermState :: ActiveTo -> Bool -> Int -> (Key, Modifiers) -> TerminalState -> TerminalState +updateTermState ac live tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p} = case key of CharKey c | ms == mempty || ms == shiftKey -> insertCharsWithContact [c] | ms == altKey && c == 'b' -> setPosition prevWordPos @@ -102,6 +193,7 @@ updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition _ -> ts where insertCharsWithContact cs + | live = insertChars cs | null s && cs /= "@" && cs /= "#" && cs /= "/" && cs /= ">" && cs /= "\\" && cs /= "!" = insertChars $ contactPrefix <> cs | (s == ">" || s == "\\" || s == "!") && cs == " " = diff --git a/src/Simplex/Chat/Terminal/Output.hs b/src/Simplex/Chat/Terminal/Output.hs index 760f81ca39..854bc3898c 100644 --- a/src/Simplex/Chat/Terminal/Output.hs +++ b/src/Simplex/Chat/Terminal/Output.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -7,6 +8,7 @@ module Simplex.Chat.Terminal.Output where +import Control.Concurrent (ThreadId) import Control.Monad.Catch (MonadMask) import Control.Monad.Except import Control.Monad.Reader @@ -17,6 +19,7 @@ import Simplex.Chat.Messages hiding (NewChatItem (..)) import Simplex.Chat.Styled import Simplex.Chat.View import System.Console.ANSI.Types +import System.Mem.Weak (Weak) import System.Terminal import System.Terminal.Internal (LocalTerminal, Terminal, VirtualTerminal) import UnliftIO.STM @@ -25,6 +28,7 @@ data ChatTerminal = ChatTerminal { termDevice :: TerminalDevice, termState :: TVar TerminalState, termSize :: Size, + liveMessageState :: TVar (Maybe LiveMessage), nextMessageRow :: TVar Int, termLock :: TMVar () } @@ -36,6 +40,16 @@ data TerminalState = TerminalState previousInput :: String } +data LiveMessage = LiveMessage + { chatName :: ChatName, + chatItemId :: ChatItemId, + livePrompt :: Bool, + sentMsg :: String, + typedMsg :: String, + liveThreadId :: Weak ThreadId, + promptThreadId :: Weak ThreadId + } + class Terminal t => WithTerminal t where withTerm :: (MonadIO m, MonadMask m) => t -> (t -> m a) -> m a @@ -55,10 +69,11 @@ newChatTerminal t = do termSize <- withTerm t . runTerminalT $ getWindowSize let lastRow = height termSize - 1 termState <- newTVarIO mkTermState + liveMessageState <- newTVarIO Nothing termLock <- newTMVarIO () nextMessageRow <- newTVarIO lastRow -- threadDelay 500000 -- this delay is the same as timeout in getTerminalSize - return ChatTerminal {termDevice = TerminalDevice t, termState, termSize, nextMessageRow, termLock} + return ChatTerminal {termDevice = TerminalDevice t, termState, termSize, liveMessageState, nextMessageRow, termLock} mkTermState :: TerminalState mkTermState = @@ -76,16 +91,15 @@ withTermLock ChatTerminal {termLock} action = do atomically $ putTMVar termLock () runTerminalOutput :: ChatTerminal -> ChatController -> IO () -runTerminalOutput ct cc@ChatController {currentUser, outputQ, config = ChatConfig {testView}} = do +runTerminalOutput ct cc@ChatController {outputQ, showLiveItems} = do forever $ do (_, r) <- atomically $ readTBQueue outputQ case r of CRNewChatItem ci -> markChatItemRead ci CRChatItemUpdated ci -> markChatItemRead ci _ -> pure () - user <- readTVarIO currentUser - ts <- getCurrentTime - printToTerminal ct $ responseToView user testView ts r + liveItems <- readTVarIO showLiveItems + printRespToTerminal ct cc liveItems r where markChatItemRead :: AChatItem -> IO () markChatItemRead (AChatItem _ _ chat item@ChatItem {meta = CIMeta {itemStatus}}) = @@ -96,6 +110,13 @@ runTerminalOutput ct cc@ChatController {currentUser, outputQ, config = ChatConfi void $ runReaderT (runExceptT $ processChatCommand (APIChatRead chatRef (Just (itemId, itemId)))) cc _ -> pure () +printRespToTerminal :: ChatTerminal -> ChatController -> Bool -> ChatResponse -> IO () +printRespToTerminal ct cc liveItems r = do + let testV = testView $ config cc + user <- readTVarIO $ currentUser cc + ts <- getCurrentTime + printToTerminal ct $ responseToView user testV liveItems ts r + printToTerminal :: ChatTerminal -> [StyledString] -> IO () printToTerminal ct s = withChatTerm ct $ @@ -103,6 +124,9 @@ printToTerminal ct s = printMessage ct s updateInput ct +updateInputView :: ChatTerminal -> IO () +updateInputView ct = withChatTerm ct $ withTermLock ct $ updateInput ct + updateInput :: forall m. MonadTerminal m => ChatTerminal -> m () updateInput ChatTerminal {termSize = Size {height, width}, termState, nextMessageRow} = do hideCursor diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 67f2ce135a..d594c305f5 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -55,10 +55,10 @@ import System.Console.ANSI.Types type CurrentTime = UTCTime serializeChatResponse :: Maybe User -> CurrentTime -> ChatResponse -> String -serializeChatResponse user_ ts = unlines . map unStyle . responseToView user_ False ts +serializeChatResponse user_ ts = unlines . map unStyle . responseToView user_ False False ts -responseToView :: Maybe User -> Bool -> CurrentTime -> ChatResponse -> [StyledString] -responseToView user_ testView ts = \case +responseToView :: Maybe User -> Bool -> Bool -> CurrentTime -> ChatResponse -> [StyledString] +responseToView user_ testView liveItems ts = \case CRActiveUser User {profile} -> viewUserProfile $ fromLocalProfile profile CRChatStarted -> ["chat started"] CRChatRunning -> ["chat is running"] @@ -79,10 +79,10 @@ responseToView user_ testView ts = \case CRContactCode ct code -> viewContactCode ct code testView CRGroupMemberCode g m code -> viewGroupMemberCode g m code testView CRNewChatItem (AChatItem _ _ chat item) -> unmuted chat item $ viewChatItem chat item False ts - CRLastMessages chatItems -> concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts) chatItems - CRLastChatItemId itemId -> [plain $ maybe "no item" show itemId] + CRChatItems chatItems -> concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts) chatItems + CRChatItemId itemId -> [plain $ maybe "no item" show itemId] CRChatItemStatusUpdated _ -> [] - CRChatItemUpdated (AChatItem _ _ chat item) -> unmuted chat item $ viewItemUpdate chat item ts + CRChatItemUpdated (AChatItem _ _ chat item) -> unmuted chat item $ viewItemUpdate chat item liveItems ts CRChatItemDeleted (AChatItem _ _ chat deletedItem) toItem byUser timed -> unmuted chat deletedItem $ viewItemDelete chat deletedItem (isJust toItem) byUser timed ts CRChatItemDeletedNotFound Contact {localDisplayName = c} _ -> [ttyFrom $ c <> "> [deleted - original message not found]"] CRBroadcastSent mc n t -> viewSentBroadcast mc n ts t @@ -263,10 +263,7 @@ muted chat ChatItem {chatDir} = case (chat, chatDir) of _ -> False viewGroupSubscribed :: GroupInfo -> [StyledString] -viewGroupSubscribed g@GroupInfo {membership} = - [incognito <> ttyFullGroup g <> ": connected to server(s)"] - where - incognito = if memberIncognito membership then incognitoPrefix else "" +viewGroupSubscribed g = [membershipIncognito g <> ttyFullGroup g <> ": connected to server(s)"] showSMPServer :: SMPServer -> String showSMPServer = B.unpack . strEncode . host @@ -279,7 +276,7 @@ viewChatItem chat ChatItem {chatDir, meta = meta@CIMeta {itemDeleted}, content, withItemDeleted <$> case chat of DirectChat c -> case chatDir of CIDirectSnd -> case content of - CISndMsgContent mc -> withSndFile to $ sndMsg to quote mc + CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc CISndGroupEvent {} -> showSndItemProhibited to _ -> showSndItem to where @@ -290,12 +287,12 @@ viewChatItem chat ChatItem {chatDir, meta = meta@CIMeta {itemDeleted}, content, CIRcvGroupEvent {} -> showRcvItemProhibited from _ -> showRcvItem from where - from = ttyFromContact' c + from = ttyFromContact c where quote = maybe [] (directQuote chatDir) quotedItem GroupChat g -> case chatDir of CIGroupSnd -> case content of - CISndMsgContent mc -> withSndFile to $ sndMsg to quote mc + CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc CISndGroupInvitation {} -> showSndItemProhibited to _ -> showSndItem to where @@ -306,7 +303,7 @@ viewChatItem chat ChatItem {chatDir, meta = meta@CIMeta {itemDeleted}, content, CIRcvGroupInvitation {} -> showRcvItemProhibited from _ -> showRcvItem from where - from = ttyFromGroup' g m + from = ttyFromGroup g m where quote = maybe [] (groupQuote g) quotedItem _ -> [] @@ -322,43 +319,61 @@ viewChatItem chat ChatItem {chatDir, meta = meta@CIMeta {itemDeleted}, content, ("", Just CIFile {fileName}, _) -> view dir quote (MCText $ T.pack fileName) ts meta _ -> view dir quote mc ts meta showSndItem to = showItem $ sentWithTime_ ts [to <> plainContent content] meta - showRcvItem from = showItem $ receivedWithTime_ ts from [] meta [plainContent content] + showRcvItem from = showItem $ receivedWithTime_ ts from [] meta [plainContent content] False showSndItemProhibited to = showItem $ sentWithTime_ ts [to <> plainContent content <> " " <> prohibited] meta - showRcvItemProhibited from = showItem $ receivedWithTime_ ts from [] meta [plainContent content <> " " <> prohibited] + showRcvItemProhibited from = showItem $ receivedWithTime_ ts from [] meta [plainContent content <> " " <> prohibited] False showItem ss = if doShow then ss else [] plainContent = plain . ciContentToText prohibited = styled (colored Red) ("[unexpected chat item created, please report to developers]" :: String) -viewItemUpdate :: MsgDirectionI d => ChatInfo c -> ChatItem c d -> CurrentTime -> [StyledString] -viewItemUpdate chat ChatItem {chatDir, meta, content, quotedItem} ts = case chat of - DirectChat Contact {localDisplayName = c} -> case chatDir of +viewItemUpdate :: MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> [StyledString] +viewItemUpdate chat ChatItem {chatDir, meta = meta@CIMeta {itemEdited, itemLive}, content, quotedItem} liveItems ts = case chat of + DirectChat c -> case chatDir of CIDirectRcv -> case content of - CIRcvMsgContent mc -> viewReceivedMessage from quote mc ts meta + CIRcvMsgContent mc + | itemLive == Just True && not liveItems -> [] + | otherwise -> viewReceivedUpdatedMessage from quote mc ts meta _ -> [] where - from = ttyFromContactEdited c - quote = maybe [] (directQuote chatDir) quotedItem - CIDirectSnd -> ["message updated"] + from = if itemEdited then ttyFromContactEdited c else ttyFromContact c + CIDirectSnd -> case content of + CISndMsgContent mc -> hideLive meta $ viewSentMessage to quote mc ts meta + _ -> [] + where + to = if itemEdited then ttyToContactEdited' c else ttyToContact' c + where + quote = maybe [] (directQuote chatDir) quotedItem GroupChat g -> case chatDir of - CIGroupRcv GroupMember {localDisplayName = m} -> case content of - CIRcvMsgContent mc -> viewReceivedMessage from quote mc ts meta + CIGroupRcv m -> case content of + CIRcvMsgContent mc + | itemLive == Just True && not liveItems -> [] + | otherwise -> viewReceivedUpdatedMessage from quote mc ts meta _ -> [] where - from = ttyFromGroupEdited g m - quote = maybe [] (groupQuote g) quotedItem - CIGroupSnd -> ["message updated"] + from = if itemEdited then ttyFromGroupEdited g m else ttyFromGroup g m + CIGroupSnd -> case content of + CISndMsgContent mc -> hideLive meta $ viewSentMessage to quote mc ts meta + _ -> [] + where + to = if itemEdited then ttyToGroupEdited g else ttyToGroup g + where + quote = maybe [] (groupQuote g) quotedItem _ -> [] +hideLive :: CIMeta d -> [StyledString] -> [StyledString] +hideLive CIMeta {itemLive = Just True} _ = [] +hideLive _ s = s + viewItemDelete :: ChatInfo c -> ChatItem c d -> Bool -> Bool -> Bool -> CurrentTime -> [StyledString] viewItemDelete chat ChatItem {chatDir, meta, content = deletedContent} markedDeleted byUser timed ts | timed = [] | byUser = if markedDeleted then ["message marked deleted"] else ["message deleted"] | otherwise = case chat of - DirectChat Contact {localDisplayName = c} -> case (chatDir, deletedContent) of + DirectChat c -> case (chatDir, deletedContent) of (CIDirectRcv, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromContactDeleted c markedDeleted) [] mc ts meta _ -> prohibited GroupChat g -> case (chatDir, deletedContent) of - (CIGroupRcv GroupMember {localDisplayName = m}, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromGroupDeleted g m markedDeleted) [] mc ts meta + (CIGroupRcv m, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromGroupDeleted g m markedDeleted) [] mc ts meta _ -> prohibited _ -> prohibited where @@ -387,7 +402,7 @@ msgPreview = msgPlain . preview . msgContentText | otherwise = T.take 120 t <> "..." viewRcvIntegrityError :: StyledString -> MsgErrorType -> CurrentTime -> CIMeta 'MDRcv -> [StyledString] -viewRcvIntegrityError from msgErr ts meta = receivedWithTime_ ts from [] meta $ viewMsgIntegrityError msgErr +viewRcvIntegrityError from msgErr ts meta = receivedWithTime_ ts from [] meta (viewMsgIntegrityError msgErr) False viewMsgIntegrityError :: MsgErrorType -> [StyledString] viewMsgIntegrityError err = msgError $ case err of @@ -427,8 +442,7 @@ viewChatCleared (AChatInfo _ chatInfo) = case chatInfo of viewContactsList :: [Contact] -> [StyledString] viewContactsList = let ldn = T.toLower . (localDisplayName :: Contact -> ContactName) - incognito ct = if contactConnIncognito ct then incognitoPrefix else "" - in map (\ct -> incognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn + in map (\ct -> ctIncognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn where muted' Contact {chatSettings, localDisplayName = ldn} | enableNtfs chatSettings = "" @@ -563,8 +577,7 @@ viewGroupMembers :: Group -> [StyledString] viewGroupMembers (Group GroupInfo {membership} members) = map groupMember . filter (not . removedOrLeft) $ membership : members where removedOrLeft m = let s = memberStatus m in s == GSMemRemoved || s == GSMemLeft - groupMember m = incognito m <> ttyFullMember m <> ": " <> role m <> ", " <> category m <> status m - incognito m = if memberIncognito m then incognitoPrefix else "" + groupMember m = memIncognito m <> ttyFullMember m <> ": " <> role m <> ", " <> category m <> status m role m = plain . strEncode $ memberRole (m :: GroupMember) category m = case memberCategory m of GCUserMember -> "you, " @@ -603,9 +616,8 @@ viewGroupsList gs = map groupSS $ sortOn ldn_ gs groupSS g@GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership, chatSettings} = case memberStatus membership of GSMemInvited -> groupInvitation' g - s -> incognito <> ttyGroup ldn <> optFullName ldn fullName <> viewMemberStatus s + s -> membershipIncognito g <> ttyGroup ldn <> optFullName ldn fullName <> viewMemberStatus s where - incognito = if memberIncognito membership then incognitoPrefix else "" viewMemberStatus = \case GSMemRemoved -> delete "you are removed" GSMemLeft -> delete "you left" @@ -880,13 +892,27 @@ viewContactUpdated fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName' viewReceivedMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta d -> [StyledString] -viewReceivedMessage from quote mc ts meta = receivedWithTime_ ts from quote meta (ttyMsgContent mc) +viewReceivedMessage = viewReceivedMessage_ False -receivedWithTime_ :: CurrentTime -> StyledString -> [StyledString] -> CIMeta d -> [StyledString] -> [StyledString] -receivedWithTime_ ts from quote CIMeta {localItemTs} styledMsg = do - prependFirst (ttyMsgTime ts localItemTs <> " " <> from) (quote <> prependFirst indent styledMsg) +viewReceivedUpdatedMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta d -> [StyledString] +viewReceivedUpdatedMessage = viewReceivedMessage_ True + +viewReceivedMessage_ :: Bool -> StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta d -> [StyledString] +viewReceivedMessage_ updated from quote mc ts meta = receivedWithTime_ ts from quote meta (ttyMsgContent mc) updated + +receivedWithTime_ :: CurrentTime -> StyledString -> [StyledString] -> CIMeta d -> [StyledString] -> Bool -> [StyledString] +receivedWithTime_ ts from quote CIMeta {localItemTs, itemId, itemEdited, itemDeleted, itemLive} styledMsg updated = do + prependFirst (ttyMsgTime ts localItemTs <> " " <> from) (quote <> prependFirst (indent <> live) styledMsg) where indent = if null quote then "" else " " + live + | itemEdited || itemDeleted = "" + | otherwise = case itemLive of + Just True + | updated -> ttyFrom "[LIVE] " + | otherwise -> ttyFrom "[LIVE started]" <> " use " <> highlight' ("/show [on/off/" <> show itemId <> "] ") + Just False -> ttyFrom "[LIVE ended] " + _ -> "" ttyMsgTime :: CurrentTime -> ZonedTime -> StyledString ttyMsgTime ts t = @@ -900,9 +926,15 @@ ttyMsgTime ts t = in styleTime $ formatTime defaultTimeLocale fmt localTime viewSentMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta d -> [StyledString] -viewSentMessage to quote mc ts = sentWithTime_ ts (prependFirst to $ quote <> prependFirst indent (ttyMsgContent mc)) +viewSentMessage to quote mc ts meta@CIMeta {itemEdited, itemDeleted, itemLive} = sentWithTime_ ts (prependFirst to $ quote <> prependFirst (indent <> live) (ttyMsgContent mc)) meta where indent = if null quote then "" else " " + live + | itemEdited || itemDeleted = "" + | otherwise = case itemLive of + Just True -> ttyTo "[LIVE started] " + Just False -> ttyTo "[LIVE] " + _ -> "" viewSentBroadcast :: MsgContent -> Int -> CurrentTime -> ZonedTime -> [StyledString] viewSentBroadcast mc n ts t = prependFirst (highlight' "/feed" <> " (" <> sShow n <> ") " <> ttyMsgTime ts t <> " ") (ttyMsgContent mc) @@ -949,7 +981,7 @@ sndFile :: SndFileTransfer -> StyledString sndFile SndFileTransfer {fileId, fileName} = fileTransferStr fileId fileName viewReceivedFileInvitation :: StyledString -> CIFile d -> CurrentTime -> CIMeta d -> [StyledString] -viewReceivedFileInvitation from file ts meta = receivedWithTime_ ts from [] meta (receivedFileInvitation_ file) +viewReceivedFileInvitation from file ts meta = receivedWithTime_ ts from [] meta (receivedFileInvitation_ file) False receivedFileInvitation_ :: CIFile d -> [StyledString] receivedFileInvitation_ CIFile {fileId, fileName, fileSize, fileStatus} = @@ -1211,22 +1243,13 @@ ttyFullName :: ContactName -> Text -> StyledString ttyFullName c fullName = ttyContact c <> optFullName c fullName ttyToContact :: ContactName -> StyledString -ttyToContact c = styled (colored Cyan) $ "@" <> c <> " " - -ttyFromContact :: ContactName -> StyledString -ttyFromContact c = ttyFrom $ c <> "> " - -ttyFromContactEdited :: ContactName -> StyledString -ttyFromContactEdited c = ttyFrom $ c <> "> [edited] " - -ttyFromContactDeleted :: ContactName -> Bool -> StyledString -ttyFromContactDeleted c markedDeleted - | markedDeleted = ttyFrom $ c <> "> [marked deleted] " - | otherwise = ttyFrom $ c <> "> [deleted] " +ttyToContact c = ttyTo $ "@" <> c <> " " ttyToContact' :: Contact -> StyledString -ttyToContact' Contact {localDisplayName = c, activeConn = Connection {customUserProfileId}} = - maybe "" (const incognitoPrefix) customUserProfileId <> ttyToContact c +ttyToContact' ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyToContact c + +ttyToContactEdited' :: Contact -> StyledString +ttyToContactEdited' ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyTo ("@" <> c <> " [edited] ") ttyQuotedContact :: Contact -> StyledString ttyQuotedContact Contact {localDisplayName = c} = ttyFrom $ c <> ">" @@ -1235,9 +1258,17 @@ ttyQuotedMember :: Maybe GroupMember -> StyledString ttyQuotedMember (Just GroupMember {localDisplayName = c}) = "> " <> ttyFrom c ttyQuotedMember _ = "> " <> ttyFrom "?" -ttyFromContact' :: Contact -> StyledString -ttyFromContact' Contact {localDisplayName = c, activeConn = Connection {customUserProfileId}} = - maybe "" (const incognitoPrefix) customUserProfileId <> ttyFromContact c +ttyFromContact :: Contact -> StyledString +ttyFromContact ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (c <> "> ") + +ttyFromContactEdited :: Contact -> StyledString +ttyFromContactEdited ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (c <> "> [edited] ") + +ttyFromContactDeleted :: Contact -> Bool -> StyledString +ttyFromContactDeleted ct@Contact {localDisplayName = c} markedDeleted = + ctIncognito ct <> ttyFrom (c <> "> " <> deleted) + where + deleted = if markedDeleted then "[marked deleted] " else "[deleted] " ttyGroup :: GroupName -> StyledString ttyGroup g = styled (colored Blue) $ "#" <> g @@ -1254,27 +1285,35 @@ ttyFullGroup :: GroupInfo -> StyledString ttyFullGroup GroupInfo {localDisplayName = g, groupProfile = GroupProfile {fullName}} = ttyGroup g <> optFullName g fullName -ttyFromGroup :: GroupInfo -> ContactName -> StyledString -ttyFromGroup GroupInfo {localDisplayName = g} c = ttyFrom $ "#" <> g <> " " <> c <> "> " +ttyFromGroup :: GroupInfo -> GroupMember -> StyledString +ttyFromGroup g m = membershipIncognito g <> ttyFrom (fromGroup_ g m) -ttyFromGroupEdited :: GroupInfo -> ContactName -> StyledString -ttyFromGroupEdited GroupInfo {localDisplayName = g} c = ttyFrom $ "#" <> g <> " " <> c <> "> [edited] " +ttyFromGroupEdited :: GroupInfo -> GroupMember -> StyledString +ttyFromGroupEdited g m = membershipIncognito g <> ttyFrom (fromGroup_ g m <> "[edited] ") -ttyFromGroupDeleted :: GroupInfo -> ContactName -> Bool -> StyledString -ttyFromGroupDeleted GroupInfo {localDisplayName = g} c markedDeleted - | markedDeleted = ttyFrom $ "#" <> g <> " " <> c <> "> [marked deleted] " - | otherwise = ttyFrom $ "#" <> g <> " " <> c <> "> [deleted] " +ttyFromGroupDeleted :: GroupInfo -> GroupMember -> Bool -> StyledString +ttyFromGroupDeleted g m markedDeleted = + membershipIncognito g <> ttyFrom (fromGroup_ g m <> deleted) + where + deleted = if markedDeleted then "[marked deleted] " else "[deleted] " + +fromGroup_ :: GroupInfo -> GroupMember -> Text +fromGroup_ GroupInfo {localDisplayName = g} GroupMember {localDisplayName = m} = + "#" <> g <> " " <> m <> "> " ttyFrom :: Text -> StyledString ttyFrom = styled $ colored Yellow -ttyFromGroup' :: GroupInfo -> GroupMember -> StyledString -ttyFromGroup' g@GroupInfo {membership} GroupMember {localDisplayName = m} = - (if memberIncognito membership then incognitoPrefix else "") <> ttyFromGroup g m +ttyTo :: Text -> StyledString +ttyTo = styled $ colored Cyan ttyToGroup :: GroupInfo -> StyledString -ttyToGroup GroupInfo {localDisplayName = g, membership} = - (if memberIncognito membership then incognitoPrefix else "") <> styled (colored Cyan) ("#" <> g <> " ") +ttyToGroup g@GroupInfo {localDisplayName = n} = + membershipIncognito g <> ttyTo ("#" <> n <> " ") + +ttyToGroupEdited :: GroupInfo -> StyledString +ttyToGroupEdited g@GroupInfo {localDisplayName = n} = + membershipIncognito g <> ttyTo ("#" <> n <> " [edited] ") ttyFilePath :: FilePath -> StyledString ttyFilePath = plain @@ -1282,6 +1321,15 @@ ttyFilePath = plain optFullName :: ContactName -> Text -> StyledString optFullName localDisplayName fullName = plain $ optionalFullName localDisplayName fullName +ctIncognito :: Contact -> StyledString +ctIncognito ct = if contactConnIncognito ct then incognitoPrefix else "" + +membershipIncognito :: GroupInfo -> StyledString +membershipIncognito = memIncognito . membership + +memIncognito :: GroupMember -> StyledString +memIncognito m = if memberIncognito m then incognitoPrefix else "" + incognitoPrefix :: StyledString incognitoPrefix = styleIncognito' "i " diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 0260b73531..c561449ec0 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -377,7 +377,8 @@ testDirectMessageUpdate = alice #$> ("/_get chat @2 count=100", chat', chatFeatures' <> [((1, "hello 🙂"), Nothing), ((0, "hi alice"), Just (1, "hello 🙂"))]) bob #$> ("/_get chat @2 count=100", chat', chatFeatures' <> [((0, "hello 🙂"), Nothing), ((1, "hi alice"), Just (0, "hello 🙂"))]) - alice #$> ("/_update item @2 " <> itemId 1 <> " text hey 👋", id, "message updated") + alice ##> ("/_update item @2 " <> itemId 1 <> " text hey 👋") + alice <# "@bob [edited] hey 👋" bob <# "alice> [edited] hey 👋" alice #$> ("/_get chat @2 count=100", chat', chatFeatures' <> [((1, "hey 👋"), Nothing), ((0, "hi alice"), Just (1, "hello 🙂"))]) @@ -393,7 +394,8 @@ testDirectMessageUpdate = alice #$> ("/_get chat @2 count=100", chat', chatFeatures' <> [((1, "hey 👋"), Nothing), ((0, "hi alice"), Just (1, "hello 🙂")), ((0, "hey alice"), Just (1, "hey 👋"))]) bob #$> ("/_get chat @2 count=100", chat', chatFeatures' <> [((0, "hey 👋"), Nothing), ((1, "hi alice"), Just (0, "hello 🙂")), ((1, "hey alice"), Just (0, "hey 👋"))]) - alice #$> ("/_update item @2 " <> itemId 1 <> " text greetings 🤝", id, "message updated") + alice ##> ("/_update item @2 " <> itemId 1 <> " text greetings 🤝") + alice <# "@bob [edited] greetings 🤝" bob <# "alice> [edited] greetings 🤝" alice #$> ("/_update item @2 " <> itemId 2 <> " text updating bob's message", id, "cannot update this item") @@ -401,11 +403,15 @@ testDirectMessageUpdate = alice #$> ("/_get chat @2 count=100", chat', chatFeatures' <> [((1, "greetings 🤝"), Nothing), ((0, "hi alice"), Just (1, "hello 🙂")), ((0, "hey alice"), Just (1, "hey 👋"))]) bob #$> ("/_get chat @2 count=100", chat', chatFeatures' <> [((0, "greetings 🤝"), Nothing), ((1, "hi alice"), Just (0, "hello 🙂")), ((1, "hey alice"), Just (0, "hey 👋"))]) - bob #$> ("/_update item @2 " <> itemId 2 <> " text hey Alice", id, "message updated") + bob ##> ("/_update item @2 " <> itemId 2 <> " text hey Alice") + bob <# "@alice [edited] > hello 🙂" + bob <## " hey Alice" alice <# "bob> [edited] > hello 🙂" alice <## " hey Alice" - bob #$> ("/_update item @2 " <> itemId 3 <> " text greetings Alice", id, "message updated") + bob ##> ("/_update item @2 " <> itemId 3 <> " text greetings Alice") + bob <# "@alice [edited] > hey 👋" + bob <## " greetings Alice" alice <# "bob> [edited] > hey 👋" alice <## " greetings Alice" @@ -437,7 +443,9 @@ testDirectMessageDelete = alice #$> ("/_get chat @2 count=100", chat, chatFeatures) -- alice: msg id 1 - bob #$> ("/_update item @2 " <> itemId 2 <> " text hey alice", id, "message updated") + bob ##> ("/_update item @2 " <> itemId 2 <> " text hey alice") + bob <# "@alice [edited] > hello 🙂" + bob <## " hey alice" alice <# "bob> [edited] hey alice" alice @@@ [("@bob", "hey alice")] alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "hey alice")]) @@ -1222,7 +1230,8 @@ testGroupMessageUpdate = (cath <# "#team alice> hello!") msgItemId1 <- lastItemId alice - alice #$> ("/_update item #1 " <> msgItemId1 <> " text hey 👋", id, "message updated") + alice ##> ("/_update item #1 " <> msgItemId1 <> " text hey 👋") + alice <# "#team [edited] hey 👋" concurrently_ (bob <# "#team alice> [edited] hey 👋") (cath <# "#team alice> [edited] hey 👋") @@ -1250,7 +1259,8 @@ testGroupMessageUpdate = bob #$> ("/_get chat #1 count=2", chat', [((0, "hey 👋"), Nothing), ((1, "hi alice"), Just (0, "hey 👋"))]) cath #$> ("/_get chat #1 count=2", chat', [((0, "hey 👋"), Nothing), ((0, "hi alice"), Just (0, "hey 👋"))]) - alice #$> ("/_update item #1 " <> msgItemId1 <> " text greetings 🤝", id, "message updated") + alice ##> ("/_update item #1 " <> msgItemId1 <> " text greetings 🤝") + alice <# "#team [edited] greetings 🤝" concurrently_ (bob <# "#team alice> [edited] greetings 🤝") (cath <# "#team alice> [edited] greetings 🤝") @@ -1323,7 +1333,9 @@ testGroupMessageDelete = -- alice: msg id 5 msgItemId3 <- lastItemId bob - bob #$> ("/_update item #1 " <> msgItemId3 <> " text hi alice", id, "message updated") + bob ##> ("/_update item #1 " <> msgItemId3 <> " text hi alice") + bob <# "#team [edited] > alice hello!" + bob <## " hi alice" concurrently_ (alice <# "#team bob> [edited] hi alice") ( do @@ -3993,24 +4005,17 @@ testNegotiateCall = bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "incoming call: accepted")]) alice <## "bob accepted your WebRTC video call (e2e encrypted)" repeatM_ 3 $ getTermLine alice - alice <## "message updated" -- call chat item updated alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "outgoing call: accepted")]) -- alice confirms call by sending WebRTC answer alice ##> ("/_call answer @2 " <> serialize testWebRTCSession) - alice - <### [ "ok", - "message updated" - ] + alice <## "ok" alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "outgoing call: connecting...")]) bob <## "alice continued the WebRTC call" repeatM_ 3 $ getTermLine bob bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "incoming call: connecting...")]) -- participants can update calls as connected alice ##> "/_call status @2 connected" - alice - <### [ "ok", - "message updated" - ] + alice <## "ok" alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "outgoing call: in progress (00:00)")]) bob ##> "/_call status @2 connected" bob <## "ok" @@ -4020,7 +4025,6 @@ testNegotiateCall = bob <## "ok" bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "incoming call: ended (00:00)")]) alice <## "call with bob ended" - alice <## "message updated" alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "outgoing call: ended (00:00)")]) testMaintenanceMode :: IO ()