mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
core: abandoned attempt to split TTY commands to separate type to reduce library size
This commit is contained in:
parent
45c7c6bc6e
commit
9a0e1c414c
6 changed files with 143 additions and 33 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
23
src/Simplex/Chat/Library/Commands/Parsers.hs
Normal file
23
src/Simplex/Chat/Library/Commands/Parsers.hs
Normal 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
|
86
src/Simplex/Chat/Terminal/Commands.hs
Normal file
86
src/Simplex/Chat/Terminal/Commands.hs
Normal 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_
|
|
@ -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
|
||||
|
|
Loading…
Add table
Reference in a new issue