core: abandoned attempt to split TTY commands to separate type to reduce library size

This commit is contained in:
Evgeny Poberezkin 2025-03-13 21:39:29 +00:00
parent 45c7c6bc6e
commit 9a0e1c414c
No known key found for this signature in database
GPG key ID: 494BDDD9A28B577D
6 changed files with 143 additions and 33 deletions

View file

@ -41,6 +41,7 @@ library
Simplex.Chat.Files
Simplex.Chat.Help
Simplex.Chat.Library.Commands
Simplex.Chat.Library.Commands.Parsers
Simplex.Chat.Library.Internal
Simplex.Chat.Library.Subscriber
Simplex.Chat.Markdown
@ -79,6 +80,7 @@ library
Simplex.Chat.Store.Shared
Simplex.Chat.Styled
Simplex.Chat.Terminal
Simplex.Chat.Terminal.Commands
Simplex.Chat.Terminal.Input
Simplex.Chat.Terminal.Main
Simplex.Chat.Terminal.Notification

View file

@ -258,7 +258,7 @@ data ChatCommand
| CreateActiveUser NewUser
| ListUsers
| APISetActiveUser UserId (Maybe UserPwd)
| SetActiveUser UserName (Maybe UserPwd)
-- | SetActiveUser UserName (Maybe UserPwd)
| SetAllContactReceipts Bool
| APISetUserContactReceipts UserId UserMsgReceiptSettings
| SetUserContactReceipts UserMsgReceiptSettings

View file

@ -54,6 +54,7 @@ import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as V4
import Simplex.Chat.Library.Subscriber
import Simplex.Chat.Call
import Simplex.Chat.Library.Commands.Parsers
import Simplex.Chat.Controller
import Simplex.Chat.Files
import Simplex.Chat.Markdown
@ -363,10 +364,10 @@ processChatCommand' vr = \case
user'' <- withFastStore' (`setActiveUser` user')
chatWriteVar currentUser $ Just user''
pure $ CRActiveUser user''
SetActiveUser uName viewPwd_ -> do
tryChatError (withFastStore (`getUserIdByName` uName)) >>= \case
Left _ -> throwChatError CEUserUnknown
Right userId -> processChatCommand $ APISetActiveUser userId viewPwd_
-- SetActiveUser uName viewPwd_ -> do
-- tryChatError (withFastStore (`getUserIdByName` uName)) >>= \case
-- Left _ -> throwChatError CEUserUnknown
-- Right userId -> processChatCommand $ APISetActiveUser userId viewPwd_
SetAllContactReceipts onOff -> withUser $ \_ -> withFastStore' (`updateAllContactReceipts` onOff) >> ok_
APISetUserContactReceipts userId' settings -> withUser $ \user -> do
user' <- privateGetUser userId'
@ -3808,7 +3809,7 @@ withExpirationDate globalTTL chatItemTTL action = do
chatCommandP :: Parser ChatCommand
chatCommandP =
choice
cmdChoice
[ "/mute " *> ((`SetShowMessages` MFNone) <$> chatNameP),
"/unmute " *> ((`SetShowMessages` MFAll) <$> chatNameP),
"/unmute mentions " *> ((`SetShowMessages` MFMentions) <$> chatNameP),
@ -3819,8 +3820,8 @@ chatCommandP =
"/create user " *> (CreateActiveUser <$> newUserP),
"/users" $> ListUsers,
"/_user " *> (APISetActiveUser <$> A.decimal <*> optional (A.space *> jsonP)),
("/user " <|> "/u ") *> (SetActiveUser <$> displayNameP <*> optional (A.space *> pwdP)),
"/set receipts all " *> (SetAllContactReceipts <$> onOffP),
-- ("/user " <|> "/u ") *> (SetActiveUser <$> displayNameP <*> optional (A.space *> pwdP)),
-- "/set receipts all " *> (SetAllContactReceipts <$> onOffP),
"/_set receipts contacts " *> (APISetUserContactReceipts <$> A.decimal <* A.space <*> receiptSettings),
"/set receipts contacts " *> (SetUserContactReceipts <$> receiptSettings),
"/_set receipts groups " *> (APISetUserGroupReceipts <$> A.decimal <* A.space <*> receiptSettings),
@ -4166,7 +4167,6 @@ chatCommandP =
"//" *> (CustomChatCommand <$> A.takeByteString)
]
where
choice = A.choice . map (\p -> p <* A.takeWhile (== ' ') <* A.endOfInput)
incognitoP = (A.space *> ("incognito" <|> "i")) $> True <|> pure False
incognitoOnOffP = (A.space *> "incognito=" *> onOffP) <|> pure False
imagePrefix = (<>) <$> "data:" <*> ("image/png;base64," <|> "image/jpg;base64,")
@ -4215,14 +4215,11 @@ chatCommandP =
enable <- onOffP
clearOverrides <- (" clear_overrides=" *> onOffP) <|> pure False
pure UserMsgReceiptSettings {enable, clearOverrides}
onOffP = ("on" $> True) <|> ("off" $> False)
profileNames = (,) <$> displayNameP <*> fullNameP
newUserP = do
(cName, fullName) <- profileNames
let profile = Just Profile {displayName = cName, fullName, image = Nothing, contactLink = Nothing, preferences = Nothing}
pure NewUser {profile, pastTimestamp = False}
jsonP :: J.FromJSON a => Parser a
jsonP = J.eitherDecodeStrict' <$?> A.takeByteString
groupProfile = do
(gName, fullName) <- profileNames
let groupPreferences =
@ -4234,7 +4231,6 @@ chatCommandP =
pure GroupProfile {displayName = gName, fullName, description = Nothing, image = Nothing, groupPreferences}
fullNameP = A.space *> textP <|> pure ""
textP = safeDecodeUtf8 <$> A.takeByteString
pwdP = jsonP <|> (UserPwd . safeDecodeUtf8 <$> A.takeTill (== ' '))
verifyCodeP = safeDecodeUtf8 <$> A.takeWhile (\c -> isDigit c || c == ' ')
msgTextP = jsonP <|> textP
stringP = T.unpack . safeDecodeUtf8 <$> A.takeByteString

View file

@ -0,0 +1,23 @@
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Chat.Library.Commands.Parsers where
import Control.Applicative ((<|>))
import qualified Data.Aeson as J
import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Functor (($>))
import Simplex.Chat.Controller (UserPwd (..))
import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>))
cmdChoice :: [Parser a] -> Parser a
cmdChoice = A.choice . map (\p -> p <* A.takeWhile (== ' ') <* A.endOfInput)
onOffP :: Parser Bool
onOffP = ("on" $> True) <|> ("off" $> False)
pwdP :: Parser UserPwd
pwdP = jsonP <|> (UserPwd . safeDecodeUtf8 <$> A.takeTill (== ' '))
jsonP :: J.FromJSON a => Parser a
jsonP = J.eitherDecodeStrict' <$?> A.takeByteString

View file

@ -0,0 +1,86 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
module Simplex.Chat.Terminal.Commands where
import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Simplex.Chat.Controller
import Simplex.Chat.Library.Commands
import Simplex.Chat.Library.Internal
import Simplex.Chat.Library.Commands.Parsers
import Simplex.Chat.Remote.Types
import Simplex.Chat.Store.Profiles
import Simplex.Chat.Types
data TerminalCommand
= TtyChatCommand ChatCommand
| SetActiveUser UserName (Maybe UserPwd)
parseTtyCommand :: ByteString -> Either String TerminalCommand
parseTtyCommand = A.parseOnly ttyCommandP . B.dropWhileEnd isSpace
ttyCommandP :: Parser TerminalCommand
ttyCommandP =
cmdChoice
[ ("/user " <|> "/u ") *> (SetActiveUser <$> displayNameP <*> optional (A.space *> pwdP)),
TtyChatCommand <$> chatCommandP
]
allowRemoteTtyCommand :: TerminalCommand -> Bool
allowRemoteTtyCommand = \case
TtyChatCommand cmd -> allowRemoteCommand cmd
_ -> True
execTtyCommand :: Maybe RemoteHostId -> TerminalCommand -> ByteString -> CM' ChatResponse
execTtyCommand rh cmd s = do
u <- readTVarIO =<< asks currentUser
-- case parseChatCommand s of
-- Left e -> pure $ chatCmdError u e
-- Right cmd ->
case rh of
Just rhId
| allowRemoteCommand cmd -> execRemoteTtyCommand u rhId cmd s
| otherwise -> pure $ CRChatCmdError u $ ChatErrorRemoteHost (RHId rhId) $ RHELocalCommand
_ -> do
cc@ChatController {config = ChatConfig {chatHooks}} <- ask
case preCmdHook chatHooks of
Just hook -> liftIO (hook cc cmd) >>= either pure (execTtyCommand_ u)
Nothing -> execTtyCommand_ u cmd
execTtyCommand_ :: Maybe User -> TerminalCommand -> CM' ChatResponse
execTtyCommand_ u cmd = handleCommandError u $ processTtyCommand cmd
execRemoteTtyCommand :: Maybe User -> RemoteHostId -> TerminalCommand -> ByteString -> CM' ChatResponse
execRemoteTtyCommand u rhId cmd s = handleCommandError u $ getRemoteHostClient rhId >>= \rh -> processRemoteCommand rhId rh cmd s
processRemoteTtyCommand :: RemoteHostId -> RemoteHostClient -> TerminalCommand -> ByteString -> CM ChatResponse
processRemoteTtyCommand remoteHostId c cmd s = case cmd of
TtyChatCommand (SendFile chatName f) -> sendFile "/f" chatName f
TtyChatCommand (SendImage chatName f) -> sendFile "/img" chatName f
_ -> liftRH remoteHostId $ remoteSend c s
where
sendFile cmdName chatName (CryptoFile path cfArgs) = do
-- don't encrypt in host if already encrypted locally
CryptoFile path' cfArgs' <- storeRemoteFile remoteHostId (cfArgs $> False) path
let f = CryptoFile path' (cfArgs <|> cfArgs') -- use local or host encryption
liftRH remoteHostId $ remoteSend c $ B.unwords [cmdName, B.pack (chatNameStr chatName), cryptoFileStr f]
cryptoFileStr CryptoFile {filePath, cryptoArgs} =
maybe "" (\(CFArgs key nonce) -> "key=" <> strEncode key <> " nonce=" <> strEncode nonce <> " ") cryptoArgs
<> encodeUtf8 (T.pack filePath)
-- | Chat API commands interpreted in context of a local zone
processTtyCommand :: TerminalCommand -> CM ChatResponse
processTtyCommand cmd =
chatVersionRange >>= (`processTtyCommand'` cmd)
{-# INLINE processTtyCommand #-}
processTtyCommand' :: VersionRangeChat -> TerminalCommand -> CM ChatResponse
processTtyCommand' vr = \case
TtyChatCommand cmd -> processChatCommand vr cmd
SetActiveUser uName viewPwd_ -> do
tryChatError (withFastStore (`getUserIdByName` uName)) >>= \case
Left _ -> throwChatError CEUserUnknown
Right userId -> processChatCommand $ APISetActiveUser userId viewPwd_

View file

@ -32,6 +32,7 @@ import Simplex.Chat.Library.Commands
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Styled
import Simplex.Chat.Terminal.Commands
import Simplex.Chat.Terminal.Output
import Simplex.Chat.Types (User (..))
import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
@ -56,17 +57,19 @@ getKey =
_ -> getKey
runInputLoop :: ChatTerminal -> ChatController -> IO ()
runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
runInputLoop ct@ChatTerminal {termState, liveMessageState} cc@ChatController {currentUser} = 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
case parseTtyCommand bs of
Left e -> (`chatCmdError` e) <$> readTVarIO currentUser
Right cmd -> do
unless (isMessage cmd) $ echo s
let rh' = if allowRemoteCommand cmd then rh else Nothing
r <- runReaderT (execTtyCommand rh' cmd 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
@ -83,22 +86,22 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
CRChatCmdError _ _ -> when (isMessage cmd) $ echo s
CRChatError _ _ -> when (isMessage cmd) $ echo s
CRCmdOk _ -> case cmd of
Right APIDeleteUser {} -> setActive ct ""
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
TtyChatCommand SendMessage {} -> True
TtyChatCommand SendLiveMessage {} -> True
TtyChatCommand SendFile {} -> True
TtyChatCommand SendMessageQuote {} -> True
TtyChatCommand ForwardMessage {} -> True
TtyChatCommand ForwardLocalMessage {} -> True
TtyChatCommand SendGroupMessageQuote {} -> True
TtyChatCommand ForwardGroupMessage {} -> True
TtyChatCommand SendMessageBroadcast {} -> True
_ -> False
startLiveMessage :: Either a ChatCommand -> ChatResponse -> IO ()
startLiveMessage (Right (SendLiveMessage chatName msg)) (CRNewChatItems {chatItems = [AChatItem cType SMDSnd _ ChatItem {meta = CIMeta {itemId}}]}) = do
startLiveMessage :: TerminalCommand -> ChatResponse -> IO ()
startLiveMessage (TtyChatCommand (SendLiveMessage chatName msg)) (CRNewChatItems {chatItems = [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