From 739990c732e431a3fd8841b69c7e5dc55d7e34ee Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 21 Feb 2022 12:05:00 +0000 Subject: [PATCH] terminal: make input responsible for echo to keep commands synchronous (as in mobile) and avoid echo delays (#343) * terminal: make input responsible for echo to keep commands synchronous (as in mobile) and avoid echo delays * use echo Co-authored-by: Efim Poberezkin <8711996+efim-poberezkin@users.noreply.github.com> Co-authored-by: Efim Poberezkin <8711996+efim-poberezkin@users.noreply.github.com> --- src/Simplex/Chat/Mobile.hs | 1 - src/Simplex/Chat/Terminal/Input.hs | 24 +++++++- src/Simplex/Chat/Terminal/Output.hs | 2 +- src/Simplex/Chat/View.hs | 96 ++++++++++++++--------------- tests/ChatTests.hs | 1 - 5 files changed, 68 insertions(+), 56 deletions(-) diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 1d1c94a1fa..577cdf8ca3 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index e401b4b8c0..833911acd9 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -5,15 +5,19 @@ module Simplex.Chat.Terminal.Input where -import Control.Monad.IO.Unlift +import Control.Monad.Except import Control.Monad.Reader +import qualified Data.ByteString.Char8 as B +import Data.Char (isSpace) import Data.List (dropWhileEnd) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Simplex.Chat import Simplex.Chat.Controller +import Simplex.Chat.Styled import Simplex.Chat.Terminal.Output import Simplex.Chat.View +import Simplex.Messaging.Parsers (parseAll) import System.Exit (exitSuccess) import System.Terminal hiding (insertChars) import UnliftIO.STM @@ -28,9 +32,23 @@ getKey = runInputLoop :: ChatTerminal -> ChatController -> IO () runInputLoop ct cc = forever $ do s <- atomically . readTBQueue $ inputQ cc - r <- runReaderT (execChatCommand . encodeUtf8 $ T.pack s) cc + let bs = encodeUtf8 $ T.pack s + cmd = parseAll chatCommandP $ B.dropWhileEnd isSpace bs + unless (isMessage cmd) $ echo s + r <- runReaderT (execChatCommand bs) cc + case r of + CRChatCmdError _ -> when (isMessage cmd) $ echo s + _ -> pure () let testV = testView $ config cc - printToTerminal ct $ responseToView s testV r + printToTerminal ct $ responseToView testV r + where + echo s = printToTerminal ct [plain s] + isMessage = \case + Right SendMessage {} -> True + Right SendGroupMessage {} -> True + Right SendFile {} -> True + Right SendGroupFile {} -> True + _ -> False runTerminalInput :: ChatTerminal -> ChatController -> IO () runTerminalInput ct cc = withChatTerm ct $ do diff --git a/src/Simplex/Chat/Terminal/Output.hs b/src/Simplex/Chat/Terminal/Output.hs index 79526e624f..d793266af3 100644 --- a/src/Simplex/Chat/Terminal/Output.hs +++ b/src/Simplex/Chat/Terminal/Output.hs @@ -76,7 +76,7 @@ runTerminalOutput :: ChatTerminal -> ChatController -> IO () runTerminalOutput ct cc = do let testV = testView $ config cc forever $ - atomically (readTBQueue $ outputQ cc) >>= printToTerminal ct . responseToView "" testV . snd + atomically (readTBQueue $ outputQ cc) >>= printToTerminal ct . responseToView testV . snd printToTerminal :: ChatTerminal -> [StyledString] -> IO () printToTerminal ct s = diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index dc77335354..1201c54758 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -30,58 +30,58 @@ import qualified Simplex.Messaging.Protocol as SMP import System.Console.ANSI.Types serializeChatResponse :: ChatResponse -> String -serializeChatResponse = unlines . map unStyle . responseToView "" False +serializeChatResponse = unlines . map unStyle . responseToView False -responseToView :: String -> Bool -> ChatResponse -> [StyledString] -responseToView cmd testView = \case - CRActiveUser User {profile} -> r $ viewUserProfile profile - CRChatStarted -> r ["chat started"] - CRApiChats chats -> r $ if testView then testViewChats chats else [sShow chats] - CRApiChat chat -> r $ if testView then testViewChat chat else [sShow chat] +responseToView :: Bool -> ChatResponse -> [StyledString] +responseToView testView = \case + CRActiveUser User {profile} -> viewUserProfile profile + CRChatStarted -> ["chat started"] + CRApiChats chats -> if testView then testViewChats chats else [sShow chats] + CRApiChat chat -> if testView then testViewChat chat else [sShow chat] CRNewChatItem (AChatItem _ _ chat item) -> viewChatItem chat item CRChatItemUpdated _ -> [] CRMsgIntegrityError mErr -> viewMsgIntegrityError mErr - CRCmdAccepted _ -> r [] - CRCmdOk -> r ["ok"] + CRCmdAccepted _ -> [] + CRCmdOk -> ["ok"] CRChatHelp section -> case section of - HSMain -> r chatHelpInfo - HSFiles -> r filesHelpInfo - HSGroups -> r groupsHelpInfo - HSMyAddress -> r myAddressHelpInfo - HSMarkdown -> r markdownInfo - CRWelcome user -> r $ chatWelcome user - CRContactsList cs -> r $ viewContactsList cs - CRUserContactLink cReqUri _ -> r $ connReqContact_ "Your chat address:" cReqUri - CRUserContactLinkUpdated _ autoAccept -> r ["auto_accept " <> if autoAccept then "on" else "off"] - CRContactRequestRejected UserContactRequest {localDisplayName = c} -> r [ttyContact c <> ": contact request rejected"] - CRGroupCreated g -> r $ viewGroupCreated g - CRGroupMembers g -> r $ viewGroupMembers g - CRGroupsList gs -> r $ viewGroupsList gs - CRSentGroupInvitation g c -> r ["invitation to join the group " <> ttyGroup' g <> " sent to " <> ttyContact' c] - CRFileTransferStatus ftStatus -> r $ viewFileTransferStatus ftStatus - CRUserProfile p -> r $ viewUserProfile p - CRUserProfileNoChange -> r ["user profile did not change"] - CRVersionInfo _ -> r [plain versionStr, plain updateStr] - CRChatCmdError e -> r $ viewChatError e - CRInvitation cReq -> r' $ viewConnReqInvitation cReq - CRSentConfirmation -> r' ["confirmation sent!"] - CRSentInvitation -> r' ["connection request sent!"] - CRContactDeleted c -> r' [ttyContact' c <> ": contact is deleted"] - CRAcceptingContactRequest c -> r [ttyFullContact c <> ": accepting contact request..."] - CRContactAlreadyExists c -> r [ttyFullContact c <> ": contact already exists"] - CRContactRequestAlreadyAccepted c -> r' [ttyFullContact c <> ": sent you a duplicate contact request, but you are already connected, no action needed"] - CRUserContactLinkCreated cReq -> r' $ connReqContact_ "Your new chat address is created!" cReq - CRUserContactLinkDeleted -> r' viewUserContactLinkDeleted - CRUserAcceptedGroupSent _g -> r' [] -- [ttyGroup' g <> ": joining the group..."] - CRUserDeletedMember g m -> r' [ttyGroup' g <> ": you removed " <> ttyMember m <> " from the group"] - CRLeftMemberUser g -> r' $ [ttyGroup' g <> ": you left the group"] <> groupPreserved g - CRGroupDeletedUser g -> r' [ttyGroup' g <> ": you deleted the group"] + HSMain -> chatHelpInfo + HSFiles -> filesHelpInfo + HSGroups -> groupsHelpInfo + HSMyAddress -> myAddressHelpInfo + HSMarkdown -> markdownInfo + CRWelcome user -> chatWelcome user + CRContactsList cs -> viewContactsList cs + CRUserContactLink cReqUri _ -> connReqContact_ "Your chat address:" cReqUri + CRUserContactLinkUpdated _ autoAccept -> ["auto_accept " <> if autoAccept then "on" else "off"] + CRContactRequestRejected UserContactRequest {localDisplayName = c} -> [ttyContact c <> ": contact request rejected"] + CRGroupCreated g -> viewGroupCreated g + CRGroupMembers g -> viewGroupMembers g + CRGroupsList gs -> viewGroupsList gs + CRSentGroupInvitation g c -> ["invitation to join the group " <> ttyGroup' g <> " sent to " <> ttyContact' c] + CRFileTransferStatus ftStatus -> viewFileTransferStatus ftStatus + CRUserProfile p -> viewUserProfile p + CRUserProfileNoChange -> ["user profile did not change"] + CRVersionInfo _ -> [plain versionStr, plain updateStr] + CRChatCmdError e -> viewChatError e + CRInvitation cReq -> viewConnReqInvitation cReq + CRSentConfirmation -> ["confirmation sent!"] + CRSentInvitation -> ["connection request sent!"] + CRContactDeleted c -> [ttyContact' c <> ": contact is deleted"] + CRAcceptingContactRequest c -> [ttyFullContact c <> ": accepting contact request..."] + CRContactAlreadyExists c -> [ttyFullContact c <> ": contact already exists"] + CRContactRequestAlreadyAccepted c -> [ttyFullContact c <> ": sent you a duplicate contact request, but you are already connected, no action needed"] + CRUserContactLinkCreated cReq -> connReqContact_ "Your new chat address is created!" cReq + CRUserContactLinkDeleted -> viewUserContactLinkDeleted + CRUserAcceptedGroupSent _g -> [] -- [ttyGroup' g <> ": joining the group..."] + CRUserDeletedMember g m -> [ttyGroup' g <> ": you removed " <> ttyMember m <> " from the group"] + CRLeftMemberUser g -> [ttyGroup' g <> ": you left the group"] <> groupPreserved g + CRGroupDeletedUser g -> [ttyGroup' g <> ": you deleted the group"] CRRcvFileAccepted RcvFileTransfer {fileId, senderDisplayName = c} filePath -> - r' ["saving file " <> sShow fileId <> " from " <> ttyContact c <> " to " <> plain filePath] - CRRcvFileAcceptedSndCancelled ft -> r' $ viewRcvFileSndCancelled ft - CRSndGroupFileCancelled fts -> r' $ viewSndGroupFileCancelled fts - CRRcvFileCancelled ft -> r' $ receivingFile_ "cancelled" ft - CRUserProfileUpdated p p' -> r' $ viewUserProfileUpdated p p' + ["saving file " <> sShow fileId <> " from " <> ttyContact c <> " to " <> plain filePath] + CRRcvFileAcceptedSndCancelled ft -> viewRcvFileSndCancelled ft + CRSndGroupFileCancelled fts -> viewSndGroupFileCancelled fts + CRRcvFileCancelled ft -> receivingFile_ "cancelled" ft + CRUserProfileUpdated p p' -> viewUserProfileUpdated p p' CRContactUpdated c c' -> viewContactUpdated c c' CRContactsMerged intoCt mergedCt -> viewContactsMerged intoCt mergedCt CRReceivedContactRequest UserContactRequest {localDisplayName = c, profile} -> viewReceivedContactRequest c profile @@ -123,10 +123,6 @@ responseToView cmd testView = \case CRMessageError prefix err -> [plain prefix <> ": " <> plain err] CRChatError e -> viewChatError e where - r = (plain cmd :) - -- this function should be `r` for "synchronous", `id` for "asynchronous" command responses - r' = r - -- r' = id testViewChats :: [AChat] -> [StyledString] testViewChats chats = [sShow $ map toChatView chats] where diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index f10bba0d82..9e7ecb1404 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -744,7 +744,6 @@ testUserContactLinkAutoAccept = cath ##> ("/c " <> cLink) cath <## "connection request sent!" - alice <## "" alice <## "cath (Catherine): accepting contact request..." concurrently_ (cath <## "alice (Alice): contact is connected")