content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE DuplicateRecordFields #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE GADTs #-}
  {-# 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
  import Control.Monad.Reader
  import qualified Data.Attoparsec.ByteString.Char8 as A
  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 GHC.Weak (deRefWeak)
  import Simplex.Chat.Controller
  import Simplex.Chat.Library.Commands
  import Simplex.Chat.Messages
  import Simplex.Chat.Messages.CIContent
  import Simplex.Chat.Styled
  import Simplex.Chat.Terminal.Output
  import Simplex.Chat.Types (User (..))
  import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
  import qualified Simplex.Messaging.Agent.Store.DB as DB
  import Simplex.Messaging.Util (catchAll_, safeDecodeUtf8, whenM)
  import System.Exit (exitSuccess)
  import System.Terminal hiding (insertChars)
  import UnliftIO.STM
  #if defined(dbPostgres)
  import Database.PostgreSQL.Simple (Only (..), Query, ToRow)
  import Database.PostgreSQL.Simple.SqlQQ (sql)
  #else
  import Database.SQLite.Simple (Only (..), Query, ToRow)
  import Database.SQLite.Simple.QQ (sql)
  #endif
  
  getKey :: MonadTerminal m => m (Key, Modifiers)
  getKey =
    flush >> awaitEvent >>= \case
      Left Interrupt -> liftIO exitSuccess
      Right (KeyEvent key ms) -> pure (key, ms)
      _ -> getKey
  
  runInputLoop :: ChatTerminal -> ChatController -> IO ()
  runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = 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 <- execChatCommand rh' bs 0 `runReaderT` cc
    case r of
      Right r' -> processResp cmd rh r'
      Left _ -> when (isMessage cmd) $ echo s
    printRespToTerminal ct cc False rh r
    mapM_ (startLiveMessage cmd) r
    where
      echo s = printToTerminal ct [plain s]
      processResp cmd rh = \case
        CRActiveUser u -> case rh of
          Nothing -> setActive ct ""
          Just rhId -> updateRemoteUser ct u rhId
        CRChatItems u chatName_ _ -> whenCurrUser cc u $ mapM_ (setActive ct . chatActiveTo) chatName_
        CRNewChatItems u ((AChatItem _ SMDSnd cInfo _) : _) -> whenCurrUser cc u $ setActiveChat ct cInfo
        CRChatItemUpdated u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo
        CRChatItemsDeleted u ((ChatItemDeletion (AChatItem _ _ cInfo _) _) : _) _ _ -> whenCurrUser cc u $ setActiveChat ct cInfo
        CRContactDeleted u c -> whenCurrUser cc u $ unsetActiveContact ct c
        CRGroupDeletedUser u g -> whenCurrUser cc u $ unsetActiveGroup ct g
        CRSentGroupInvitation u g _ _ -> whenCurrUser cc u $ setActiveGroup ct g
        CRCmdOk _ -> case cmd of
          Right 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
        _ -> False
      startLiveMessage :: Either a ChatCommand -> ChatResponse -> IO ()
      startLiveMessage (Right (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
          liveThreadId <- mkWeakThreadId =<< runLiveMessage int `forkFinally` const (atomically $ writeTVar liveMessageState Nothing)
          promptThreadId <- mkWeakThreadId =<< forkIO blinkLivePrompt
          atomically $ do
            let lm = LiveMessage {chatName, chatItemId = itemId, livePrompt = True, sentMsg = s, typedMsg = s, liveThreadId, promptThreadId}
            writeTVar liveMessageState (Just lm)
            modifyTVar termState $ \ts -> ts {inputString = s, inputPosition = length s, inputPrompt = liveInputPrompt lm}
        where
          liveInputPrompt LiveMessage {chatName = n, livePrompt} =
            "> " <> chatNameStr n <> " [" <> (if livePrompt then "LIVE" else "    ") <> "] "
          runLiveMessage :: Int -> IO ()
          runLiveMessage int = do
            threadDelay int
            TerminalState {inputString = s} <- readTVarIO termState
            readTVarIO liveMessageState
              >>= mapM_ (\lm -> updateLiveMessage s lm >> runLiveMessage int)
          blinkLivePrompt = readTVarIO liveMessageState >>= mapM_ updateLivePrompt
            where
              updateLivePrompt lm = do
                atomically $ updatePrompt lm
                updateInputView ct
                threadDelay 1000000
                blinkLivePrompt
              updatePrompt lm = do
                writeTVar liveMessageState $ Just lm {livePrompt = not $ livePrompt lm}
                modifyTVar termState (\ts -> ts {inputPrompt = liveInputPrompt lm})
          liveMessageToSend t LiveMessage {sentMsg, typedMsg} =
            let s = if t /= typedMsg then truncateToWords t else t
             in if s /= sentMsg then Just s else Nothing
          updateLiveMessage typedMsg lm = case liveMessageToSend typedMsg lm of
            Just sentMsg ->
              sendUpdatedLiveMessage cc sentMsg lm True >>= \case
                Right CRChatItemUpdated {} -> setLiveMessage lm {sentMsg, typedMsg}
                _ -> do
                  -- TODO print error
                  setLiveMessage lm {typedMsg}
            _ -> setLiveMessage lm {typedMsg}
          setLiveMessage :: LiveMessage -> IO ()
          setLiveMessage = atomically . writeTVar liveMessageState . Just
          truncateToWords = fst . foldl' acc ("", "")
            where
              acc (s, w) c
                | isAlphaNum c = (s, c : w)
                | otherwise = (s <> reverse (c : w), "")
      startLiveMessage _ _ = pure ()
  
  sendUpdatedLiveMessage :: ChatController -> String -> LiveMessage -> Bool -> IO (Either ChatError ChatResponse)
  sendUpdatedLiveMessage cc sentMsg LiveMessage {chatName, chatItemId} live = do
    let cmd = UpdateLiveMessage chatName chatItemId live $ T.pack sentMsg
    execChatCommand' cmd 0 `runReaderT` cc
  
  runTerminalInput :: ChatTerminal -> ChatController -> IO ()
  runTerminalInput ct cc = withChatTerm ct $ do
    updateInput ct
    receiveFromTTY cc ct
  
  receiveFromTTY :: forall m. MonadTerminal m => ChatController -> ChatTerminal -> m ()
  receiveFromTTY cc@ChatController {inputQ, currentUser, currentRemoteHost, chatStore} ct@ChatTerminal {termSize, termState, liveMessageState, activeTo} =
    forever $ getKey >>= liftIO . processKey >> withTermLock ct (updateInput ct)
    where
      processKey :: (Key, Modifiers) -> IO ()
      processKey key = case key of
        (EnterKey, ms)
          | ms == mempty -> submit False
          | ms == altKey -> submit True
          | otherwise -> pure ()
        (CharKey c, ms)
          | (c == 'l' || c == 'L') && ms == ctrlKey -> submit True
          | otherwise -> update key
        _ -> update key
      submit live = do
        ts <- readTVarIO termState
        isLive <- isJust <$> readTVarIO liveMessageState
        when (inputString ts /= "" || isLive) $
          atomically (submitInput live ts) >>= mapM_ (uncurry endLiveMessage)
      update key = do
        chatPrefix <- readTVarIO activeTo
        live <- isJust <$> readTVarIO liveMessageState
        ts <- readTVarIO termState
        user_ <- readTVarIO currentUser
        ts' <- updateTermState user_ chatStore chatPrefix live (width termSize) key ts
        atomically $ writeTVar termState $! ts'
  
      endLiveMessage :: String -> LiveMessage -> IO ()
      endLiveMessage sentMsg lm = do
        kill liveThreadId
        kill promptThreadId
        atomically $ writeTVar liveMessageState Nothing
        r <- sendUpdatedLiveMessage cc sentMsg lm False
        rh <- readTVarIO currentRemoteHost -- XXX: should be inherited from live message state
        printRespToTerminal ct cc False rh r
        where
          kill sel = deRefWeak (sel lm) >>= mapM_ killThread
  
      submitInput :: Bool -> TerminalState -> STM (Maybe (String, LiveMessage))
      submitInput live ts = do
        let s = inputString ts
        lm_ <- readTVar liveMessageState
        case lm_ of
          Just LiveMessage {chatName}
            | live -> do
                writeTVar termState ts' {previousInput}
                writeTBQueue inputQ $ "/live " <> chatNameStr chatName
            | otherwise ->
                writeTVar termState ts' {inputPrompt = "> ", previousInput}
            where
              previousInput = chatNameStr chatName <> " " <> s
          _
            | live -> when (isSend s) $ do
                writeTVar termState ts' {previousInput = s}
                writeTBQueue inputQ $ "/live " <> s
            | otherwise -> do
                writeTVar termState ts' {inputPrompt = "> ", previousInput = s}
                writeTBQueue inputQ s
        pure $ (s,) <$> lm_
        where
          isSend s = length s > 1 && (head s == '@' || head s == '#')
          ts' = ts {inputString = "", inputPosition = 0, autoComplete = mkAutoComplete}
  
  data AutoComplete
    = ACContact Text
    | ACContactRequest Text
    | ACMember Text Text
    | ACGroup Text
    | ACCommand Text
    | ACNone
  
  updateTermState :: Maybe User -> DBStore -> String -> Bool -> Int -> (Key, Modifiers) -> TerminalState -> IO TerminalState
  updateTermState user_ st chatPrefix live tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p, autoComplete = acp} = case key of
    CharKey c
      | ms == mempty || ms == shiftKey -> pure $ insertChars $ charsWithContact [c]
      | ms == altKey && c == 'b' -> pure $ setPosition prevWordPos
      | ms == altKey && c == 'f' -> pure $ setPosition nextWordPos
      | otherwise -> pure ts
    TabKey -> do
      (pfx, vs) <- autoCompleteVariants user_
      let sv = acShowVariants acp
          sv'
            | not (acTabPressed acp) = if null pfx || sv /= SVNone then SVSome else SVNone
            | 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
        | ms == mempty && null s -> let s' = upArrowCmd $ previousInput ts in ts' (s', length s')
        | ms == mempty -> let p' = p - tw in if p' > 0 then setPosition p' else ts
        | otherwise -> ts
      Downwards
        | ms == mempty -> let p' = p + tw in if p' <= length s then setPosition p' else ts
        | otherwise -> ts
    _ -> pure ts
    where
      autoCompleteVariants Nothing = pure ("", [charsWithContact "    "])
      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_ :: ToRow p => Text -> p -> 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 /= "!" && cs /= "+" && cs /= "-" =
            chatPrefix <> cs
        | (s == ">" || s == "\\" || s == "!") && cs == " " =
            cs <> chatPrefix
        | 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)
      backDeleteChar
        | p == 0 || null s = ts
        | p >= length s = ts' (init s, length s - 1)
        | otherwise = let (b, a) = splitAt p s in ts' (init b <> a, p - 1)
      deleteChar
        | p >= length s || null s = ts
        | p == 0 = ts' (tail s, 0)
        | otherwise = let (b, a) = splitAt p s in ts' (b <> tail a, p)
      leftPos
        | ms == mempty = max 0 (p - 1)
        | ms == shiftKey = 0
        | ms == ctrlKey = prevWordPos
        | ms == altKey = prevWordPos
        | otherwise = p
      rightPos
        | ms == mempty = min (length s) (p + 1)
        | ms == shiftKey = length s
        | ms == ctrlKey = nextWordPos
        | ms == altKey = nextWordPos
        | otherwise = p
      upArrowCmd inp = case parseChatCommand . encodeUtf8 $ T.pack inp of
        Left _ -> inp
        Right cmd -> case cmd of
          SendMessage {} -> "! " <> inp
          SendMessageQuote {contactName, message} -> T.unpack $ "! @" <> contactName <> " " <> message
          SendGroupMessageQuote {groupName, message} -> T.unpack $ "! #" <> groupName <> " " <> message
          _ -> inp
      setPosition p' = ts' (s, p')
      prevWordPos
        | p == 0 || null s = p
        | otherwise =
            let before = take p s
                beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before
             in max 0 $ p - length before + length beforeWord
      nextWordPos
        | p >= length s || null s = p
        | otherwise =
            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', autoComplete = acp {acTabPressed = False}}
  