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

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

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

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

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

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_

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