diff --git a/simplex-chat.cabal b/simplex-chat.cabal index f8370e4391..945601b8ff 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 49ff263f6f..d3bd9e9943 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -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 diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 54d3cd9143..a6dfcbf9b7 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -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 diff --git a/src/Simplex/Chat/Library/Commands/Parsers.hs b/src/Simplex/Chat/Library/Commands/Parsers.hs new file mode 100644 index 0000000000..4a7390aab5 --- /dev/null +++ b/src/Simplex/Chat/Library/Commands/Parsers.hs @@ -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 diff --git a/src/Simplex/Chat/Terminal/Commands.hs b/src/Simplex/Chat/Terminal/Commands.hs new file mode 100644 index 0000000000..a01137579d --- /dev/null +++ b/src/Simplex/Chat/Terminal/Commands.hs @@ -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_ diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index bf48d1d4f5..95b05459ec 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -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