mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-06-28 20:29:53 +00:00
a5db36469d
* wip
* wip
* test
* mute
* tests
* simplify (only bool flag)
* re-encrypt file
* tests
* more tests (wip)
* fix relative paths, refactor
* more tests
* more locks
* fix, tests
* more tests
* rework (revert from bool to ids)
* update schema
* more tests
* add to info
* ForwardedMsg container
* Revert "ForwardedMsg container"
This reverts commit bb57f12151.
* parser
* more tests
* rework api
* more locks
* test
* move
* remove from
* view
* prohibit editing
* item info view
---------
Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
396 lines
18 KiB
Haskell
396 lines
18 KiB
Haskell
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Simplex.Chat.Terminal.Input where
|
|
|
|
import Control.Applicative (optional, (<|>))
|
|
import Control.Concurrent (forkFinally, forkIO, killThread, mkWeakThreadId, threadDelay)
|
|
import Control.Monad
|
|
import Control.Monad.Except
|
|
import Control.Monad.Reader
|
|
import qualified Data.Attoparsec.ByteString.Char8 as A
|
|
import Data.Bifunctor (second)
|
|
import qualified Data.ByteString.Char8 as B
|
|
import Data.Char (isAlpha, isAlphaNum, isAscii)
|
|
import Data.Either (fromRight)
|
|
import Data.List (dropWhileEnd, foldl', sort)
|
|
import Data.Maybe (isJust, isNothing)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Data.Text.Encoding (encodeUtf8)
|
|
import Database.SQLite.Simple (Only (..))
|
|
import qualified Database.SQLite.Simple as SQL
|
|
import Database.SQLite.Simple.QQ (sql)
|
|
import GHC.Weak (deRefWeak)
|
|
import Simplex.Chat
|
|
import Simplex.Chat.Controller
|
|
import Simplex.Chat.Messages
|
|
import Simplex.Chat.Messages.CIContent
|
|
import Simplex.Chat.Styled
|
|
import Simplex.Chat.Terminal.Output
|
|
import Simplex.Chat.Types (User (..))
|
|
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore, withTransaction)
|
|
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
|
import Simplex.Messaging.Util (catchAll_, safeDecodeUtf8, whenM)
|
|
import System.Exit (exitSuccess)
|
|
import System.Terminal hiding (insertChars)
|
|
import UnliftIO.STM
|
|
|
|
getKey :: MonadTerminal m => m (Key, Modifiers)
|
|
getKey =
|
|
flush >> awaitEvent >>= \case
|
|
Left Interrupt -> liftIO exitSuccess
|
|
Right (KeyEvent key ms) -> pure (key, ms)
|
|
_ -> getKey
|
|
|
|
runInputLoop :: ChatTerminal -> ChatController -> IO ()
|
|
runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
|
|
s <- atomically . readTBQueue $ inputQ cc
|
|
rh <- readTVarIO $ currentRemoteHost cc
|
|
let bs = encodeUtf8 $ T.pack s
|
|
cmd = parseChatCommand bs
|
|
rh' = if either (const False) allowRemoteCommand cmd then rh else Nothing
|
|
unless (isMessage cmd) $ echo s
|
|
r <- runReaderT (execChatCommand rh' bs) cc
|
|
processResp s cmd rh r
|
|
printRespToTerminal ct cc False rh r
|
|
startLiveMessage cmd r
|
|
where
|
|
echo s = printToTerminal ct [plain s]
|
|
processResp s cmd rh = \case
|
|
CRActiveUser u -> case rh of
|
|
Nothing -> setActive ct ""
|
|
Just rhId -> updateRemoteUser ct u rhId
|
|
CRChatItems u chatName_ _ -> whenCurrUser cc u $ mapM_ (setActive ct . chatActiveTo) chatName_
|
|
CRNewChatItem u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo
|
|
CRChatItemUpdated u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo
|
|
CRChatItemDeleted u (AChatItem _ _ cInfo _) _ _ _ -> whenCurrUser cc u $ setActiveChat ct cInfo
|
|
CRContactDeleted u c -> whenCurrUser cc u $ unsetActiveContact ct c
|
|
CRGroupDeletedUser u g -> whenCurrUser cc u $ unsetActiveGroup ct g
|
|
CRSentGroupInvitation u g _ _ -> whenCurrUser cc u $ setActiveGroup ct g
|
|
CRChatCmdError _ _ -> when (isMessage cmd) $ echo s
|
|
CRChatError _ _ -> when (isMessage cmd) $ echo s
|
|
CRCmdOk _ -> case cmd of
|
|
Right APIDeleteUser {} -> setActive ct ""
|
|
_ -> pure ()
|
|
_ -> pure ()
|
|
isMessage = \case
|
|
Right SendMessage {} -> True
|
|
Right SendLiveMessage {} -> True
|
|
Right SendFile {} -> True
|
|
Right SendMessageQuote {} -> True
|
|
Right ForwardMessage {} -> True
|
|
Right ForwardLocalMessage {} -> True
|
|
Right SendGroupMessageQuote {} -> True
|
|
Right ForwardGroupMessage {} -> 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 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 cmd = UpdateLiveMessage chatName chatItemId live $ T.pack sentMsg
|
|
either (CRChatCmdError Nothing) id <$> runExceptT (processChatCommand cmd) `runReaderT` cc
|
|
|
|
runTerminalInput :: ChatTerminal -> ChatController -> IO ()
|
|
runTerminalInput ct cc = withChatTerm ct $ do
|
|
updateInput ct
|
|
receiveFromTTY cc ct
|
|
|
|
receiveFromTTY :: forall m. MonadTerminal m => ChatController -> ChatTerminal -> m ()
|
|
receiveFromTTY cc@ChatController {inputQ, currentUser, currentRemoteHost, chatStore} ct@ChatTerminal {termSize, termState, liveMessageState, activeTo} =
|
|
forever $ getKey >>= liftIO . processKey >> withTermLock ct (updateInput ct)
|
|
where
|
|
processKey :: (Key, Modifiers) -> IO ()
|
|
processKey key = case key of
|
|
(EnterKey, ms)
|
|
| ms == mempty -> submit False
|
|
| ms == altKey -> submit True
|
|
| otherwise -> pure ()
|
|
(CharKey c, ms)
|
|
| (c == 'l' || c == 'L') && ms == ctrlKey -> submit True
|
|
| otherwise -> update key
|
|
_ -> update key
|
|
submit live = do
|
|
ts <- readTVarIO termState
|
|
isLive <- isJust <$> readTVarIO liveMessageState
|
|
when (inputString ts /= "" || isLive) $
|
|
atomically (submitInput live ts) >>= mapM_ (uncurry endLiveMessage)
|
|
update key = do
|
|
chatPrefix <- readTVarIO activeTo
|
|
live <- isJust <$> readTVarIO liveMessageState
|
|
ts <- readTVarIO termState
|
|
user_ <- readTVarIO currentUser
|
|
ts' <- updateTermState user_ chatStore chatPrefix live (width termSize) key ts
|
|
atomically $ writeTVar termState $! ts'
|
|
|
|
endLiveMessage :: String -> LiveMessage -> IO ()
|
|
endLiveMessage sentMsg lm = do
|
|
kill liveThreadId
|
|
kill promptThreadId
|
|
atomically $ writeTVar liveMessageState Nothing
|
|
r <- sendUpdatedLiveMessage cc sentMsg lm False
|
|
rh <- readTVarIO currentRemoteHost -- XXX: should be inherited from live message state
|
|
printRespToTerminal ct cc False rh r
|
|
where
|
|
kill sel = deRefWeak (sel lm) >>= mapM_ killThread
|
|
|
|
submitInput :: Bool -> TerminalState -> STM (Maybe (String, LiveMessage))
|
|
submitInput live ts = do
|
|
let s = inputString ts
|
|
lm_ <- readTVar liveMessageState
|
|
case lm_ of
|
|
Just LiveMessage {chatName}
|
|
| live -> do
|
|
writeTVar termState ts' {previousInput}
|
|
writeTBQueue inputQ $ "/live " <> chatNameStr chatName
|
|
| otherwise ->
|
|
writeTVar termState ts' {inputPrompt = "> ", previousInput}
|
|
where
|
|
previousInput = chatNameStr chatName <> " " <> s
|
|
_
|
|
| live -> 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, autoComplete = mkAutoComplete}
|
|
|
|
data AutoComplete
|
|
= ACContact Text
|
|
| ACContactRequest Text
|
|
| ACMember Text Text
|
|
| ACGroup Text
|
|
| ACCommand Text
|
|
| ACNone
|
|
|
|
updateTermState :: Maybe User -> SQLiteStore -> String -> Bool -> Int -> (Key, Modifiers) -> TerminalState -> IO TerminalState
|
|
updateTermState user_ st chatPrefix live tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p, autoComplete = acp} = case key of
|
|
CharKey c
|
|
| ms == mempty || ms == shiftKey -> pure $ insertChars $ charsWithContact [c]
|
|
| ms == altKey && c == 'b' -> pure $ setPosition prevWordPos
|
|
| ms == altKey && c == 'f' -> pure $ setPosition nextWordPos
|
|
| otherwise -> pure ts
|
|
TabKey -> do
|
|
(pfx, vs) <- autoCompleteVariants user_
|
|
let sv = acShowVariants acp
|
|
sv'
|
|
| not (acTabPressed acp) = if null pfx || sv /= SVNone then SVSome else SVNone
|
|
| sv == SVNone = SVSome
|
|
| sv == SVSome && length vs > 4 = SVAll
|
|
| otherwise = SVNone
|
|
acp' = acp {acVariants = vs, acInputString = s, acShowVariants = sv', acTabPressed = True}
|
|
pure $ (insertChars pfx) {autoComplete = acp'}
|
|
BackspaceKey -> pure backDeleteChar
|
|
DeleteKey -> pure deleteChar
|
|
HomeKey -> pure $ setPosition 0
|
|
EndKey -> pure $ setPosition $ length s
|
|
ArrowKey d -> pure $ case d of
|
|
Leftwards -> setPosition leftPos
|
|
Rightwards -> setPosition rightPos
|
|
Upwards
|
|
| ms == mempty && null s -> let s' = upArrowCmd $ previousInput ts in ts' (s', length s')
|
|
| ms == mempty -> let p' = p - tw in if p' > 0 then setPosition p' else ts
|
|
| otherwise -> ts
|
|
Downwards
|
|
| ms == mempty -> let p' = p + tw in if p' <= length s then setPosition p' else ts
|
|
| otherwise -> ts
|
|
_ -> pure ts
|
|
where
|
|
autoCompleteVariants Nothing = pure ("", [charsWithContact " "])
|
|
autoCompleteVariants (Just User {userId, userContactId}) =
|
|
getAutoCompleteChars $ fromRight ACNone $ A.parseOnly autoCompleteP $ encodeUtf8 $ T.pack s
|
|
where
|
|
autoCompleteP =
|
|
A.choice
|
|
[ ACContact <$> (contactPfx *> displayName <* A.endOfInput),
|
|
ACContactRequest <$> (contactReqPfx *> displayName <* A.endOfInput),
|
|
ACMember <$> (groupMemberPfx *> displayName) <* A.space <* optional (A.char '@') <*> displayName <* A.endOfInput,
|
|
ACGroup <$> (groupPfx *> displayName <* A.endOfInput),
|
|
ACCommand . safeDecodeUtf8 <$> ((<>) <$> ("/" *> alphaP) <*> (B.cons <$> A.space <*> alphaP <|> "")) <* A.endOfInput
|
|
]
|
|
displayName = safeDecodeUtf8 <$> (B.cons <$> A.satisfy refChar <*> A.takeTill (== ' ') <|> "")
|
|
refChar c = c > ' ' && c /= '#' && c /= '@'
|
|
alphaP = A.takeWhile $ \c -> isAscii c && isAlpha c
|
|
contactPfx =
|
|
A.choice $
|
|
ops '@' [">>", ">", "!", "\\"]
|
|
<> cmd '@' ["t", "tail", "?", "search", "set voice", "set delete", "set disappear"]
|
|
<> cmd_ '@' ["i ", "info ", "f ", "file ", "clear", "d ", "delete ", "code ", "verify "]
|
|
<> ["@"]
|
|
contactReqPfx = A.choice $ cmd_ '@' ["ac", "accept", "rc", "reject"]
|
|
groupPfx =
|
|
A.choice $
|
|
ops '#' [">", "!", "\\\\", "\\"]
|
|
<> cmd '#' ["t", "tail", "?", "search", "i", "info", "f", "file", "clear", "d", "delete", "code", "verify", "set voice", "set delete", "set disappear", "set direct"]
|
|
<> cmd_ '#' ["a", "add", "j", "join", "rm", "remove", "l", "leave", "ms", "members", "mr", "member role"]
|
|
<> ["#"]
|
|
groupMemberPfx =
|
|
A.choice $
|
|
ops '#' [">", "\\\\"]
|
|
<> cmd '#' ["i", "info", "code", "verify"]
|
|
<> cmd_ '#' ["rm", "remove", "l", "leave", "mr", "member role"]
|
|
ops c = map (<* (optional A.space <* A.char c))
|
|
cmd c = map $ \t -> A.char '/' *> t <* A.space <* A.char c
|
|
cmd_ c = map $ \t -> A.char '/' *> t <* A.space <* optional (A.char c)
|
|
getAutoCompleteChars = \case
|
|
ACContact pfx -> common pfx <$> getContactSfxs pfx
|
|
ACContactRequest pfx -> common pfx <$> getNameSfxs "contact_requests" pfx
|
|
ACGroup pfx -> common pfx <$> getNameSfxs "groups" pfx
|
|
ACMember gName pfx -> common pfx <$> getMemberNameSfxs gName pfx
|
|
ACCommand pfx -> pure $ second (map ('/' :)) $ common pfx $ hasPfx pfx commands
|
|
ACNone -> pure ("", [charsWithContact ""])
|
|
where
|
|
getMemberNameSfxs gName pfx =
|
|
getNameSfxs_
|
|
pfx
|
|
(userId, userContactId, gName, pfx <> "%")
|
|
[sql|
|
|
SELECT m.local_display_name
|
|
FROM group_members m
|
|
JOIN groups g USING (group_id)
|
|
WHERE g.user_id = ?
|
|
AND (m.contact_id IS NULL OR m.contact_id != ?)
|
|
AND g.local_display_name = ?
|
|
AND m.local_display_name LIKE ?
|
|
|]
|
|
getContactSfxs pfx =
|
|
getNameSfxs_
|
|
pfx
|
|
(userId, pfx <> "%")
|
|
"SELECT local_display_name FROM contacts WHERE is_user = 0 AND user_id = ? AND local_display_name LIKE ?"
|
|
getNameSfxs table pfx =
|
|
getNameSfxs_ pfx (userId, pfx <> "%") $
|
|
"SELECT local_display_name FROM " <> table <> " WHERE user_id = ? AND local_display_name LIKE ?"
|
|
getNameSfxs_ :: SQL.ToRow p => Text -> p -> SQL.Query -> IO [String]
|
|
getNameSfxs_ pfx ps q =
|
|
withTransaction st (\db -> hasPfx pfx . map fromOnly <$> DB.query db q ps) `catchAll_` pure []
|
|
commands =
|
|
["connect", "search", "tail", "info", "clear", "delete", "code", "verify"]
|
|
<> ["file", "freceive", "fcancel", "fstatus", "fforward", "image", "image_forward"]
|
|
<> ["address", "delete_address", "show_address", "auto_accept", "accept @", "reject @"]
|
|
<> ["group", "groups", "members #", "member role #", "add #", "join #", "remove #", "leave #"]
|
|
<> ["create link #", "set link role #", "delete link #", "show link #"]
|
|
<> ["set voice", "set delete", "set direct #", "set disappear", "mute", "unmute"]
|
|
<> ["create user", "profile", "users", "user", "mute user", "unmute user", "hide user", "unhide user", "delete user"]
|
|
<> ["chats", "contacts", "help", "markdown", "quit", "db export", "db encrypt", "db decrypt", "db key"]
|
|
hasPfx pfx = map T.unpack . sort . filter (pfx `T.isPrefixOf`)
|
|
common pfx xs = (commonPrefix $ map (drop $ T.length pfx) xs, xs)
|
|
commonPrefix = \case
|
|
x : xs -> foldl go x xs
|
|
_ -> ""
|
|
where
|
|
go (c : cs) (c' : cs')
|
|
| c == c' = c : go cs cs'
|
|
| otherwise = ""
|
|
go _ _ = ""
|
|
charsWithContact cs
|
|
| live = cs
|
|
| null s && cs /= "@" && cs /= "#" && cs /= "/" && cs /= ">" && cs /= "\\" && cs /= "!" && cs /= "+" && cs /= "-" =
|
|
chatPrefix <> cs
|
|
| (s == ">" || s == "\\" || s == "!") && cs == " " =
|
|
cs <> chatPrefix
|
|
| otherwise = cs
|
|
insertChars = ts' . if p >= length s then append else insert
|
|
append cs = let s' = s <> cs in (s', length s')
|
|
insert cs = let (b, a) = splitAt p s in (b <> cs <> a, p + length cs)
|
|
backDeleteChar
|
|
| p == 0 || null s = ts
|
|
| p >= length s = ts' (init s, length s - 1)
|
|
| otherwise = let (b, a) = splitAt p s in ts' (init b <> a, p - 1)
|
|
deleteChar
|
|
| p >= length s || null s = ts
|
|
| p == 0 = ts' (tail s, 0)
|
|
| otherwise = let (b, a) = splitAt p s in ts' (b <> tail a, p)
|
|
leftPos
|
|
| ms == mempty = max 0 (p - 1)
|
|
| ms == shiftKey = 0
|
|
| ms == ctrlKey = prevWordPos
|
|
| ms == altKey = prevWordPos
|
|
| otherwise = p
|
|
rightPos
|
|
| ms == mempty = min (length s) (p + 1)
|
|
| ms == shiftKey = length s
|
|
| ms == ctrlKey = nextWordPos
|
|
| ms == altKey = nextWordPos
|
|
| otherwise = p
|
|
upArrowCmd inp = case parseChatCommand . encodeUtf8 $ T.pack inp of
|
|
Left _ -> inp
|
|
Right cmd -> case cmd of
|
|
SendMessage {} -> "! " <> inp
|
|
SendMessageQuote {contactName, message} -> T.unpack $ "! @" <> contactName <> " " <> message
|
|
SendGroupMessageQuote {groupName, message} -> T.unpack $ "! #" <> groupName <> " " <> message
|
|
_ -> inp
|
|
setPosition p' = ts' (s, p')
|
|
prevWordPos
|
|
| p == 0 || null s = p
|
|
| otherwise =
|
|
let before = take p s
|
|
beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before
|
|
in max 0 $ p - length before + length beforeWord
|
|
nextWordPos
|
|
| p >= length s || null s = p
|
|
| otherwise =
|
|
let after = drop p s
|
|
afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after
|
|
in min (length s) $ p + length after - length afterWord
|
|
ts' (s', p') = ts {inputString = s', inputPosition = p', autoComplete = acp {acTabPressed = False}}
|