simplex-chat/src/Simplex/Chat/Terminal/Output.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Simplex.Chat.Terminal.Output where

import Control.Concurrent (ThreadId)
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Catch (MonadMask)
import Control.Monad.Reader
import Data.List (intercalate)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (getCurrentTime)
import Data.Time.LocalTime (getCurrentTimeZone)
import Simplex.Chat.Controller
import Simplex.Chat.Library.Commands (execChatCommand, execChatCommand')
import Simplex.Chat.Markdown
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent (CIContent (..), SMsgDirection (..))
import Simplex.Chat.Options
import Simplex.Chat.Protocol (MsgContent (..), msgContentText)
import Simplex.Chat.Remote.Types (RHKey (..), RemoteHostId, RemoteHostInfo (..), RemoteHostSession (..))
import Simplex.Chat.Styled
import Simplex.Chat.Terminal.Notification (Notification (..), initializeNotifications)
import Simplex.Chat.Types
import Simplex.Chat.View
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util (tshow)
import System.Console.ANSI.Types
import System.IO (IOMode (..), hPutStrLn, withFile)
import System.Mem.Weak (Weak)
import System.Terminal
import System.Terminal.Internal (LocalTerminal, Terminal, VirtualTerminal)
import UnliftIO.STM

data ChatTerminal = ChatTerminal
  { termDevice :: TerminalDevice,
    termState :: TVar TerminalState,
    termSize :: Size,
    liveMessageState :: TVar (Maybe LiveMessage),
    nextMessageRow :: TVar Int,
    termLock :: TMVar (),
    sendNotification :: Maybe (Notification -> IO ()),
    activeTo :: TVar String,
    currentRemoteUsers :: TMap RemoteHostId User
  }

data TerminalState = TerminalState
  { inputPrompt :: String,
    inputString :: String,
    inputPosition :: Int,
    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
  { chatName :: ChatName,
    chatItemId :: ChatItemId,
    livePrompt :: Bool,
    sentMsg :: String,
    typedMsg :: String,
    liveThreadId :: Weak ThreadId,
    promptThreadId :: Weak ThreadId
  }

class Terminal t => WithTerminal t where
  withTerm :: (MonadIO m, MonadMask m) => t -> (t -> m a) -> m a

data TerminalDevice = forall t. WithTerminal t => TerminalDevice t

instance WithTerminal LocalTerminal where
  withTerm _ = withTerminal

instance WithTerminal VirtualTerminal where
  withTerm t = ($ t)

withChatTerm :: (MonadIO m, MonadMask m) => ChatTerminal -> (forall t. WithTerminal t => TerminalT t m a) -> m a
withChatTerm ChatTerminal {termDevice = TerminalDevice t} action = withTerm t $ runTerminalT action

newChatTerminal :: WithTerminal t => t -> ChatOpts -> IO ChatTerminal
newChatTerminal t opts = do
  termSize <- withTerm t . runTerminalT $ getWindowSize
  let lastRow = height termSize - 1
  termState <- newTVarIO mkTermState
  liveMessageState <- newTVarIO Nothing
  termLock <- newTMVarIO ()
  nextMessageRow <- newTVarIO lastRow
  sendNotification <- if muteNotifications opts then pure Nothing else Just <$> initializeNotifications
  activeTo <- newTVarIO ""
  currentRemoteUsers <- newTVarIO mempty
  -- threadDelay 500000 -- this delay is the same as timeout in getTerminalSize
  pure
    ChatTerminal
      { termDevice = TerminalDevice t,
        termState,
        termSize,
        liveMessageState,
        nextMessageRow,
        termLock,
        sendNotification,
        activeTo,
        currentRemoteUsers
      }

mkTermState :: TerminalState
mkTermState =
  TerminalState
    { inputString = "",
      inputPosition = 0,
      inputPrompt = "> ",
      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
  action
  atomically $ putTMVar termLock ()

runTerminalOutput :: ChatTerminal -> ChatController -> ChatOpts -> IO ()
runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} ChatOpts {markRead} = do
  forever $ do
    (outputRH, r_) <- atomically $ readTBQueue outputQ
    forM_ r_ $ \case
      CEvtNewChatItems u (ci : _) -> when markRead $ markChatItemRead u ci -- At the moment of writing received items are created one at a time
      CEvtChatItemUpdated u ci -> when markRead $ markChatItemRead u ci
      CEvtRemoteHostConnected {remoteHost = RemoteHostInfo {remoteHostId}} -> getRemoteUser remoteHostId
      CEvtRemoteHostStopped {remoteHostId_} -> mapM_ removeRemoteUser remoteHostId_
      _ -> pure ()
    let printEvent = case logFilePath of
          Just path -> if either (const True) logEventToFile r_ then logResponse path else printToTerminal ct
          _ -> printToTerminal ct
    liveItems <- readTVarIO showLiveItems
    responseString ct cc liveItems outputRH r_ >>= printEvent
    mapM_ (chatEventNotification ct cc) r_
  where
    markChatItemRead u (AChatItem _ _ chat ci@ChatItem {chatDir, meta = CIMeta {itemStatus}}) =
      case (chatDirNtf u chat chatDir (isUserMention ci), itemStatus) of
        (True, CISRcvNew) -> do
          let itemId = chatItemId' ci
              chatRef_ = chatInfoToRef chat
          forM_ chatRef_ $ \chatRef -> runReaderT (execChatCommand' (APIChatItemsRead chatRef [itemId]) 0) cc
        _ -> pure ()
    logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s
    getRemoteUser rhId =
      runReaderT (execChatCommand (Just rhId) "/user" 0) cc >>= \case
        Right CRActiveUser {user} -> updateRemoteUser ct user rhId
        cr -> logError $ "Unexpected reply while getting remote user: " <> tshow cr
    removeRemoteUser rhId = atomically $ TM.delete rhId (currentRemoteUsers ct)

chatEventNotification :: ChatTerminal -> ChatController -> ChatEvent -> IO ()
chatEventNotification t@ChatTerminal {sendNotification} cc = \case
  -- At the moment of writing received items are created one at a time
  CEvtNewChatItems u ((AChatItem _ SMDRcv cInfo ci@ChatItem {chatDir, content = CIRcvMsgContent mc, formattedText}) : _) ->
    when (chatDirNtf u cInfo chatDir $ isUserMention ci) $ do
      whenCurrUser cc u $ setActiveChat t cInfo
      case (cInfo, chatDir) of
        (DirectChat ct, _) -> sendNtf (viewContactName ct <> "> ", text)
        (GroupChat g scopeInfo, CIGroupRcv m) -> sendNtf (fromGroup_ g scopeInfo (Just m), text)
        (GroupChat g scopeInfo, CIChannelRcv) -> sendNtf (fromGroup_ g scopeInfo Nothing, text)
        _ -> pure ()
    where
      text = msgText mc formattedText
  CEvtChatItemUpdated u (AChatItem _ SMDRcv cInfo ci@ChatItem {chatDir, content = CIRcvMsgContent _}) ->
    whenCurrUser cc u $ when (chatDirNtf u cInfo chatDir $ isUserMention ci) $ setActiveChat t cInfo
  CEvtContactConnected u ct _ -> when (contactNtf u ct False) $ do
    whenCurrUser cc u $ setActiveContact t ct
    sendNtf (viewContactName ct <> "> ", "connected")
  CEvtContactSndReady u ct ->
    whenCurrUser cc u $ setActiveContact t ct
  CEvtContactAnotherClient u ct -> do
    whenCurrUser cc u $ unsetActiveContact t ct
    when (contactNtf u ct False) $ sendNtf (viewContactName ct <> "> ", "connected to another client")
  CEvtReceivedGroupInvitation u g ct _ _ ->
    when (contactNtf u ct False) $
      sendNtf ("#" <> viewGroupName g <> " " <> viewContactName ct <> "> ", "invited you to join the group")
  CEvtUserJoinedGroup u g _ -> when (groupNtf u g False) $ do
    whenCurrUser cc u $ setActiveGroup t g
    sendNtf ("#" <> viewGroupName g, "you are connected to group")
  CEvtJoinedGroupMember u g m ->
    when (groupNtf u g False) $ sendNtf ("#" <> viewGroupName g, "member " <> viewMemberName m <> " is connected")
  CEvtJoinedGroupMemberConnecting u g _ m | memberStatus m == GSMemPendingReview ->
    when (groupNtf u g False) $ sendNtf ("#" <> viewGroupName g, "member " <> viewMemberName m <> " is pending review")
  CEvtConnectedToGroupMember u g m _ ->
    when (groupNtf u g False) $ sendNtf ("#" <> viewGroupName g, "member " <> viewMemberName m <> " is connected")
  CEvtReceivedContactRequest u UserContactRequest {localDisplayName = n} _ ->
    when (userNtf u) $ sendNtf (viewName n <> ">", "wants to connect to you")
  CEvtDeletedMemberUser _u g m _withMessages _signed ->
    sendNtf ("#" <> viewGroupName g, viewMemberName m <> " removed you from the group")
  _ -> pure ()
  where
    sendNtf = maybe (\_ -> pure ()) (. uncurry Notification) sendNotification

chatResponseNotification :: ChatTerminal -> Either ChatError ChatResponse -> IO ()
chatResponseNotification ChatTerminal {sendNotification} = \case
  Right r -> case r of
    CRUserContactLinkCreated {} -> sendNtf ("SimpleX", "contact link created")
    CRUserProfileUpdated {} -> sendNtf ("SimpleX", "profile updated")
    _ -> pure ()
  Left _ -> pure ()
  where
    sendNtf = maybe (\_ -> pure ()) (. uncurry Notification) sendNotification

msgText :: MsgContent -> Maybe MarkdownList -> Text
msgText (MCFile _) _ = "wants to send a file"
msgText mc md_ = maybe (msgContentText mc) (mconcat . map hideSecret) md_
  where
    hideSecret :: FormattedText -> Text
    hideSecret FormattedText {format = Just Secret} = "..."
    hideSecret FormattedText {text} = text

chatActiveTo :: ChatName -> String
chatActiveTo (ChatName cType name) = case cType of
  CTDirect -> T.unpack $ "@" <> viewName name <> " "
  CTGroup -> T.unpack $ "#" <> viewName name <> " "
  _ -> ""

chatInfoActiveTo :: ChatInfo c -> String
chatInfoActiveTo = \case
  DirectChat c -> contactActiveTo c
  GroupChat g _scopeInfo -> groupActiveTo g
  _ -> ""

contactActiveTo :: Contact -> String
contactActiveTo c = T.unpack $ "@" <> viewContactName c <> " "

groupActiveTo :: GroupInfo -> String
groupActiveTo g = T.unpack $ "#" <> viewGroupName g <> " "

setActiveChat :: ChatTerminal -> ChatInfo c -> IO ()
setActiveChat t = setActive t . chatInfoActiveTo

setActiveContact :: ChatTerminal -> Contact -> IO ()
setActiveContact t = setActive t . contactActiveTo

setActiveGroup :: ChatTerminal -> GroupInfo -> IO ()
setActiveGroup t = setActive t . groupActiveTo

setActive :: ChatTerminal -> String -> IO ()
setActive ChatTerminal {activeTo} to = atomically $ writeTVar activeTo to

unsetActiveContact :: ChatTerminal -> Contact -> IO ()
unsetActiveContact t = unsetActive t . contactActiveTo

unsetActiveGroup :: ChatTerminal -> GroupInfo -> IO ()
unsetActiveGroup t = unsetActive t . groupActiveTo

unsetActive :: ChatTerminal -> String -> IO ()
unsetActive ChatTerminal {activeTo} to' = atomically $ modifyTVar activeTo unset
  where
    unset to = if to == to' then "" else to

whenCurrUser :: ChatController -> User -> IO () -> IO ()
whenCurrUser cc u a = do
  u_ <- readTVarIO $ currentUser cc
  when (sameUser u u_) a
  where
    sameUser User {userId = uId} = maybe False $ \User {userId} -> userId == uId

printRespToTerminal :: ChatTerminal -> ChatController -> Bool -> Maybe RemoteHostId -> Either ChatError ChatResponse -> IO ()
printRespToTerminal ct cc liveItems outputRH r = responseString ct cc liveItems outputRH r >>= printToTerminal ct

responseString :: forall r. ChatResponseEvent r => ChatTerminal -> ChatController -> Bool -> Maybe RemoteHostId -> Either ChatError r -> IO [StyledString]
responseString ct cc liveItems outputRH = \case
  Right r -> do
    cu <- getCurrentUser ct cc
    ts <- getCurrentTime
    tz <- getCurrentTimeZone
    pure $ responseToView cu (config cc) liveItems ts tz outputRH r
  Left e -> pure $ chatErrorToView (isCommandResponse @r) (config cc) e

updateRemoteUser :: ChatTerminal -> User -> RemoteHostId -> IO ()
updateRemoteUser ct user rhId = atomically $ TM.insert rhId user (currentRemoteUsers ct)

getCurrentUser :: ChatTerminal -> ChatController -> IO (Maybe RemoteHostId, Maybe User)
getCurrentUser ct cc = atomically $ do
  localUser_ <- readTVar (currentUser cc)
  readTVar (currentRemoteHost cc) >>= \case
    Nothing -> pure (Nothing, localUser_)
    Just rhId ->
      TM.lookup (RHId rhId) (remoteHostSessions cc) >>= \case
        Just (_, RHSessionConnected {}) -> do
          hostUser_ <- TM.lookup rhId (currentRemoteUsers ct)
          pure (Just rhId, hostUser_)
        _ -> pure (Nothing, localUser_)

printToTerminal :: ChatTerminal -> [StyledString] -> IO ()
printToTerminal ct s =
  withChatTerm ct $
    withTermLock ct $ do
      printMessage ct s
      updateInput ct

updateInputView :: ChatTerminal -> IO ()
updateInputView ct = withChatTerm ct $ withTermLock ct $ updateInput ct

updateInput :: forall m. MonadTerminal m => ChatTerminal -> m ()
updateInput ChatTerminal {termSize = Size {height, width}, termState, nextMessageRow} = do
  hideCursor
  ts <- readTVarIO termState
  nmr <- readTVarIO nextMessageRow
  let ih = inputHeight ts
      iStart = height - ih
      prompt = inputPrompt 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}
  showCursor
  flush
  where
    clearLines :: Int -> Int -> m ()
    clearLines from till
      | from >= till = return ()
      | otherwise = do
          setCursorPosition $ Position {row = from, col = 0}
          eraseInLine EraseForward
          clearLines (from + 1) till
    inputHeight :: TerminalState -> Int
    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
          col = pos - row * wid
       in Position {row, col}

printMessage :: forall m. MonadTerminal m => ChatTerminal -> [StyledString] -> m ()
printMessage ChatTerminal {termSize = Size {height, width}, nextMessageRow} msg = do
  nmr <- readTVarIO nextMessageRow
  setCursorPosition $ Position {row = nmr, col = 0}
  mapM_ printStyled msg
  flush
  let lc = sum $ map lineCount msg
  atomically . writeTVar nextMessageRow $ min (height - 1) (nmr + lc)
  where
    lineCount :: StyledString -> Int
    lineCount s = sLength s `div` width + 1
    printStyled :: StyledString -> m ()
    printStyled s = do
      putStyled s
      eraseInLine EraseForward
      putLn

-- Currently it is assumed that the message does not have internal line breaks.
-- Previous implementation "kind of" supported them,
-- but it was not determining the number of printed lines correctly
-- because of accounting for control sequences in length
putStyled :: MonadTerminal m => StyledString -> m ()
putStyled (s1 :<>: s2) = putStyled s1 >> putStyled s2
putStyled (Styled [] s) = putString s
putStyled (Styled sgr s) = setSGR sgr >> putString s >> resetAttributes

setSGR :: MonadTerminal m => [SGR] -> m ()
setSGR = mapM_ $ \case
  Reset -> resetAttributes
  SetConsoleIntensity BoldIntensity -> setAttribute bold
  SetConsoleIntensity _ -> resetAttribute bold
  SetItalicized True -> setAttribute italic
  SetItalicized _ -> resetAttribute italic
  SetUnderlining NoUnderline -> resetAttribute underlined
  SetUnderlining _ -> setAttribute underlined
  SetSwapForegroundBackground True -> setAttribute inverted
  SetSwapForegroundBackground _ -> resetAttribute inverted
  SetColor l i c -> setAttribute . layer l . intensity i $ color c
  SetBlinkSpeed _ -> pure ()
  SetVisible _ -> pure ()
  SetRGBColor _ _ -> pure ()
  SetPaletteColor _ _ -> pure ()
  SetDefaultColor _ -> pure ()
  where
    layer = \case
      Foreground -> foreground
      Background -> background
    intensity = \case
      Dull -> id
      Vivid -> bright
    color = \case
      Black -> black
      Red -> red
      Green -> green
      Yellow -> yellow
      Blue -> blue
      Magenta -> magenta
      Cyan -> cyan
      White -> white