diff --git a/ChatOptions.hs b/ChatOptions.hs index 0940c34b8f..7b501b3ff4 100644 --- a/ChatOptions.hs +++ b/ChatOptions.hs @@ -7,12 +7,10 @@ import Options.Applicative import Simplex.Messaging.Agent.Transmission (SMPServer (..), smpServerP) import Simplex.Messaging.Parsers (parseAll) import System.FilePath (combine) -import System.Info (os) import Types data ChatOpts = ChatOpts - { name :: Maybe B.ByteString, - dbFileName :: String, + { dbFileName :: String, smpServer :: SMPServer, termMode :: TermMode } @@ -20,15 +18,7 @@ data ChatOpts = ChatOpts chatOpts :: FilePath -> Parser ChatOpts chatOpts appDir = ChatOpts - <$> option - (Just <$> str) - ( long "name" - <> short 'n' - <> metavar "NAME" - <> help "optional name to use for invitations" - <> value Nothing - ) - <*> strOption + <$> strOption ( long "database" <> short 'd' <> metavar "DB_FILE" @@ -48,14 +38,11 @@ chatOpts appDir = ( long "term" <> short 't' <> metavar "TERM" - <> help ("terminal mode: editor or basic (" <> termModeName deafultTermMode <> ")") - <> value deafultTermMode + <> help ("terminal mode: editor or basic (" <> termModeName TermModeEditor <> ")") + <> value TermModeEditor ) where defaultDbFilePath = combine appDir "smp-chat.db" - deafultTermMode - | os == "mingw32" = TermModeBasic - | otherwise = TermModeEditor parseSMPServer :: ReadM SMPServer parseSMPServer = eitherReader $ parseAll smpServerP . B.pack diff --git a/ChatTerminal.hs b/ChatTerminal.hs index ccc5a87616..9a09027d16 100644 --- a/ChatTerminal.hs +++ b/ChatTerminal.hs @@ -7,315 +7,97 @@ module ChatTerminal ( ChatTerminal (..), newChatTerminal, chatTerminal, - updateUsername, ttyContact, ttyFromContact, ) where +import ChatTerminal.Basic +import ChatTerminal.Core +import ChatTerminal.Editor import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race_) -import Control.Concurrent.STM import Control.Monad -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B -import Data.List (dropWhileEnd) -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import Data.Text.Encoding import Numeric.Natural -import Simplex.Messaging.Transport (getLn, putLn) -import qualified System.Console.ANSI as C -import System.IO +import Styled +import System.Terminal import Types +import UnliftIO.STM -data ChatTerminal = ChatTerminal - { inputQ :: TBQueue ByteString, - outputQ :: TBQueue ByteString, - activeContact :: TVar (Maybe Contact), - username :: TVar (Maybe Contact), - termMode :: TermMode, - termState :: TVar TerminalState, - termSize :: (Int, Int), - nextMessageRow :: TVar Int, - termLock :: TMVar () - } - -data TerminalState = TerminalState - { inputPrompt :: String, - inputString :: String, - inputPosition :: Int - } - -inputHeight :: TerminalState -> ChatTerminal -> Int -inputHeight ts ct = length (inputPrompt ts <> inputString ts) `div` snd (termSize ct) + 1 - -data Key - = KeyLeft - | KeyRight - | KeyUp - | KeyDown - | KeyAltLeft - | KeyAltRight - | KeyCtrlLeft - | KeyCtrlRight - | KeyShiftLeft - | KeyShiftRight - | KeyEnter - | KeyBack - | KeyTab - | KeyEsc - | KeyChars String - | KeyUnsupported - deriving (Eq) - -newChatTerminal :: Natural -> Maybe Contact -> TermMode -> IO ChatTerminal -newChatTerminal qSize user termMode = do +newChatTerminal :: Natural -> TermMode -> IO ChatTerminal +newChatTerminal qSize termMode = do inputQ <- newTBQueueIO qSize outputQ <- newTBQueueIO qSize activeContact <- newTVarIO Nothing - username <- newTVarIO user - termSize <- fromMaybe (0, 0) <$> C.getTerminalSize - let lastRow = fst termSize - 1 - termState <- newTVarIO $ newTermState user + termSize <- withTerminal . runTerminalT $ getWindowSize + let lastRow = height termSize - 1 + termState <- newTVarIO newTermState termLock <- newTMVarIO () nextMessageRow <- newTVarIO lastRow threadDelay 500000 -- this delay is the same as timeout in getTerminalSize - return ChatTerminal {inputQ, outputQ, activeContact, username, termMode, termState, termSize, nextMessageRow, termLock} + return ChatTerminal {inputQ, outputQ, activeContact, termMode, termState, termSize, nextMessageRow, termLock} -newTermState :: Maybe Contact -> TerminalState -newTermState user = +newTermState :: TerminalState +newTermState = TerminalState { inputString = "", inputPosition = 0, - inputPrompt = promptString user + inputPrompt = "> ", + previousInput = "" } chatTerminal :: ChatTerminal -> IO () chatTerminal ct - | termSize ct == (0, 0) || termMode ct == TermModeBasic = - run receiveFromTTY sendToTTY + | termSize ct == Size 0 0 || termMode ct == TermModeBasic = + run basicReceiveFromTTY basicSendToTTY | otherwise = do - setTTY NoBuffering - hSetEcho stdin False - updateInput ct - run receiveFromTTY' sendToTTY' + withTerminal . runTerminalT $ updateInput ct + run receiveFromTTY sendToTTY where run receive send = race_ (receive ct) (send ct) -receiveFromTTY :: ChatTerminal -> IO () -receiveFromTTY ct = - forever $ getLn stdin >>= atomically . writeTBQueue (inputQ ct) +basicReceiveFromTTY :: ChatTerminal -> IO () +basicReceiveFromTTY ct = + forever $ getLn >>= atomically . writeTBQueue (inputQ ct) -withTermLock :: ChatTerminal -> IO () -> IO () +basicSendToTTY :: ChatTerminal -> IO () +basicSendToTTY ct = forever $ readOutputQ ct >>= mapM_ putStyledLn + +withTermLock :: MonadTerminal m => ChatTerminal -> m () -> m () withTermLock ChatTerminal {termLock} action = do _ <- atomically $ takeTMVar termLock action atomically $ putTMVar termLock () -receiveFromTTY' :: ChatTerminal -> IO () -receiveFromTTY' ct@ChatTerminal {inputQ, activeContact, termSize, termState} = - forever $ +receiveFromTTY :: ChatTerminal -> IO () +receiveFromTTY ct@ChatTerminal {inputQ, activeContact, termSize, termState} = + withTerminal . runTerminalT . forever $ getKey >>= processKey >> withTermLock ct (updateInput ct) where - processKey :: Key -> IO () + processKey :: MonadTerminal m => (Key, Modifiers) -> m () processKey = \case - KeyEnter -> submitInput + (EnterKey, _) -> submitInput key -> atomically $ do ac <- readTVar activeContact - modifyTVar termState $ updateTermState ac (snd termSize) key + modifyTVar termState $ updateTermState ac (width termSize) key - submitInput :: IO () + submitInput :: MonadTerminal m => m () submitInput = do msg <- atomically $ do ts <- readTVar termState - writeTVar termState $ ts {inputString = "", inputPosition = 0} - let msg = encodeUtf8 . T.pack $ inputString ts - writeTBQueue inputQ msg - return msg - withTermLock ct . printMessage ct $ highlightContact msg - - updateTermState :: Maybe Contact -> Int -> Key -> TerminalState -> TerminalState - updateTermState ac tw key ts@TerminalState {inputString = s, inputPosition = p} = case key of - KeyChars cs -> insertCharsWithContact cs - KeyTab -> insertChars " " - KeyBack -> backDeleteChar - KeyLeft -> setPosition $ max 0 (p - 1) - KeyRight -> setPosition $ min (length s) (p + 1) - KeyUp -> setPosition $ let p' = p - tw in if p' > 0 then p' else p - KeyDown -> setPosition $ let p' = p + tw in if p' <= length s then p' else p - KeyAltLeft -> setPosition prevWordPos - KeyAltRight -> setPosition nextWordPos - KeyCtrlLeft -> setPosition prevWordPos - KeyCtrlRight -> setPosition nextWordPos - KeyShiftLeft -> setPosition 0 - KeyShiftRight -> setPosition $ length s - _ -> ts - where - insertCharsWithContact cs - | null s && cs /= "@" && cs /= "/" = - insertChars $ contactPrefix <> cs - | otherwise = insertChars 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) - contactPrefix = case ac of - Just (Contact c) -> "@" <> B.unpack c <> " " - Nothing -> "" - backDeleteChar - | p == 0 || null s = ts - | p >= length s = ts' backDeleteLast - | otherwise = ts' backDelete - backDeleteLast = if null s then (s, 0) else let s' = init s in (s', length s') - backDelete = let (b, a) = splitAt p s in (init b <> a, p - 1) - 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'} - -highlightContact :: ByteString -> ByteString -highlightContact = \case - "" -> "" - s -> - if B.head s == '@' - then let (c, rest) = B.span (/= ' ') $ B.drop 1 s in ttyToContact (Contact c) <> rest - else s - -updateInput :: ChatTerminal -> IO () -updateInput ct@ChatTerminal {termSize, termState, nextMessageRow} = do - C.hideCursor - ts <- readTVarIO termState - nmr <- readTVarIO nextMessageRow - let (th, tw) = termSize - ih = inputHeight ts ct - iStart = th - ih - prompt = inputPrompt ts - (cRow, cCol) = relativeCursorPosition tw $ length prompt + inputPosition ts - if nmr >= iStart - then atomically $ writeTVar nextMessageRow iStart - else clearLines nmr iStart - C.setCursorPosition (max nmr iStart) 0 - putStr $ prompt <> inputString ts <> " " - C.clearFromCursorToLineEnd - C.setCursorPosition (iStart + cRow) cCol - C.showCursor - where - clearLines :: Int -> Int -> IO () - clearLines from till - | from >= till = return () - | otherwise = do - C.setCursorPosition from 0 - C.clearFromCursorToLineEnd - clearLines (from + 1) till - - relativeCursorPosition :: Int -> Int -> (Int, Int) - relativeCursorPosition width pos = - let row = pos `div` width - col = pos - row * width - in (row, col) - -updateUsername :: ChatTerminal -> Maybe Contact -> STM () -updateUsername ct a = do - writeTVar (username ct) a - modifyTVar (termState ct) $ \ts -> ts {inputPrompt = promptString a} - -promptString :: Maybe Contact -> String -promptString a = maybe "" (B.unpack . toBs) a <> "> " + let s = inputString ts + writeTVar termState $ ts {inputString = "", inputPosition = 0, previousInput = s} + writeTBQueue inputQ s + return s + withTermLock ct $ printMessage ct [styleMessage msg] sendToTTY :: ChatTerminal -> IO () -sendToTTY ct = forever $ readOutputQ ct >>= putLn stdout - -sendToTTY' :: ChatTerminal -> IO () -sendToTTY' ct = forever $ do +sendToTTY ct = forever $ do + -- `readOutputQ` should be outside of `withTerminal` (see #94) msg <- readOutputQ ct - withTermLock ct $ do + withTerminal . runTerminalT . withTermLock ct $ do printMessage ct msg updateInput ct -readOutputQ :: ChatTerminal -> IO ByteString +readOutputQ :: ChatTerminal -> IO [StyledString] readOutputQ = atomically . readTBQueue . outputQ - -printMessage :: ChatTerminal -> ByteString -> IO () -printMessage ChatTerminal {termSize, nextMessageRow} msg = do - nmr <- readTVarIO nextMessageRow - C.setCursorPosition nmr 0 - let (th, tw) = termSize - lc <- printLines tw msg - atomically . writeTVar nextMessageRow $ min (th - 1) (nmr + lc) - where - printLines :: Int -> ByteString -> IO Int - printLines tw s = do - let ls - | B.null s = [""] - | otherwise = B.lines s <> ["" | B.last s == '\n'] - print_ ls - return $ foldl (\lc l -> lc + (B.length l `div` tw) + 1) 0 ls - - print_ :: [ByteString] -> IO () - print_ [] = return () - print_ (l : ls) = do - B.hPut stdout l - C.clearFromCursorToLineEnd - B.hPut stdout "\n" - print_ ls - -getKey :: IO Key -getKey = charsToKey . reverse <$> keyChars "" - where - charsToKey = \case - "\ESC" -> KeyEsc - "\ESC[A" -> KeyUp - "\ESC[B" -> KeyDown - "\ESC[D" -> KeyLeft - "\ESC[C" -> KeyRight - "\ESCb" -> KeyAltLeft - "\ESCf" -> KeyAltRight - "\ESC[1;5D" -> KeyCtrlLeft - "\ESC[1;5C" -> KeyCtrlRight - "\ESC[1;2D" -> KeyShiftLeft - "\ESC[1;2C" -> KeyShiftRight - "\n" -> KeyEnter - "\DEL" -> KeyBack - "\t" -> KeyTab - '\ESC' : _ -> KeyUnsupported - cs -> KeyChars cs - - keyChars cs = do - c <- getChar - more <- hReady stdin - -- for debugging - uncomment this, comment line after: - -- (if more then keyChars else \c' -> print (reverse c') >> return c') (c : cs) - (if more then keyChars else return) (c : cs) - -setTTY :: BufferMode -> IO () -setTTY mode = do - hSetBuffering stdin mode - hSetBuffering stdout mode - -ttyContact :: Contact -> ByteString -ttyContact (Contact a) = withSGR contactSGR a - -ttyFromContact :: Contact -> ByteString -ttyFromContact (Contact a) = withSGR contactSGR $ a <> ">" - -ttyToContact :: Contact -> ByteString -ttyToContact (Contact a) = withSGR selfSGR $ "@" <> a - -contactSGR :: [C.SGR] -contactSGR = [C.SetColor C.Foreground C.Vivid C.Yellow] - -selfSGR :: [C.SGR] -selfSGR = [C.SetColor C.Foreground C.Vivid C.Cyan] - -withSGR :: [C.SGR] -> ByteString -> ByteString -withSGR sgr s = B.pack (C.setSGRCode sgr) <> s <> B.pack (C.setSGRCode [C.Reset]) diff --git a/ChatTerminal/Basic.hs b/ChatTerminal/Basic.hs new file mode 100644 index 0000000000..875313c645 --- /dev/null +++ b/ChatTerminal/Basic.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE LambdaCase #-} + +module ChatTerminal.Basic where + +import Control.Monad.IO.Class (liftIO) +import Styled +import System.Console.ANSI.Types +import System.Exit (exitSuccess) +import System.Terminal as C + +getLn :: IO String +getLn = withTerminal $ runTerminalT getTermLine + +putStyledLn :: StyledString -> IO () +putStyledLn s = + withTerminal . runTerminalT $ + putStyled s >> C.putLn >> flush + +-- 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 + +getKey :: MonadTerminal m => m (Key, Modifiers) +getKey = + flush >> awaitEvent >>= \case + Left Interrupt -> liftIO exitSuccess + Right (KeyEvent key ms) -> pure (key, ms) + _ -> getKey + +getTermLine :: MonadTerminal m => m String +getTermLine = getChars "" + where + getChars s = + getKey >>= \(key, ms) -> case key of + CharKey c + | ms == mempty || ms == shiftKey -> do + C.putChar c + flush + getChars (c : s) + | otherwise -> getChars s + EnterKey -> do + C.putLn + flush + pure $ reverse s + BackspaceKey -> do + moveCursorBackward 1 + eraseChars 1 + flush + getChars $ if null s then s else tail s + _ -> getChars s diff --git a/ChatTerminal/Core.hs b/ChatTerminal/Core.hs new file mode 100644 index 0000000000..ab001cb548 --- /dev/null +++ b/ChatTerminal/Core.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module ChatTerminal.Core where + +import Control.Concurrent.STM +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.List (dropWhileEnd) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +import Styled +import System.Console.ANSI.Types +import System.Terminal hiding (insertChars) +import Types + +data ChatTerminal = ChatTerminal + { inputQ :: TBQueue String, + outputQ :: TBQueue [StyledString], + activeContact :: TVar (Maybe Contact), + termMode :: TermMode, + termState :: TVar TerminalState, + termSize :: Size, + nextMessageRow :: TVar Int, + termLock :: TMVar () + } + +data TerminalState = TerminalState + { inputPrompt :: String, + inputString :: String, + inputPosition :: Int, + previousInput :: String + } + +inputHeight :: TerminalState -> ChatTerminal -> Int +inputHeight ts ct = length (inputPrompt ts <> inputString ts) `div` width (termSize ct) + 1 + +positionRowColumn :: Int -> Int -> Position +positionRowColumn wid pos = + let row = pos `div` wid + col = pos - row * wid + in Position {row, col} + +updateTermState :: Maybe Contact -> Int -> (Key, Modifiers) -> TerminalState -> TerminalState +updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p} = case key of + CharKey c + | ms == mempty || ms == shiftKey -> insertCharsWithContact [c] + | ms == altKey && c == 'b' -> setPosition prevWordPos + | ms == altKey && c == 'f' -> setPosition nextWordPos + | otherwise -> ts + TabKey -> insertCharsWithContact " " + BackspaceKey -> backDeleteChar + DeleteKey -> deleteChar + HomeKey -> setPosition 0 + EndKey -> setPosition $ length s + ArrowKey d -> case d of + Leftwards -> setPosition leftPos + Rightwards -> setPosition rightPos + Upwards + | ms == mempty && null s -> let s' = 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 + _ -> ts + where + insertCharsWithContact cs + | null s && cs /= "@" && cs /= "/" = + insertChars $ contactPrefix <> cs + | otherwise = insertChars 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) + contactPrefix = case ac of + Just (Contact c) -> "@" <> B.unpack c <> " " + Nothing -> "" + 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 + 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'} + +styleMessage :: String -> StyledString +styleMessage = \case + "" -> "" + s@('@' : _) -> let (c, rest) = span (/= ' ') s in Styled selfSGR c <> markdown rest + s -> markdown s + where + markdown :: String -> StyledString + markdown = styleMarkdownText . T.pack + +safeDecodeUtf8 :: ByteString -> Text +safeDecodeUtf8 = decodeUtf8With onError + where + onError _ _ = Just '?' + +ttyContact :: Contact -> StyledString +ttyContact (Contact a) = Styled contactSGR $ B.unpack a + +ttyFromContact :: Contact -> StyledString +ttyFromContact (Contact a) = Styled contactSGR $ B.unpack a <> "> " + +contactSGR :: [SGR] +contactSGR = [SetColor Foreground Vivid Yellow] + +selfSGR :: [SGR] +selfSGR = [SetColor Foreground Vivid Cyan] diff --git a/ChatTerminal/Editor.hs b/ChatTerminal/Editor.hs new file mode 100644 index 0000000000..d4e6a9843a --- /dev/null +++ b/ChatTerminal/Editor.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module ChatTerminal.Editor where + +import ChatTerminal.Basic +import ChatTerminal.Core +import Styled +import System.Terminal +import UnliftIO.STM + +-- debug :: MonadTerminal m => String -> m () +-- debug s = do +-- saveCursor +-- setCursorPosition $ Position 0 0 +-- putString s +-- restoreCursor + +updateInput :: forall m. MonadTerminal m => ChatTerminal -> m () +updateInput ct@ChatTerminal {termSize = Size {height, width}, termState, nextMessageRow} = do + hideCursor + ts <- readTVarIO termState + nmr <- readTVarIO nextMessageRow + let ih = inputHeight ts ct + iStart = height - ih + prompt = inputPrompt ts + Position {row, col} = positionRowColumn width $ length prompt + inputPosition ts + if nmr >= iStart + then atomically $ writeTVar nextMessageRow iStart + else clearLines nmr iStart + setCursorPosition $ Position {row = max nmr iStart, col = 0} + 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 + +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 diff --git a/Main.hs b/Main.hs index bc2c1c198f..b7127be0d5 100644 --- a/Main.hs +++ b/Main.hs @@ -11,6 +11,7 @@ module Main where import ChatOptions import ChatTerminal +import ChatTerminal.Core import Control.Applicative ((<|>)) import Control.Concurrent.STM import Control.Logger.Simple @@ -20,17 +21,21 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) +import Data.List (intersperse) +import qualified Data.Text as T +import Data.Text.Encoding import Numeric.Natural +import Simplex.Markdown import Simplex.Messaging.Agent (getSMPAgentClient, runSMPAgentClient) import Simplex.Messaging.Agent.Client (AgentClient (..)) import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Transmission import Simplex.Messaging.Client (smpDefaultConfig) import Simplex.Messaging.Parsers (parseAll) -import Simplex.Messaging.Util (bshow, raceAny_) +import Simplex.Messaging.Util (raceAny_) +import Styled +import System.Console.ANSI.Types import System.Directory (getAppUserDataDirectory) -import System.Exit (exitFailure) -import System.Info (os) import Types cfg :: AgentConfig @@ -50,39 +55,38 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} data ChatClient = ChatClient { inQ :: TBQueue ChatCommand, outQ :: TBQueue ChatResponse, - smpServer :: SMPServer, - username :: TVar (Maybe Contact) + smpServer :: SMPServer } -- | GroupMessage ChatGroup ByteString -- | AddToGroup Contact data ChatCommand = ChatHelp - | AddContact Contact - | AcceptContact Contact SMPQueueInfo - | ChatWith Contact - | SetName Contact + | MarkdownHelp + | AddConnection Contact + | Connect Contact SMPQueueInfo + | DeleteConnection Contact | SendMessage Contact ByteString chatCommandP :: Parser ChatCommand chatCommandP = - "/help" $> ChatHelp - <|> "/add " *> (AddContact <$> contact) - <|> "/accept " *> acceptContact - <|> "/chat " *> chatWith - <|> "/name " *> setName + ("/help" <|> "/h") $> ChatHelp + <|> ("/markdown" <|> "/m") $> MarkdownHelp + <|> ("/add " <|> "/a ") *> (AddConnection <$> contact) + <|> ("/connect " <> "/c ") *> connect + <|> ("/delete " <> "/d ") *> (DeleteConnection <$> contact) <|> "@" *> sendMessage where - acceptContact = AcceptContact <$> contact <* A.space <*> smpQueueInfoP - chatWith = ChatWith <$> contact - setName = SetName <$> contact + connect = Connect <$> contact <* A.space <*> smpQueueInfoP sendMessage = SendMessage <$> contact <* A.space <*> A.takeByteString contact = Contact <$> A.takeTill (== ' ') data ChatResponse = ChatHelpInfo + | MarkdownInfo | Invitation SMPQueueInfo | Connected Contact + | Confirmation Contact | ReceivedMessage Contact ByteString | Disconnected Contact | YesYes @@ -90,40 +94,77 @@ data ChatResponse | ChatError AgentErrorType | NoChatResponse -serializeChatResponse :: Maybe Contact -> ChatResponse -> ByteString -serializeChatResponse name = \case +serializeChatResponse :: ChatResponse -> [StyledString] +serializeChatResponse = \case ChatHelpInfo -> chatHelpInfo - Invitation qInfo -> "ask your contact to enter: /accept " <> showName name <> " " <> serializeSmpQueueInfo qInfo - Connected c -> ttyContact c <> " connected" - ReceivedMessage c t -> ttyFromContact c <> " " <> t - Disconnected c -> "disconnected from " <> ttyContact c <> " - try \"/chat " <> toBs c <> "\"" - YesYes -> "you got it!" - ErrorInput t -> "invalid input: " <> t - ChatError e -> "chat error: " <> bshow e - NoChatResponse -> "" + MarkdownInfo -> markdownInfo + Invitation qInfo -> + [ "pass this invitation to your contact (via any channel): ", + "", + (bPlain . serializeSmpQueueInfo) qInfo, + "", + "and ask them to connect: /c " + ] + Connected c -> [ttyContact c <> " connected"] + Confirmation c -> [ttyContact c <> " ok"] + ReceivedMessage c t -> prependFirst (ttyFromContact c) $ msgPlain t + Disconnected c -> ["disconnected from " <> ttyContact c <> " - try \"/chat " <> bPlain (toBs c) <> "\""] + YesYes -> ["you got it!"] + ErrorInput t -> ["invalid input: " <> bPlain t] + ChatError e -> ["chat error: " <> plain (show e)] + NoChatResponse -> [""] where - showName Nothing = "" - showName (Just (Contact a)) = a + prependFirst :: StyledString -> [StyledString] -> [StyledString] + prependFirst s [] = [s] + prependFirst s (s' : ss) = (s <> s') : ss + msgPlain :: ByteString -> [StyledString] + msgPlain = map styleMarkdownText . T.lines . safeDecodeUtf8 -chatHelpInfo :: ByteString +chatHelpInfo :: [StyledString] chatHelpInfo = - "Using chat:\n\ - \/add - create invitation to send out-of-band\n\ - \ to your contact \n\ - \ (any unique string without spaces)\n\ - \/accept - accept \n\ - \ (a string that starts from \"smp::\")\n\ - \ from your contact \n\ - \/name - set to use in invitations\n\ - \@ - send (any string) to contact \n\ - \ @ can be omitted to send to previous" + map + styleMarkdown + [ "Using chat:", + highlight "/add " <> " - create invitation to send out-of-band to your contact ", + " ( is the alias you choose to message your contact)", + highlight "/connect " <> " - connect using ", + " (a string returned by /add that starts from \"smp::\")", + " if /connect is used by your contact,", + " is the alias your contact chooses to message you", + highlight "@ " <> " - send (any string) to contact ", + " @ will be auto-typed to send to the previous contact -", + " just start typing the message!", + highlight "/delete" <> " - delete contact and all messages you had with them", + highlight "/markdown" <> " - markdown cheat-sheet", + "", + "Commands can be abbreviated to 1 letter: ", + listCommands ["/h", "/a", "/c", "/d", "/m"] + ] + where + listCommands = mconcat . intersperse ", " . map highlight + highlight = Markdown (Colored Cyan) + +markdownInfo :: [StyledString] +markdownInfo = + map + styleMarkdown + [ "Markdown:", + " *bold* - " <> Markdown Bold "bold text", + " _italic_ - " <> Markdown Italic "italic text" <> " (shown as underlined)", + " +underlined+ - " <> Markdown Underline "underlined text", + " ~strikethrough~ - " <> Markdown StrikeThrough "strikethrough text" <> " (shown as inverse)", + " `code snippet` - " <> Markdown Snippet "a + b // no *markdown* here", + " !1 text! - " <> red "red text" <> " (1-6: red, green, blue, yellow, cyan, magenta)", + " #secret# - " <> Markdown Secret "secret text" <> " (can be copy-pasted)" + ] + where + red = Markdown (Colored Red) main :: IO () main = do - ChatOpts {dbFileName, smpServer, name, termMode} <- welcomeGetOpts - let user = Contact <$> name - t <- getChatClient smpServer user - ct <- newChatTerminal (tbqSize cfg) user termMode + ChatOpts {dbFileName, smpServer, termMode} <- welcomeGetOpts + t <- getChatClient smpServer + ct <- newChatTerminal (tbqSize cfg) termMode -- setLogLevel LogInfo -- LogError -- withGlobalLogging logCfg $ do env <- newSMPAgentEnv cfg {dbFile = dbFileName} @@ -132,22 +173,12 @@ main = do welcomeGetOpts :: IO ChatOpts welcomeGetOpts = do appDir <- getAppUserDataDirectory "simplex" - opts@ChatOpts {dbFileName, termMode} <- getChatOpts appDir - putStrLn "simpleX chat prototype" + opts@ChatOpts {dbFileName} <- getChatOpts appDir + putStrLn "SimpleX chat prototype" putStrLn $ "db: " <> dbFileName - when (os == "mingw32") $ windowsWarning termMode - putStrLn "type \"/help\" for usage information" + putStrLn "type \"/help\" or \"/h\" for usage info" pure opts -windowsWarning :: TermMode -> IO () -windowsWarning = \case - m@TermModeBasic -> do - putStrLn $ "running in Windows (terminal mode is " <> termModeName m <> ", no utf8 support)" - putStrLn "it is recommended to use Windows Subsystem for Linux (WSL)" - m -> do - putStrLn $ "running in Windows, terminal mode " <> termModeName m <> " is not supported" - exitFailure - dogFoodChat :: ChatClient -> ChatTerminal -> Env -> IO () dogFoodChat t ct env = do c <- runReaderT getSMPAgentClient env @@ -160,38 +191,32 @@ dogFoodChat t ct env = do chatTerminal ct ] -getChatClient :: SMPServer -> Maybe Contact -> IO ChatClient -getChatClient srv name = atomically $ newChatClient (tbqSize cfg) srv name +getChatClient :: SMPServer -> IO ChatClient +getChatClient srv = atomically $ newChatClient (tbqSize cfg) srv -newChatClient :: Natural -> SMPServer -> Maybe Contact -> STM ChatClient -newChatClient qSize smpServer name = do +newChatClient :: Natural -> SMPServer -> STM ChatClient +newChatClient qSize smpServer = do inQ <- newTBQueue qSize outQ <- newTBQueue qSize - username <- newTVar name - return ChatClient {inQ, outQ, smpServer, username} + return ChatClient {inQ, outQ, smpServer} receiveFromChatTerm :: ChatClient -> ChatTerminal -> IO () receiveFromChatTerm t ct = forever $ do atomically (readTBQueue $ inputQ ct) - >>= processOrError . parseAll chatCommandP + >>= processOrError . parseAll chatCommandP . encodeUtf8 . T.pack where processOrError = \case - Left err -> atomically . writeTBQueue (outQ t) . ErrorInput $ B.pack err - Right ChatHelp -> atomically . writeTBQueue (outQ t) $ ChatHelpInfo - Right (SetName a) -> atomically $ do - let user = Just a - writeTVar (username (t :: ChatClient)) user - updateUsername ct user - writeTBQueue (outQ t) YesYes + Left err -> writeOutQ . ErrorInput $ B.pack err + Right ChatHelp -> writeOutQ ChatHelpInfo + Right MarkdownHelp -> writeOutQ MarkdownInfo Right cmd -> atomically $ writeTBQueue (inQ t) cmd + writeOutQ = atomically . writeTBQueue (outQ t) sendToChatTerm :: ChatClient -> ChatTerminal -> IO () -sendToChatTerm ChatClient {outQ, username} ChatTerminal {outputQ} = forever $ do +sendToChatTerm ChatClient {outQ} ChatTerminal {outputQ} = forever $ do atomically (readTBQueue outQ) >>= \case NoChatResponse -> return () - resp -> do - name <- readTVarIO username - atomically . writeTBQueue outputQ $ serializeChatResponse name resp + resp -> atomically . writeTBQueue outputQ $ serializeChatResponse resp sendToAgent :: ChatClient -> ChatTerminal -> AgentClient -> IO () sendToAgent ChatClient {inQ, smpServer} ct AgentClient {rcvQ} = do @@ -202,19 +227,18 @@ sendToAgent ChatClient {inQ, smpServer} ct AgentClient {rcvQ} = do setActiveContact cmd where setActiveContact :: ChatCommand -> STM () - setActiveContact cmd = - writeTVar (activeContact ct) $ case cmd of - ChatWith a -> Just a - SendMessage a _ -> Just a - _ -> Nothing + setActiveContact = \case + SendMessage a _ -> setActive ct a + DeleteConnection a -> unsetActive ct a + _ -> pure () agentTransmission :: ChatCommand -> Maybe (ATransmission 'Client) agentTransmission = \case - AddContact a -> transmission a $ NEW smpServer - AcceptContact a qInfo -> transmission a $ JOIN qInfo $ ReplyVia smpServer - ChatWith a -> transmission a SUB + AddConnection a -> transmission a $ NEW smpServer + Connect a qInfo -> transmission a $ JOIN qInfo $ ReplyVia smpServer + DeleteConnection a -> transmission a DEL SendMessage a msg -> transmission a $ SEND msg ChatHelp -> Nothing - SetName _ -> Nothing + MarkdownHelp -> Nothing transmission :: Contact -> ACommand 'Client -> Maybe (ATransmission 'Client) transmission (Contact a) cmd = Just ("1", a, cmd) @@ -227,17 +251,25 @@ receiveFromAgent t ct c = forever . atomically $ do chatResponse :: ATransmission 'Agent -> ChatResponse chatResponse (_, a, resp) = case resp of INV qInfo -> Invitation qInfo - CON -> Connected $ Contact a - END -> Disconnected $ Contact a - MSG {m_body} -> ReceivedMessage (Contact a) m_body + CON -> Connected contact + END -> Disconnected contact + MSG {m_body} -> ReceivedMessage contact m_body SENT _ -> NoChatResponse - OK -> Connected $ Contact a -- hack for subscribing to all + OK -> Confirmation contact ERR e -> ChatError e + where + contact = Contact a setActiveContact :: ChatResponse -> STM () setActiveContact = \case - Connected a -> set $ Just a - ReceivedMessage a _ -> set $ Just a - Disconnected _ -> set Nothing - _ -> return () - where - set a = writeTVar (activeContact ct) a + Connected a -> setActive ct a + ReceivedMessage a _ -> setActive ct a + Disconnected a -> unsetActive ct a + _ -> pure () + +setActive :: ChatTerminal -> Contact -> STM () +setActive ct = writeTVar (activeContact ct) . Just + +unsetActive :: ChatTerminal -> Contact -> STM () +unsetActive ct a = modifyTVar (activeContact ct) unset + where + unset a' = if Just a == a' then Nothing else a' diff --git a/Styled.hs b/Styled.hs new file mode 100644 index 0000000000..87f28a7867 --- /dev/null +++ b/Styled.hs @@ -0,0 +1,60 @@ +module Styled + ( StyledString (..), + bPlain, + plain, + styleMarkdown, + styleMarkdownText, + sLength, + ) +where + +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.String +import Data.Text (Text) +import qualified Data.Text as T +import Simplex.Markdown +import System.Console.ANSI.Types + +data StyledString = Styled [SGR] String | StyledString :<>: StyledString + +instance Semigroup StyledString where (<>) = (:<>:) + +instance Monoid StyledString where mempty = plain "" + +instance IsString StyledString where fromString = plain + +plain :: String -> StyledString +plain = Styled [] + +bPlain :: ByteString -> StyledString +bPlain = Styled [] . B.unpack + +styleMarkdownText :: Text -> StyledString +styleMarkdownText = styleMarkdown . parseMarkdown + +styleMarkdown :: Markdown -> StyledString +styleMarkdown (s1 :|: s2) = styleMarkdown s1 <> styleMarkdown s2 +styleMarkdown (Markdown Snippet s) = '`' `wrap` styled Snippet s +styleMarkdown (Markdown Secret s) = '#' `wrap` styled Secret s +styleMarkdown (Markdown f s) = styled f s + +wrap :: Char -> StyledString -> StyledString +wrap c s = plain [c] <> s <> plain [c] + +styled :: Format -> Text -> StyledString +styled f = Styled sgr . T.unpack + where + sgr = case f of + Bold -> [SetConsoleIntensity BoldIntensity] + Italic -> [SetUnderlining SingleUnderline, SetItalicized True] + Underline -> [SetUnderlining SingleUnderline] + StrikeThrough -> [SetSwapForegroundBackground True] + Colored c -> [SetColor Foreground Vivid c] + Secret -> [SetColor Foreground Dull Black, SetColor Background Dull Black] + Snippet -> [] + NoFormat -> [] + +sLength :: StyledString -> Int +sLength (Styled _ s) = length s +sLength (s1 :<>: s2) = sLength s1 + sLength s2 diff --git a/Types.hs b/Types.hs index ae03c01989..016073cbd0 100644 --- a/Types.hs +++ b/Types.hs @@ -4,7 +4,7 @@ module Types where import Data.ByteString.Char8 (ByteString) -newtype Contact = Contact {toBs :: ByteString} +newtype Contact = Contact {toBs :: ByteString} deriving (Eq) data TermMode = TermModeBasic | TermModeEditor deriving (Eq)