blade/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2024-12-17 17:20:21 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

terminal: support live messages (#1597)

Browse Source 
* 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>
This commit is contained in:
Evgeny Poberezkin
2022-12-19 11:16:50 +00:00
committed by GitHub
parent 5dab099b5c
commit 86271fe109
8 changed files with 357 additions and 140 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/Terminal/Input.hs
+114 -22
View File
@@ -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 == " " =
src/Simplex/Chat/Terminal/Output.hs
+29 -5
View File
@@ -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