terminal: autocomplete contacts, groups and commands (#2125)

* terminal: autocomplete contacts, groups and commands

* autocomplete for commands and member names

* update commands

* show variants

* improve

* improve

* do not show user in contacts, better state machine for tab states

* update CI runners

src/Simplex/Chat.hs

@@ -4408,7 +4408,7 @@ chatCommandP =
       "/_temp_folder " *> (SetTempFolder <$> filePath),
       ("/_files_folder " <|> "/files_folder ") *> (SetFilesFolder <$> filePath),
       "/_xftp " *> (APISetXFTPConfig <$> ("on " *> (Just <$> jsonP) <|> ("off" $> Nothing))),
-      "/xftp " *> (APISetXFTPConfig <$> ("on " *> (Just <$> xftpCfgP) <|> ("off" $> Nothing))),
+      "/xftp " *> (APISetXFTPConfig <$> ("on" *> (Just <$> xftpCfgP) <|> ("off" $> Nothing))),
       "/_db export " *> (APIExportArchive <$> jsonP),
       "/db export" $> ExportArchive,
       "/_db import " *> (APIImportArchive <$> jsonP),
@@ -4671,10 +4671,7 @@ chatCommandP =
       logErrors <- " log=" *> onOffP <|> pure False
       let tcpTimeout = 1000000 * fromMaybe (maybe 5 (const 10) socksProxy) t_
       pure $ fullNetworkConfig socksProxy tcpTimeout logErrors
-    xftpCfgP = do
+    xftpCfgP = XFTPFileConfig <$> (" size=" *> fileSizeP <|> pure 0)
-      minFileSize <- "minFileSize=" *> fileSizeP
-      pure $ XFTPFileConfig {minFileSize}
-    -- TODO move to Utils in simplexmq
     fileSizeP =
       A.choice
         [ gb <$> A.decimal <* "gb",

src/Simplex/Chat/Terminal/Input.hs

@@ -4,26 +4,38 @@
 {-# 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.Except
 import Control.Monad.Reader
-import Data.Char (isAlphaNum)
+import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.List (dropWhileEnd, foldl')
+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 DB
+import Database.SQLite.Simple.QQ (sql)
 import GHC.Weak (deRefWeak)
 import Simplex.Chat
 import Simplex.Chat.Controller
 import Simplex.Chat.Messages
 import Simplex.Chat.Styled
 import Simplex.Chat.Terminal.Output
-import Simplex.Messaging.Util (whenM)
+import Simplex.Chat.Types (User (..))
+import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore, withTransaction)
+import Simplex.Messaging.Util (catchAll_, safeDecodeUtf8, whenM)
 import System.Exit (exitSuccess)
 import System.Terminal hiding (insertChars)
 import UnliftIO.STM
@@ -119,7 +131,7 @@ runTerminalInput ct cc = withChatTerm ct $ do
   receiveFromTTY cc ct
 
 receiveFromTTY :: forall m. MonadTerminal m => ChatController -> ChatTerminal -> m ()
-receiveFromTTY cc@ChatController {inputQ, activeTo} ct@ChatTerminal {termSize, termState, liveMessageState} =
+receiveFromTTY cc@ChatController {inputQ, activeTo, currentUser, chatStore} ct@ChatTerminal {termSize, termState, liveMessageState} =
   forever $ getKey >>= liftIO . processKey >> withTermLock ct (updateInput ct)
   where
     processKey :: (Key, Modifiers) -> IO ()
@@ -132,13 +144,18 @@ receiveFromTTY cc@ChatController {inputQ, activeTo} ct@ChatTerminal {termSize, t
         | (c == 'l' || c == 'L') && ms == ctrlKey -> submit True
         | otherwise -> update key
       _ -> update key
-    submit live =
+    submit live = do
-      atomically (readTVar termState >>= submitInput live)
+      ts <- readTVarIO termState
-        >>= mapM_ (uncurry endLiveMessage)
+      isLive <- isJust <$> readTVarIO liveMessageState
-    update key = atomically $ do
+      when (inputString ts /= "" || isLive) $
-      ac <- readTVar activeTo
+        atomically (submitInput live ts) >>= mapM_ (uncurry endLiveMessage)
-      live <- isJust <$> readTVar liveMessageState
+    update key = do
-      modifyTVar termState $ updateTermState ac live (width termSize) key
+      ac <- readTVarIO activeTo
+      live <- isJust <$> readTVarIO liveMessageState
+      ts <- readTVarIO termState
+      user_ <- readTVarIO currentUser
+      ts' <- updateTermState user_ chatStore ac live (width termSize) key ts
+      atomically $ writeTVar termState $! ts'
 
     endLiveMessage :: String -> LiveMessage -> IO ()
     endLiveMessage sentMsg lm = do
@@ -173,21 +190,38 @@ receiveFromTTY cc@ChatController {inputQ, activeTo} ct@ChatTerminal {termSize, t
       pure $ (s,) <$> lm_
       where
         isSend s = length s > 1 && (head s == '@' || head s == '#')
-        ts' = ts {inputString = "", inputPosition = 0}
+        ts' = ts {inputString = "", inputPosition = 0, autoComplete = mkAutoComplete}
 
-updateTermState :: ActiveTo -> Bool -> Int -> (Key, Modifiers) -> TerminalState -> TerminalState
+data AutoComplete
-updateTermState ac live tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p} = case key of
+  = ACContact Text
+  | ACContactRequest Text
+  | ACMember Text Text
+  | ACGroup Text
+  | ACCommand Text
+  | ACNone
+
+updateTermState :: Maybe User -> SQLiteStore -> ActiveTo -> Bool -> Int -> (Key, Modifiers) -> TerminalState -> IO TerminalState
+updateTermState user_ st ac live tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p, autoComplete = acp} = case key of
   CharKey c
-    | ms == mempty || ms == shiftKey -> insertCharsWithContact [c]
+    | ms == mempty || ms == shiftKey -> pure $ insertChars $ charsWithContact [c]
-    | ms == altKey && c == 'b' -> setPosition prevWordPos
+    | ms == altKey && c == 'b' -> pure $ setPosition prevWordPos
-    | ms == altKey && c == 'f' -> setPosition nextWordPos
+    | ms == altKey && c == 'f' -> pure $ setPosition nextWordPos
-    | otherwise -> ts
+    | otherwise -> pure ts
-  TabKey -> insertCharsWithContact "    "
+  TabKey -> do
-  BackspaceKey -> backDeleteChar
+    (pfx, vs) <- autoCompleteVariants user_
-  DeleteKey -> deleteChar
+    let sv = acShowVariants acp
-  HomeKey -> setPosition 0
+        sv'
-  EndKey -> setPosition $ length s
+          | not (acTabPressed acp) = if null pfx || sv /= SVNone then SVSome else SVNone
-  ArrowKey d -> case d of
+          | 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
@@ -197,15 +231,102 @@ updateTermState ac live tw (key, ms) ts@TerminalState {inputString = s, inputPos
     Downwards
       | ms == mempty -> let p' = p + tw in if p' <= length s then setPosition p' else ts
       | otherwise -> ts
-  _ -> ts
+  _ -> pure ts
   where
-    insertCharsWithContact cs
+    autoCompleteVariants Nothing = pure ("", [charsWithContact "    "])
-      | live = insertChars cs
+    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_ :: DB.ToRow p => Text -> p -> DB.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 /= "!" =
-        insertChars $ contactPrefix <> cs
+        contactPrefix <> cs
       | (s == ">" || s == "\\" || s == "!") && cs == " " =
-        insertChars $ cs <> contactPrefix
+        cs <> contactPrefix
-      | otherwise = insertChars cs
+      | 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)
@@ -253,4 +374,4 @@ updateTermState ac live tw (key, ms) ts@TerminalState {inputString = s, inputPos
         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'}
+    ts' (s', p') = ts {inputString = s', inputPosition = p', autoComplete = acp {acTabPressed = False}}

src/Simplex/Chat/Terminal/Output.hs

@@ -12,6 +12,7 @@ import Control.Concurrent (ThreadId)
 import Control.Monad.Catch (MonadMask)
 import Control.Monad.Except
 import Control.Monad.Reader
+import Data.List (intercalate)
 import Data.Time.Clock (getCurrentTime)
 import Simplex.Chat (processChatCommand)
 import Simplex.Chat.Controller
@@ -38,7 +39,18 @@ data TerminalState = TerminalState
   { inputPrompt :: String,
     inputString :: String,
     inputPosition :: Int,
-    previousInput :: String
+    previousInput :: String,
+    autoComplete :: AutoCompleteState
+  }
+
+data ACShowVariants = SVNone | SVSome | SVAll
+  deriving (Eq, Enum)
+
+data AutoCompleteState = ACState
+  { acVariants :: [String],
+    acInputString :: String,
+    acTabPressed :: Bool,
+    acShowVariants :: ACShowVariants
   }
 
 data LiveMessage = LiveMessage
@@ -82,9 +94,13 @@ mkTermState =
     { inputString = "",
       inputPosition = 0,
       inputPrompt = "> ",
-      previousInput = ""
+      previousInput = "",
+      autoComplete = mkAutoComplete
     }
 
+mkAutoComplete :: AutoCompleteState
+mkAutoComplete = ACState {acVariants = [], acInputString = "", acTabPressed = False, acShowVariants = SVNone}
+
 withTermLock :: MonadTerminal m => ChatTerminal -> m () -> m ()
 withTermLock ChatTerminal {termLock} action = do
   _ <- atomically $ takeTMVar termLock
@@ -141,11 +157,13 @@ updateInput ChatTerminal {termSize = Size {height, width}, termState, nextMessag
   let ih = inputHeight ts
       iStart = height - ih
       prompt = inputPrompt ts
-      Position {row, col} = positionRowColumn width $ length prompt + inputPosition ts
+      acPfx = autoCompletePrefix ts
+      Position {row, col} = positionRowColumn width $ length acPfx + length prompt + inputPosition ts
   if nmr >= iStart
     then atomically $ writeTVar nextMessageRow iStart
     else clearLines nmr iStart
   setCursorPosition $ Position {row = max nmr iStart, col = 0}
+  putStyled $ Styled [SetColor Foreground Dull White] acPfx
   putString $ prompt <> inputString ts <> " "
   eraseInLine EraseForward
   setCursorPosition $ Position {row = iStart + row, col}
@@ -160,7 +178,15 @@ updateInput ChatTerminal {termSize = Size {height, width}, termState, nextMessag
         eraseInLine EraseForward
         clearLines (from + 1) till
     inputHeight :: TerminalState -> Int
-    inputHeight ts = length (inputPrompt ts <> inputString ts) `div` width + 1
+    inputHeight ts = length (autoCompletePrefix ts <> inputPrompt ts <> inputString ts) `div` width + 1
+    autoCompletePrefix :: TerminalState -> String
+    autoCompletePrefix TerminalState {autoComplete = ac}
+      | length vars <= 1 || sv == SVNone = ""
+      | sv == SVAll || length vars <= 4 = "(" <> intercalate ", " vars <> ") "
+      | otherwise = "(" <> intercalate ", " (take 3 vars) <> "... +" <> show (length vars - 3) <> ") "
+      where
+        sv = acShowVariants ac
+        vars = acVariants ac
     positionRowColumn :: Int -> Int -> Position
     positionRowColumn wid pos =
       let row = pos `div` wid

tests/ChatTests/Files.hs

@@ -1058,7 +1058,7 @@ testXFTPWithChangedConfig =
       alice #$> ("/_xftp on {\"minFileSize\":1024}", id, "ok")
 
       bob #$> ("/xftp off", id, "ok")
-      bob #$> ("/xftp on minFileSize=1kb", id, "ok")
+      bob #$> ("/xftp on size=1kb", id, "ok")
 
       connectUsers alice bob