From b61b1e838482863fc0d9eac7201585a9441b2984 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 7 Apr 2021 20:20:32 +0100 Subject: [PATCH 01/14] Support windows terminal in basic mode (#80) * add terminal package * basic terminal mode with utf8 support in windows * fix terminal input in basic mode on mac * test code * send StyledString to ChatTerminal * clean up * support StyledString with System.Terminal * minor style change * clean up * minor style change --- ChatOptions.hs | 3 +- ChatTerminal.hs | 65 +++++++++++++++++---------------------- Main.hs | 35 ++++++++++++--------- Styled.hs | 29 ++++++++++++++++++ Terminal.hs | 81 +++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 161 insertions(+), 52 deletions(-) create mode 100644 Styled.hs create mode 100644 Terminal.hs diff --git a/ChatOptions.hs b/ChatOptions.hs index 0a7ff89f09..e51f576fdb 100644 --- a/ChatOptions.hs +++ b/ChatOptions.hs @@ -3,6 +3,7 @@ module ChatOptions (getChatOpts, ChatOpts (..)) where import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Options.Applicative import Simplex.Messaging.Agent.Transmission (SMPServer (..), smpServerP) @@ -11,7 +12,7 @@ import System.Info (os) import Types data ChatOpts = ChatOpts - { name :: Maybe B.ByteString, + { name :: Maybe ByteString, dbFileName :: String, smpServer :: SMPServer, termMode :: TermMode diff --git a/ChatTerminal.hs b/ChatTerminal.hs index ccc5a87616..9797fb040a 100644 --- a/ChatTerminal.hs +++ b/ChatTerminal.hs @@ -17,21 +17,19 @@ 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 Styled import qualified System.Console.ANSI as C import System.IO +import Terminal (getLn, putLn) import Types data ChatTerminal = ChatTerminal - { inputQ :: TBQueue ByteString, - outputQ :: TBQueue ByteString, + { inputQ :: TBQueue String, + outputQ :: TBQueue StyledString, activeContact :: TVar (Maybe Contact), username :: TVar (Maybe Contact), termMode :: TermMode, @@ -105,7 +103,7 @@ chatTerminal ct receiveFromTTY :: ChatTerminal -> IO () receiveFromTTY ct = - forever $ getLn stdin >>= atomically . writeTBQueue (inputQ ct) + forever $ getLn >>= atomically . writeTBQueue (inputQ ct) withTermLock :: ChatTerminal -> IO () -> IO () withTermLock ChatTerminal {termLock} action = do @@ -130,9 +128,9 @@ receiveFromTTY' ct@ChatTerminal {inputQ, activeContact, termSize, termState} = msg <- atomically $ do ts <- readTVar termState writeTVar termState $ ts {inputString = "", inputPosition = 0} - let msg = encodeUtf8 . T.pack $ inputString ts - writeTBQueue inputQ msg - return msg + let s = inputString ts + writeTBQueue inputQ s + return s withTermLock ct . printMessage ct $ highlightContact msg updateTermState :: Maybe Contact -> Int -> Key -> TerminalState -> TerminalState @@ -183,13 +181,11 @@ receiveFromTTY' ct@ChatTerminal {inputQ, activeContact, termSize, termState} = in min (length s) $ p + length after - length afterWord ts' (s', p') = ts {inputString = s', inputPosition = p'} -highlightContact :: ByteString -> ByteString +highlightContact :: String -> StyledString highlightContact = \case "" -> "" - s -> - if B.head s == '@' - then let (c, rest) = B.span (/= ' ') $ B.drop 1 s in ttyToContact (Contact c) <> rest - else s + s@('@' : _) -> let (c, rest) = span (/= ' ') s in Styled selfSGR c <> plain rest + s -> plain s updateInput :: ChatTerminal -> IO () updateInput ct@ChatTerminal {termSize, termState, nextMessageRow} = do @@ -233,7 +229,7 @@ promptString :: Maybe Contact -> String promptString a = maybe "" (B.unpack . toBs) a <> "> " sendToTTY :: ChatTerminal -> IO () -sendToTTY ct = forever $ readOutputQ ct >>= putLn stdout +sendToTTY ct = forever $ readOutputQ ct >>= putLn sendToTTY' :: ChatTerminal -> IO () sendToTTY' ct = forever $ do @@ -242,10 +238,10 @@ sendToTTY' ct = forever $ do printMessage ct msg updateInput ct -readOutputQ :: ChatTerminal -> IO ByteString +readOutputQ :: ChatTerminal -> IO StyledString readOutputQ = atomically . readTBQueue . outputQ -printMessage :: ChatTerminal -> ByteString -> IO () +printMessage :: ChatTerminal -> StyledString -> IO () printMessage ChatTerminal {termSize, nextMessageRow} msg = do nmr <- readTVarIO nextMessageRow C.setCursorPosition nmr 0 @@ -253,20 +249,21 @@ printMessage ChatTerminal {termSize, nextMessageRow} msg = do 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'] + printLines :: Int -> StyledString -> IO Int + printLines tw ss = do + let s = styledToANSITerm ss + ls + | null s = [""] + | otherwise = lines s <> ["" | last s == '\n'] print_ ls - return $ foldl (\lc l -> lc + (B.length l `div` tw) + 1) 0 ls + return $ foldl (\lc l -> lc + (length l `div` tw) + 1) 0 ls - print_ :: [ByteString] -> IO () + print_ :: [String] -> IO () print_ [] = return () print_ (l : ls) = do - B.hPut stdout l + putStr l C.clearFromCursorToLineEnd - B.hPut stdout "\n" + putStr "\n" print_ ls getKey :: IO Key @@ -302,20 +299,14 @@ setTTY mode = do hSetBuffering stdin mode hSetBuffering stdout mode -ttyContact :: Contact -> ByteString -ttyContact (Contact a) = withSGR contactSGR a +ttyContact :: Contact -> StyledString +ttyContact (Contact a) = Styled contactSGR $ B.unpack a -ttyFromContact :: Contact -> ByteString -ttyFromContact (Contact a) = withSGR contactSGR $ a <> ">" - -ttyToContact :: Contact -> ByteString -ttyToContact (Contact a) = withSGR selfSGR $ "@" <> a +ttyFromContact :: Contact -> StyledString +ttyFromContact (Contact a) = Styled contactSGR $ B.unpack 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/Main.hs b/Main.hs index ac33b81e50..858997d6c3 100644 --- a/Main.hs +++ b/Main.hs @@ -20,13 +20,16 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) +import qualified Data.Text as T +import Data.Text.Encoding import Numeric.Natural 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.Util (bshow, raceAny_) +import Simplex.Messaging.Util (raceAny_) +import Styled import System.Directory (getAppUserDataDirectory) import System.Exit (exitFailure) import System.Info (os) @@ -89,22 +92,24 @@ data ChatResponse | ChatError AgentErrorType | NoChatResponse -serializeChatResponse :: Maybe Contact -> ChatResponse -> ByteString +serializeChatResponse :: Maybe Contact -> ChatResponse -> StyledString serializeChatResponse name = \case ChatHelpInfo -> chatHelpInfo - Invitation qInfo -> "ask your contact to enter: /accept " <> showName name <> " " <> serializeSmpQueueInfo qInfo + Invitation qInfo -> "ask your contact to enter: /accept " <> showName name <> " " <> (bPlain . serializeSmpQueueInfo) qInfo Connected c -> ttyContact c <> " connected" - ReceivedMessage c t -> ttyFromContact c <> " " <> t - Disconnected c -> "disconnected from " <> ttyContact c <> " - try \"/chat " <> toBs c <> "\"" + ReceivedMessage c t -> ttyFromContact c <> " " <> msgPlain t + Disconnected c -> "disconnected from " <> ttyContact c <> " - try \"/chat " <> bPlain (toBs c) <> "\"" YesYes -> "you got it!" - ErrorInput t -> "invalid input: " <> t - ChatError e -> "chat error: " <> bshow e + ErrorInput t -> "invalid input: " <> bPlain t + ChatError e -> "chat error: " <> plain (show e) NoChatResponse -> "" where showName Nothing = "" - showName (Just (Contact a)) = a + showName (Just (Contact a)) = bPlain a + msgPlain = plain . T.unpack . decodeUtf8With onError + onError _ _ = Just '?' -chatHelpInfo :: ByteString +chatHelpInfo :: StyledString chatHelpInfo = "Using chat:\n\ \/add - create invitation to send out-of-band\n\ @@ -172,7 +177,7 @@ newChatClient qSize smpServer name = do receiveFromChatTerm :: ChatClient -> ChatTerminal -> IO () receiveFromChatTerm t ct = forever $ do atomically (readTBQueue $ inputQ ct) - >>= processOrError . A.parseOnly (chatCommandP <* A.endOfInput) + >>= processOrError . A.parseOnly (chatCommandP <* A.endOfInput) . encodeUtf8 . T.pack where processOrError = \case Left err -> atomically . writeTBQueue (outQ t) . ErrorInput $ B.pack err @@ -226,12 +231,14 @@ 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 -> Connected contact -- hack for subscribing to all ERR e -> ChatError e + where + contact = Contact a setActiveContact :: ChatResponse -> STM () setActiveContact = \case Connected a -> set $ Just a diff --git a/Styled.hs b/Styled.hs new file mode 100644 index 0000000000..f355a55c70 --- /dev/null +++ b/Styled.hs @@ -0,0 +1,29 @@ +module Styled (StyledString (..), plain, bPlain, styledToANSITerm, styledToPlain) where + +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.String +import System.Console.ANSI (SGR (..), setSGRCode) + +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 + +styledToANSITerm :: StyledString -> String +styledToANSITerm (Styled [] s) = s +styledToANSITerm (Styled sgr s) = setSGRCode sgr <> s <> setSGRCode [Reset] +styledToANSITerm (s1 :<>: s2) = styledToANSITerm s1 <> styledToANSITerm s2 + +styledToPlain :: StyledString -> String +styledToPlain (Styled _ s) = s +styledToPlain (s1 :<>: s2) = styledToPlain s1 <> styledToPlain s2 diff --git a/Terminal.hs b/Terminal.hs new file mode 100644 index 0000000000..916eb06d17 --- /dev/null +++ b/Terminal.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE LambdaCase #-} + +module Terminal 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 + +putLn :: StyledString -> IO () +putLn s = + withTerminal . runTerminalT $ + putStyled s >> C.putLn >> flush + +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 + +getTermLine :: MonadTerminal m => m String +getTermLine = getChars "" + where + getChars s = awaitEvent >>= processKey s + processKey s = \case + Right (KeyEvent 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 + Left Interrupt -> liftIO exitSuccess + _ -> getChars s From bac96b44330d963eb6e056c37952dfa8fd78b173 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Thu, 8 Apr 2021 19:32:38 +0100 Subject: [PATCH 02/14] Markdown (#81) * Markdown type * Markdown parser (WIP) * fix markdown parser * style markdown in messages * one-letter color abbreviations in markdown --- ChatTerminal.hs | 15 ++++-- Main.hs | 3 +- SimplexMarkdown.hs | 122 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 134 insertions(+), 6 deletions(-) create mode 100644 SimplexMarkdown.hs diff --git a/ChatTerminal.hs b/ChatTerminal.hs index 9797fb040a..643955ad76 100644 --- a/ChatTerminal.hs +++ b/ChatTerminal.hs @@ -20,7 +20,9 @@ import Control.Monad import qualified Data.ByteString.Char8 as B import Data.List (dropWhileEnd) import Data.Maybe (fromMaybe) +import qualified Data.Text as T import Numeric.Natural +import SimplexMarkdown import Styled import qualified System.Console.ANSI as C import System.IO @@ -131,7 +133,7 @@ receiveFromTTY' ct@ChatTerminal {inputQ, activeContact, termSize, termState} = let s = inputString ts writeTBQueue inputQ s return s - withTermLock ct . printMessage ct $ highlightContact msg + withTermLock ct . printMessage ct $ styleMessage msg updateTermState :: Maybe Contact -> Int -> Key -> TerminalState -> TerminalState updateTermState ac tw key ts@TerminalState {inputString = s, inputPosition = p} = case key of @@ -181,11 +183,14 @@ receiveFromTTY' ct@ChatTerminal {inputQ, activeContact, termSize, termState} = in min (length s) $ p + length after - length afterWord ts' (s', p') = ts {inputString = s', inputPosition = p'} -highlightContact :: String -> StyledString -highlightContact = \case +styleMessage :: String -> StyledString +styleMessage = \case "" -> "" - s@('@' : _) -> let (c, rest) = span (/= ' ') s in Styled selfSGR c <> plain rest - s -> plain s + s@('@' : _) -> let (c, rest) = span (/= ' ') s in Styled selfSGR c <> markdown rest + s -> markdown s + where + markdown :: String -> StyledString + markdown = styleMarkdown . parseMarkdown . T.pack updateInput :: ChatTerminal -> IO () updateInput ct@ChatTerminal {termSize, termState, nextMessageRow} = do diff --git a/Main.hs b/Main.hs index 858997d6c3..15b6c0ff1d 100644 --- a/Main.hs +++ b/Main.hs @@ -29,6 +29,7 @@ import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Transmission import Simplex.Messaging.Client (smpDefaultConfig) import Simplex.Messaging.Util (raceAny_) +import SimplexMarkdown import Styled import System.Directory (getAppUserDataDirectory) import System.Exit (exitFailure) @@ -106,7 +107,7 @@ serializeChatResponse name = \case where showName Nothing = "" showName (Just (Contact a)) = bPlain a - msgPlain = plain . T.unpack . decodeUtf8With onError + msgPlain = styleMarkdown . parseMarkdown . decodeUtf8With onError onError _ _ = Just '?' chatHelpInfo :: StyledString diff --git a/SimplexMarkdown.hs b/SimplexMarkdown.hs new file mode 100644 index 0000000000..46596db0ef --- /dev/null +++ b/SimplexMarkdown.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module SimplexMarkdown where + +import Control.Applicative ((<|>)) +import Data.Attoparsec.Text (Parser) +import qualified Data.Attoparsec.Text as A +import Data.Either (fromRight) +import Data.Functor (($>)) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.String +import Data.Text (Text) +import qualified Data.Text as T +import Styled +import System.Console.ANSI.Types + +data Markdown = Markdown Format Text | Markdown :|: Markdown + deriving (Show) + +data Format + = Bold + | Italic + | Underline + | StrikeThrough + | Colored Color + | NoFormat + deriving (Show) + +instance Semigroup Markdown where (<>) = (:|:) + +instance Monoid Markdown where mempty = unmarked "" + +instance IsString Markdown where fromString = unmarked . T.pack + +unmarked :: Text -> Markdown +unmarked = Markdown NoFormat + +styleMarkdown :: Markdown -> StyledString +styleMarkdown (s1 :|: s2) = styleMarkdown s1 <> styleMarkdown s2 +styleMarkdown (Markdown f s) = Styled sgr $ T.unpack s + 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] + NoFormat -> [] + +formats :: Map Char Format +formats = + M.fromList + [ ('*', Bold), + ('_', Italic), + ('+', Underline), + ('~', StrikeThrough), + ('^', Colored White) + ] + +colors :: Map Text Color +colors = + M.fromList + [ ("red", Red), + ("green", Green), + ("blue", Blue), + ("yellow", Yellow), + ("cyan", Cyan), + ("magenta", Magenta), + ("r", Red), + ("g", Green), + ("b", Blue), + ("y", Yellow), + ("c", Cyan), + ("m", Magenta) + ] + +parseMarkdown :: Text -> Markdown +parseMarkdown s = fromRight (unmarked s) $ A.parseOnly (markdownP <* A.endOfInput) s + +markdownP :: Parser Markdown +markdownP = merge <$> A.many' fragmentP + where + merge :: [Markdown] -> Markdown + merge [] = "" + merge [f] = f + merge (f : fs) = foldl (:|:) f fs + fragmentP :: Parser Markdown + fragmentP = + A.anyChar >>= \case + ' ' -> unmarked . (" " <>) <$> A.takeWhile (== ' ') + c -> case M.lookup c formats of + Just (Colored White) -> coloredP + Just f -> formattedP c "" f + Nothing -> unformattedP c + formattedP :: Char -> Text -> Format -> Parser Markdown + formattedP c p f = do + s <- A.takeTill (== c) + (A.char c $> Markdown f s) <|> noFormat (T.singleton c <> p <> s) + coloredP :: Parser Markdown + coloredP = do + color <- A.takeWhile (\c -> c /= ' ' && c /= '^') + case M.lookup color colors of + Just c -> + let f = Colored c + in (A.char ' ' *> formattedP '^' (color <> " ") f) + <|> (A.char '^' $> Markdown f color) + <|> noFormat ("^" <> color) + _ -> noFormat ("^" <> color) + unformattedP :: Char -> Parser Markdown + unformattedP c = unmarked . (T.singleton c <>) <$> wordsP + wordsP :: Parser Text + wordsP = do + s <- (<>) <$> A.takeTill (== ' ') <*> A.takeWhile (== ' ') + A.peekChar >>= \case + Nothing -> pure s + Just c -> case M.lookup c formats of + Just _ -> pure s + Nothing -> (s <>) <$> wordsP + noFormat :: Text -> Parser Markdown + noFormat = pure . unmarked From d0163ccd56da85384bc08534e32b74ad9a182d33 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Thu, 8 Apr 2021 20:20:06 +0100 Subject: [PATCH 03/14] refactor chat terminal (#83) --- ChatTerminal.hs | 240 ++------------------------- Terminal.hs => ChatTerminal/Basic.hs | 2 +- ChatTerminal/Core.hs | 130 +++++++++++++++ ChatTerminal/POSIX.hs | 102 ++++++++++++ 4 files changed, 247 insertions(+), 227 deletions(-) rename Terminal.hs => ChatTerminal/Basic.hs (98%) create mode 100644 ChatTerminal/Core.hs create mode 100644 ChatTerminal/POSIX.hs diff --git a/ChatTerminal.hs b/ChatTerminal.hs index 643955ad76..3f80dde16c 100644 --- a/ChatTerminal.hs +++ b/ChatTerminal.hs @@ -13,62 +13,19 @@ module ChatTerminal ) where +import ChatTerminal.Basic (getLn, putLn) +import ChatTerminal.Core +import ChatTerminal.POSIX import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race_) import Control.Concurrent.STM import Control.Monad -import qualified Data.ByteString.Char8 as B -import Data.List (dropWhileEnd) import Data.Maybe (fromMaybe) -import qualified Data.Text as T import Numeric.Natural -import SimplexMarkdown import Styled import qualified System.Console.ANSI as C -import System.IO -import Terminal (getLn, putLn) import Types -data ChatTerminal = ChatTerminal - { inputQ :: TBQueue String, - outputQ :: TBQueue StyledString, - 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 inputQ <- newTBQueueIO qSize @@ -94,27 +51,29 @@ newTermState user = chatTerminal :: ChatTerminal -> IO () chatTerminal ct | termSize ct == (0, 0) || termMode ct == TermModeBasic = - run receiveFromTTY sendToTTY + run basicReceiveFromTTY basicSendToTTY | otherwise = do - setTTY NoBuffering - hSetEcho stdin False + initTTY updateInput ct - run receiveFromTTY' sendToTTY' + run receiveFromTTY sendToTTY where run receive send = race_ (receive ct) (send ct) -receiveFromTTY :: ChatTerminal -> IO () -receiveFromTTY ct = +basicReceiveFromTTY :: ChatTerminal -> IO () +basicReceiveFromTTY ct = forever $ getLn >>= atomically . writeTBQueue (inputQ ct) +basicSendToTTY :: ChatTerminal -> IO () +basicSendToTTY ct = forever $ readOutputQ ct >>= putLn + withTermLock :: ChatTerminal -> IO () -> IO () withTermLock ChatTerminal {termLock} action = do _ <- atomically $ takeTMVar termLock action atomically $ putTMVar termLock () -receiveFromTTY' :: ChatTerminal -> IO () -receiveFromTTY' ct@ChatTerminal {inputQ, activeContact, termSize, termState} = +receiveFromTTY :: ChatTerminal -> IO () +receiveFromTTY ct@ChatTerminal {inputQ, activeContact, termSize, termState} = forever $ getKey >>= processKey >> withTermLock ct (updateInput ct) where @@ -135,109 +94,8 @@ receiveFromTTY' ct@ChatTerminal {inputQ, activeContact, termSize, termState} = return s withTermLock ct . printMessage ct $ styleMessage 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'} - -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 = styleMarkdown . parseMarkdown . T.pack - -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 <> "> " - sendToTTY :: ChatTerminal -> IO () -sendToTTY ct = forever $ readOutputQ ct >>= putLn - -sendToTTY' :: ChatTerminal -> IO () -sendToTTY' ct = forever $ do +sendToTTY ct = forever $ do msg <- readOutputQ ct withTermLock ct $ do printMessage ct msg @@ -245,73 +103,3 @@ sendToTTY' ct = forever $ do readOutputQ :: ChatTerminal -> IO StyledString readOutputQ = atomically . readTBQueue . outputQ - -printMessage :: ChatTerminal -> StyledString -> 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 -> StyledString -> IO Int - printLines tw ss = do - let s = styledToANSITerm ss - ls - | null s = [""] - | otherwise = lines s <> ["" | last s == '\n'] - print_ ls - return $ foldl (\lc l -> lc + (length l `div` tw) + 1) 0 ls - - print_ :: [String] -> IO () - print_ [] = return () - print_ (l : ls) = do - putStr l - C.clearFromCursorToLineEnd - putStr "\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 -> StyledString -ttyContact (Contact a) = Styled contactSGR $ B.unpack a - -ttyFromContact :: Contact -> StyledString -ttyFromContact (Contact a) = Styled contactSGR $ B.unpack 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] diff --git a/Terminal.hs b/ChatTerminal/Basic.hs similarity index 98% rename from Terminal.hs rename to ChatTerminal/Basic.hs index 916eb06d17..95e4cd43eb 100644 --- a/Terminal.hs +++ b/ChatTerminal/Basic.hs @@ -1,6 +1,6 @@ {-# LANGUAGE LambdaCase #-} -module Terminal where +module ChatTerminal.Basic where import Control.Monad.IO.Class (liftIO) import Styled diff --git a/ChatTerminal/Core.hs b/ChatTerminal/Core.hs new file mode 100644 index 0000000000..72ab58f446 --- /dev/null +++ b/ChatTerminal/Core.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module ChatTerminal.Core where + +import Control.Concurrent.STM +import qualified Data.ByteString.Char8 as B +import Data.List (dropWhileEnd) +import qualified Data.Text as T +import SimplexMarkdown +import Styled +import System.Console.ANSI.Types +import Types + +data ChatTerminal = ChatTerminal + { inputQ :: TBQueue String, + outputQ :: TBQueue StyledString, + 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 + } + +data Key + = KeyLeft + | KeyRight + | KeyUp + | KeyDown + | KeyAltLeft + | KeyAltRight + | KeyCtrlLeft + | KeyCtrlRight + | KeyShiftLeft + | KeyShiftRight + | KeyEnter + | KeyBack + | KeyTab + | KeyEsc + | KeyChars String + | KeyUnsupported + deriving (Eq) + +inputHeight :: TerminalState -> ChatTerminal -> Int +inputHeight ts ct = length (inputPrompt ts <> inputString ts) `div` snd (termSize ct) + 1 + +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'} + +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 = styleMarkdown . parseMarkdown . T.pack + +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 <> "> " + +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/POSIX.hs b/ChatTerminal/POSIX.hs new file mode 100644 index 0000000000..c4dcb95fa9 --- /dev/null +++ b/ChatTerminal/POSIX.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} + +module ChatTerminal.POSIX where + +import ChatTerminal.Core +import Control.Concurrent.STM +import Styled +import qualified System.Console.ANSI as C +import System.IO + +initTTY :: IO () +initTTY = do + hSetEcho stdin False + hSetBuffering stdin NoBuffering + hSetBuffering stdout NoBuffering + +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) + +printMessage :: ChatTerminal -> StyledString -> 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 -> StyledString -> IO Int + printLines tw ss = do + let s = styledToANSITerm ss + ls + | null s = [""] + | otherwise = lines s <> ["" | last s == '\n'] + print_ ls + return $ foldl (\lc l -> lc + (length l `div` tw) + 1) 0 ls + + print_ :: [String] -> IO () + print_ [] = return () + print_ (l : ls) = do + putStr l + C.clearFromCursorToLineEnd + putStr "\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) From ee8814dd2584f2faf2e0fab5bb5dac2d49c26828 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 10 Apr 2021 11:57:28 +0100 Subject: [PATCH 04/14] Windows support in editor mode (#85) * use System.Terminal for "editor" mode (WIP, does not work in POSIX) * fix getKey - only return one event on control keys * fix printing with System.Terminal * different markdown escape for color, added black color * fix color escapes * make black invisible * markdown fixes * remove Key type, fix editor bug, refactor * refactor: use getKey in getTermLine * default mode is "editor", remove windows warning * markdown: code snippet * use ! for color markdown * edit previous input * clean up * use getWindowSize from System.Terminal --- ChatOptions.hs | 8 +-- ChatTerminal.hs | 45 ++++++++------- ChatTerminal/Basic.hs | 22 +++++--- ChatTerminal/Core.hs | 80 ++++++++++++++------------- ChatTerminal/Editor.hs | 55 +++++++++++++++++++ ChatTerminal/POSIX.hs | 102 ---------------------------------- Main.hs | 16 +----- SimplexMarkdown.hs | 122 ----------------------------------------- Styled.hs | 26 ++++++++- 9 files changed, 162 insertions(+), 314 deletions(-) create mode 100644 ChatTerminal/Editor.hs delete mode 100644 ChatTerminal/POSIX.hs delete mode 100644 SimplexMarkdown.hs diff --git a/ChatOptions.hs b/ChatOptions.hs index e51f576fdb..bba310998a 100644 --- a/ChatOptions.hs +++ b/ChatOptions.hs @@ -8,7 +8,6 @@ import qualified Data.ByteString.Char8 as B import Options.Applicative import Simplex.Messaging.Agent.Transmission (SMPServer (..), smpServerP) import System.FilePath (combine) -import System.Info (os) import Types data ChatOpts = ChatOpts @@ -49,14 +48,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 $ A.parseOnly (smpServerP <* A.endOfInput) . B.pack diff --git a/ChatTerminal.hs b/ChatTerminal.hs index 3f80dde16c..e392a0ae2b 100644 --- a/ChatTerminal.hs +++ b/ChatTerminal.hs @@ -13,18 +13,17 @@ module ChatTerminal ) where -import ChatTerminal.Basic (getLn, putLn) +import ChatTerminal.Basic import ChatTerminal.Core -import ChatTerminal.POSIX +import ChatTerminal.Editor import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race_) -import Control.Concurrent.STM import Control.Monad -import Data.Maybe (fromMaybe) import Numeric.Natural import Styled -import qualified System.Console.ANSI as C +import System.Terminal import Types +import UnliftIO.STM newChatTerminal :: Natural -> Maybe Contact -> TermMode -> IO ChatTerminal newChatTerminal qSize user termMode = do @@ -32,8 +31,8 @@ newChatTerminal qSize user termMode = do outputQ <- newTBQueueIO qSize activeContact <- newTVarIO Nothing username <- newTVarIO user - termSize <- fromMaybe (0, 0) <$> C.getTerminalSize - let lastRow = fst termSize - 1 + termSize <- withTerminal . runTerminalT $ getWindowSize + let lastRow = height termSize - 1 termState <- newTVarIO $ newTermState user termLock <- newTMVarIO () nextMessageRow <- newTVarIO lastRow @@ -45,16 +44,16 @@ newTermState user = TerminalState { inputString = "", inputPosition = 0, - inputPrompt = promptString user + inputPrompt = promptString user, + previousInput = "" } chatTerminal :: ChatTerminal -> IO () chatTerminal ct - | termSize ct == (0, 0) || termMode ct == TermModeBasic = + | termSize ct == Size 0 0 || termMode ct == TermModeBasic = run basicReceiveFromTTY basicSendToTTY | otherwise = do - initTTY - updateInput ct + withTerminal . runTerminalT $ updateInput ct run receiveFromTTY sendToTTY where run receive send = race_ (receive ct) (send ct) @@ -64,9 +63,9 @@ basicReceiveFromTTY ct = forever $ getLn >>= atomically . writeTBQueue (inputQ ct) basicSendToTTY :: ChatTerminal -> IO () -basicSendToTTY ct = forever $ readOutputQ ct >>= putLn +basicSendToTTY ct = forever $ atomically (readOutputQ ct) >>= putStyledLn -withTermLock :: ChatTerminal -> IO () -> IO () +withTermLock :: MonadTerminal m => ChatTerminal -> m () -> m () withTermLock ChatTerminal {termLock} action = do _ <- atomically $ takeTMVar termLock action @@ -74,32 +73,32 @@ withTermLock ChatTerminal {termLock} action = do receiveFromTTY :: ChatTerminal -> IO () receiveFromTTY ct@ChatTerminal {inputQ, activeContact, termSize, termState} = - forever $ + 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 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 $ do - msg <- readOutputQ ct +sendToTTY ct = withTerminal . runTerminalT . forever $ do + msg <- atomically $ readOutputQ ct withTermLock ct $ do printMessage ct msg updateInput ct -readOutputQ :: ChatTerminal -> IO StyledString -readOutputQ = atomically . readTBQueue . outputQ +readOutputQ :: ChatTerminal -> STM StyledString +readOutputQ = readTBQueue . outputQ diff --git a/ChatTerminal/Basic.hs b/ChatTerminal/Basic.hs index 95e4cd43eb..52b618e414 100644 --- a/ChatTerminal/Basic.hs +++ b/ChatTerminal/Basic.hs @@ -11,11 +11,15 @@ import System.Terminal as C getLn :: IO String getLn = withTerminal $ runTerminalT getTermLine -putLn :: StyledString -> IO () -putLn s = +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 @@ -55,12 +59,18 @@ setSGR = mapM_ $ \case Cyan -> cyan White -> white +getKey :: MonadTerminal m => m (Key, Modifiers) +getKey = + awaitEvent >>= \case + Left Interrupt -> liftIO exitSuccess + Right (KeyEvent key ms) -> pure (key, ms) + _ -> getKey + getTermLine :: MonadTerminal m => m String getTermLine = getChars "" where - getChars s = awaitEvent >>= processKey s - processKey s = \case - Right (KeyEvent key ms) -> case key of + getChars s = + getKey >>= \(key, ms) -> case key of CharKey c | ms == mempty || ms == shiftKey -> do C.putChar c @@ -77,5 +87,3 @@ getTermLine = getChars "" flush getChars $ if null s then s else tail s _ -> getChars s - Left Interrupt -> liftIO exitSuccess - _ -> getChars s diff --git a/ChatTerminal/Core.hs b/ChatTerminal/Core.hs index 72ab58f446..24856e4984 100644 --- a/ChatTerminal/Core.hs +++ b/ChatTerminal/Core.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module ChatTerminal.Core where @@ -7,9 +8,10 @@ import Control.Concurrent.STM import qualified Data.ByteString.Char8 as B import Data.List (dropWhileEnd) import qualified Data.Text as T -import SimplexMarkdown +import Simplex.Markdown import Styled import System.Console.ANSI.Types +import System.Terminal hiding (insertChars) import Types data ChatTerminal = ChatTerminal @@ -19,7 +21,7 @@ data ChatTerminal = ChatTerminal username :: TVar (Maybe Contact), termMode :: TermMode, termState :: TVar TerminalState, - termSize :: (Int, Int), + termSize :: Size, nextMessageRow :: TVar Int, termLock :: TMVar () } @@ -27,46 +29,48 @@ data ChatTerminal = ChatTerminal data TerminalState = TerminalState { inputPrompt :: String, inputString :: String, - inputPosition :: Int + inputPosition :: Int, + previousInput :: String } -data Key - = KeyLeft - | KeyRight - | KeyUp - | KeyDown - | KeyAltLeft - | KeyAltRight - | KeyCtrlLeft - | KeyCtrlRight - | KeyShiftLeft - | KeyShiftRight - | KeyEnter - | KeyBack - | KeyTab - | KeyEsc - | KeyChars String - | KeyUnsupported - deriving (Eq) - inputHeight :: TerminalState -> ChatTerminal -> Int -inputHeight ts ct = length (inputPrompt ts <> inputString ts) `div` snd (termSize ct) + 1 +inputHeight ts ct = length (inputPrompt ts <> inputString ts) `div` width (termSize ct) + 1 -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 +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 + ArrowKey d -> case d of + Leftwards + | ms == mempty -> setPosition $ max 0 (p - 1) + | ms == shiftKey -> setPosition 0 + | ms == ctrlKey -> setPosition prevWordPos + | ms == altKey -> setPosition prevWordPos + | otherwise -> setPosition p + Rightwards + | ms == mempty -> setPosition $ min (length s) (p + 1) + | ms == shiftKey -> setPosition $ length s + | ms == ctrlKey -> setPosition nextWordPos + | ms == altKey -> setPosition nextWordPos + | otherwise -> setPosition p + Upwards + | ms == mempty && null s -> let s' = previousInput ts in ts' (s', length s') + | ms == mempty -> let p' = p - tw in setPosition $ if p' > 0 then p' else p + | otherwise -> setPosition p + Downwards + | ms == mempty -> let p' = p + tw in setPosition $ if p' <= length s then p' else p + | otherwise -> setPosition p _ -> ts where insertCharsWithContact cs diff --git a/ChatTerminal/Editor.hs b/ChatTerminal/Editor.hs new file mode 100644 index 0000000000..ec1ae19ba1 --- /dev/null +++ b/ChatTerminal/Editor.hs @@ -0,0 +1,55 @@ +{-# 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 :: MonadTerminal m => ChatTerminal -> StyledString -> m () +printMessage ChatTerminal {termSize = Size {height, width}, nextMessageRow} msg = do + nmr <- readTVarIO nextMessageRow + setCursorPosition $ Position {row = nmr, col = 0} + let lc = sLength msg `div` width + 1 + putStyled msg + eraseInLine EraseForward + putLn + flush + atomically . writeTVar nextMessageRow $ min (height - 1) (nmr + lc) diff --git a/ChatTerminal/POSIX.hs b/ChatTerminal/POSIX.hs deleted file mode 100644 index c4dcb95fa9..0000000000 --- a/ChatTerminal/POSIX.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} - -module ChatTerminal.POSIX where - -import ChatTerminal.Core -import Control.Concurrent.STM -import Styled -import qualified System.Console.ANSI as C -import System.IO - -initTTY :: IO () -initTTY = do - hSetEcho stdin False - hSetBuffering stdin NoBuffering - hSetBuffering stdout NoBuffering - -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) - -printMessage :: ChatTerminal -> StyledString -> 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 -> StyledString -> IO Int - printLines tw ss = do - let s = styledToANSITerm ss - ls - | null s = [""] - | otherwise = lines s <> ["" | last s == '\n'] - print_ ls - return $ foldl (\lc l -> lc + (length l `div` tw) + 1) 0 ls - - print_ :: [String] -> IO () - print_ [] = return () - print_ (l : ls) = do - putStr l - C.clearFromCursorToLineEnd - putStr "\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) diff --git a/Main.hs b/Main.hs index 15b6c0ff1d..28407c86bb 100644 --- a/Main.hs +++ b/Main.hs @@ -23,17 +23,15 @@ import Data.Functor (($>)) 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.Util (raceAny_) -import SimplexMarkdown import Styled import System.Directory (getAppUserDataDirectory) -import System.Exit (exitFailure) -import System.Info (os) import Types cfg :: AgentConfig @@ -137,22 +135,12 @@ main = do welcomeGetOpts :: IO ChatOpts welcomeGetOpts = do appDir <- getAppUserDataDirectory "simplex" - opts@ChatOpts {dbFileName, termMode} <- getChatOpts appDir + opts@ChatOpts {dbFileName} <- getChatOpts appDir putStrLn "simpleX chat prototype" putStrLn $ "db: " <> dbFileName - when (os == "mingw32") $ windowsWarning termMode putStrLn "type \"/help\" for usage information" 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 diff --git a/SimplexMarkdown.hs b/SimplexMarkdown.hs deleted file mode 100644 index 46596db0ef..0000000000 --- a/SimplexMarkdown.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module SimplexMarkdown where - -import Control.Applicative ((<|>)) -import Data.Attoparsec.Text (Parser) -import qualified Data.Attoparsec.Text as A -import Data.Either (fromRight) -import Data.Functor (($>)) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import Styled -import System.Console.ANSI.Types - -data Markdown = Markdown Format Text | Markdown :|: Markdown - deriving (Show) - -data Format - = Bold - | Italic - | Underline - | StrikeThrough - | Colored Color - | NoFormat - deriving (Show) - -instance Semigroup Markdown where (<>) = (:|:) - -instance Monoid Markdown where mempty = unmarked "" - -instance IsString Markdown where fromString = unmarked . T.pack - -unmarked :: Text -> Markdown -unmarked = Markdown NoFormat - -styleMarkdown :: Markdown -> StyledString -styleMarkdown (s1 :|: s2) = styleMarkdown s1 <> styleMarkdown s2 -styleMarkdown (Markdown f s) = Styled sgr $ T.unpack s - 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] - NoFormat -> [] - -formats :: Map Char Format -formats = - M.fromList - [ ('*', Bold), - ('_', Italic), - ('+', Underline), - ('~', StrikeThrough), - ('^', Colored White) - ] - -colors :: Map Text Color -colors = - M.fromList - [ ("red", Red), - ("green", Green), - ("blue", Blue), - ("yellow", Yellow), - ("cyan", Cyan), - ("magenta", Magenta), - ("r", Red), - ("g", Green), - ("b", Blue), - ("y", Yellow), - ("c", Cyan), - ("m", Magenta) - ] - -parseMarkdown :: Text -> Markdown -parseMarkdown s = fromRight (unmarked s) $ A.parseOnly (markdownP <* A.endOfInput) s - -markdownP :: Parser Markdown -markdownP = merge <$> A.many' fragmentP - where - merge :: [Markdown] -> Markdown - merge [] = "" - merge [f] = f - merge (f : fs) = foldl (:|:) f fs - fragmentP :: Parser Markdown - fragmentP = - A.anyChar >>= \case - ' ' -> unmarked . (" " <>) <$> A.takeWhile (== ' ') - c -> case M.lookup c formats of - Just (Colored White) -> coloredP - Just f -> formattedP c "" f - Nothing -> unformattedP c - formattedP :: Char -> Text -> Format -> Parser Markdown - formattedP c p f = do - s <- A.takeTill (== c) - (A.char c $> Markdown f s) <|> noFormat (T.singleton c <> p <> s) - coloredP :: Parser Markdown - coloredP = do - color <- A.takeWhile (\c -> c /= ' ' && c /= '^') - case M.lookup color colors of - Just c -> - let f = Colored c - in (A.char ' ' *> formattedP '^' (color <> " ") f) - <|> (A.char '^' $> Markdown f color) - <|> noFormat ("^" <> color) - _ -> noFormat ("^" <> color) - unformattedP :: Char -> Parser Markdown - unformattedP c = unmarked . (T.singleton c <>) <$> wordsP - wordsP :: Parser Text - wordsP = do - s <- (<>) <$> A.takeTill (== ' ') <*> A.takeWhile (== ' ') - A.peekChar >>= \case - Nothing -> pure s - Just c -> case M.lookup c formats of - Just _ -> pure s - Nothing -> (s <>) <$> wordsP - noFormat :: Text -> Parser Markdown - noFormat = pure . unmarked diff --git a/Styled.hs b/Styled.hs index f355a55c70..6b12076e17 100644 --- a/Styled.hs +++ b/Styled.hs @@ -1,9 +1,12 @@ -module Styled (StyledString (..), plain, bPlain, styledToANSITerm, styledToPlain) where +module Styled where import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.String -import System.Console.ANSI (SGR (..), setSGRCode) +import qualified Data.Text as T +import Simplex.Markdown +import System.Console.ANSI (setSGRCode) +import System.Console.ANSI.Types data StyledString = Styled [SGR] String | StyledString :<>: StyledString @@ -19,6 +22,21 @@ plain = Styled [] bPlain :: ByteString -> StyledString bPlain = Styled [] . B.unpack +styleMarkdown :: Markdown -> StyledString +styleMarkdown (s1 :|: s2) = styleMarkdown s1 <> styleMarkdown s2 +styleMarkdown (Markdown Snippet s) = plain . T.unpack $ '`' `T.cons` s `T.snoc` '`' +styleMarkdown (Markdown f s) = Styled sgr $ T.unpack s + where + sgr = case f of + Bold -> [SetConsoleIntensity BoldIntensity] + Italic -> [SetUnderlining SingleUnderline, SetItalicized True] + Underline -> [SetUnderlining SingleUnderline] + StrikeThrough -> [SetSwapForegroundBackground True] + Colored Black -> [SetColor Foreground Dull Black] + Colored c -> [SetColor Foreground Vivid c] + Snippet -> [] + NoFormat -> [] + styledToANSITerm :: StyledString -> String styledToANSITerm (Styled [] s) = s styledToANSITerm (Styled sgr s) = setSGRCode sgr <> s <> setSGRCode [Reset] @@ -27,3 +45,7 @@ styledToANSITerm (s1 :<>: s2) = styledToANSITerm s1 <> styledToANSITerm s2 styledToPlain :: StyledString -> String styledToPlain (Styled _ s) = s styledToPlain (s1 :<>: s2) = styledToPlain s1 <> styledToPlain s2 + +sLength :: StyledString -> Int +sLength (Styled _ s) = length s +sLength (s1 :<>: s2) = sLength s1 + sLength s2 From a819fcb86b9f839cd2a2896d0520d2e6c940b6c4 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 10 Apr 2021 12:53:22 +0100 Subject: [PATCH 05/14] support Home, End and Del keys (#87) * add Home and End keys * support Delete key * simplify updateTermState --- ChatTerminal/Core.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/ChatTerminal/Core.hs b/ChatTerminal/Core.hs index 24856e4984..09d9197950 100644 --- a/ChatTerminal/Core.hs +++ b/ChatTerminal/Core.hs @@ -51,6 +51,9 @@ updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition | otherwise -> ts TabKey -> insertCharsWithContact " " BackspaceKey -> backDeleteChar + DeleteKey -> deleteChar + HomeKey -> setPosition 0 + EndKey -> setPosition $ length s ArrowKey d -> case d of Leftwards | ms == mempty -> setPosition $ max 0 (p - 1) @@ -85,10 +88,12 @@ updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition 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) + | 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) setPosition p' = ts' (s, p') prevWordPos | p == 0 || null s = p From e49bda7957d73cb0244b7119c899c46c4d3699b1 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 10 Apr 2021 13:12:28 +0100 Subject: [PATCH 06/14] markdown tests (#86) --- Styled.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/Styled.hs b/Styled.hs index 6b12076e17..e3f8f23eaa 100644 --- a/Styled.hs +++ b/Styled.hs @@ -32,7 +32,6 @@ styleMarkdown (Markdown f s) = Styled sgr $ T.unpack s Italic -> [SetUnderlining SingleUnderline, SetItalicized True] Underline -> [SetUnderlining SingleUnderline] StrikeThrough -> [SetSwapForegroundBackground True] - Colored Black -> [SetColor Foreground Dull Black] Colored c -> [SetColor Foreground Vivid c] Snippet -> [] NoFormat -> [] From 6f137d25bf11639dad8ebf93c8996a73c72f2fb4 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 10 Apr 2021 13:30:58 +0100 Subject: [PATCH 07/14] refactor key handling (#88) * refactor key handling * remove constant change * simplify * refactor Downwards --- ChatTerminal/Core.hs | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/ChatTerminal/Core.hs b/ChatTerminal/Core.hs index 09d9197950..513b62a1ae 100644 --- a/ChatTerminal/Core.hs +++ b/ChatTerminal/Core.hs @@ -55,25 +55,15 @@ updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition HomeKey -> setPosition 0 EndKey -> setPosition $ length s ArrowKey d -> case d of - Leftwards - | ms == mempty -> setPosition $ max 0 (p - 1) - | ms == shiftKey -> setPosition 0 - | ms == ctrlKey -> setPosition prevWordPos - | ms == altKey -> setPosition prevWordPos - | otherwise -> setPosition p - Rightwards - | ms == mempty -> setPosition $ min (length s) (p + 1) - | ms == shiftKey -> setPosition $ length s - | ms == ctrlKey -> setPosition nextWordPos - | ms == altKey -> setPosition nextWordPos - | otherwise -> setPosition p + 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 setPosition $ if p' > 0 then p' else p - | otherwise -> setPosition p + | 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 setPosition $ if p' <= length s then p' else p - | otherwise -> setPosition p + | ms == mempty -> let p' = p + tw in if p' <= length s then setPosition p' else ts + | otherwise -> ts _ -> ts where insertCharsWithContact cs @@ -94,6 +84,18 @@ updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition | 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 = min (length s) (p + 1) + | ms == shiftKey = length s + | ms == ctrlKey = nextWordPos + | ms == altKey = nextWordPos + | 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 From 62281a62d7ce3795ffa10153cd717050ae17ddfd Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 11 Apr 2021 09:51:57 +0100 Subject: [PATCH 08/14] fix multiline output (messages and help) (#90) --- ChatTerminal.hs | 6 ++--- ChatTerminal/Core.hs | 15 ++++++++---- ChatTerminal/Editor.hs | 16 +++++++++---- Main.hs | 54 +++++++++++++++++++++++++----------------- Styled.hs | 4 ++++ 5 files changed, 61 insertions(+), 34 deletions(-) diff --git a/ChatTerminal.hs b/ChatTerminal.hs index e392a0ae2b..f2dd2e2c4a 100644 --- a/ChatTerminal.hs +++ b/ChatTerminal.hs @@ -63,7 +63,7 @@ basicReceiveFromTTY ct = forever $ getLn >>= atomically . writeTBQueue (inputQ ct) basicSendToTTY :: ChatTerminal -> IO () -basicSendToTTY ct = forever $ atomically (readOutputQ ct) >>= putStyledLn +basicSendToTTY ct = forever $ atomically (readOutputQ ct) >>= mapM_ putStyledLn withTermLock :: MonadTerminal m => ChatTerminal -> m () -> m () withTermLock ChatTerminal {termLock} action = do @@ -91,7 +91,7 @@ receiveFromTTY ct@ChatTerminal {inputQ, activeContact, termSize, termState} = writeTVar termState $ ts {inputString = "", inputPosition = 0, previousInput = s} writeTBQueue inputQ s return s - withTermLock ct . printMessage ct $ styleMessage msg + withTermLock ct $ printMessage ct [styleMessage msg] sendToTTY :: ChatTerminal -> IO () sendToTTY ct = withTerminal . runTerminalT . forever $ do @@ -100,5 +100,5 @@ sendToTTY ct = withTerminal . runTerminalT . forever $ do printMessage ct msg updateInput ct -readOutputQ :: ChatTerminal -> STM StyledString +readOutputQ :: ChatTerminal -> STM [StyledString] readOutputQ = readTBQueue . outputQ diff --git a/ChatTerminal/Core.hs b/ChatTerminal/Core.hs index 513b62a1ae..92e16decdd 100644 --- a/ChatTerminal/Core.hs +++ b/ChatTerminal/Core.hs @@ -5,10 +5,12 @@ 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 Simplex.Markdown +import Data.Text.Encoding import Styled import System.Console.ANSI.Types import System.Terminal hiding (insertChars) @@ -16,7 +18,7 @@ import Types data ChatTerminal = ChatTerminal { inputQ :: TBQueue String, - outputQ :: TBQueue StyledString, + outputQ :: TBQueue [StyledString], activeContact :: TVar (Maybe Contact), username :: TVar (Maybe Contact), termMode :: TermMode, @@ -118,7 +120,12 @@ styleMessage = \case s -> markdown s where markdown :: String -> StyledString - markdown = styleMarkdown . parseMarkdown . T.pack + markdown = styleMarkdownText . T.pack + +safeDecodeUtf8 :: ByteString -> Text +safeDecodeUtf8 = decodeUtf8With onError + where + onError _ _ = Just '?' updateUsername :: ChatTerminal -> Maybe Contact -> STM () updateUsername ct a = do @@ -132,7 +139,7 @@ ttyContact :: Contact -> StyledString ttyContact (Contact a) = Styled contactSGR $ B.unpack a ttyFromContact :: Contact -> StyledString -ttyFromContact (Contact a) = Styled contactSGR $ B.unpack a <> ">" +ttyFromContact (Contact a) = Styled contactSGR $ B.unpack a <> "> " contactSGR :: [SGR] contactSGR = [SetColor Foreground Vivid Yellow] diff --git a/ChatTerminal/Editor.hs b/ChatTerminal/Editor.hs index ec1ae19ba1..d4e6a9843a 100644 --- a/ChatTerminal/Editor.hs +++ b/ChatTerminal/Editor.hs @@ -43,13 +43,19 @@ updateInput ct@ChatTerminal {termSize = Size {height, width}, termState, nextMes eraseInLine EraseForward clearLines (from + 1) till -printMessage :: MonadTerminal m => ChatTerminal -> StyledString -> m () +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} - let lc = sLength msg `div` width + 1 - putStyled msg - eraseInLine EraseForward - putLn + 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 28407c86bb..7ef8218ee2 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 @@ -31,6 +32,7 @@ import Simplex.Messaging.Agent.Transmission import Simplex.Messaging.Client (smpDefaultConfig) import Simplex.Messaging.Util (raceAny_) import Styled +import System.Console.ANSI.Types import System.Directory (getAppUserDataDirectory) import Types @@ -91,35 +93,43 @@ data ChatResponse | ChatError AgentErrorType | NoChatResponse -serializeChatResponse :: Maybe Contact -> ChatResponse -> StyledString +serializeChatResponse :: Maybe Contact -> ChatResponse -> [StyledString] serializeChatResponse name = \case ChatHelpInfo -> chatHelpInfo - Invitation qInfo -> "ask your contact to enter: /accept " <> showName name <> " " <> (bPlain . serializeSmpQueueInfo) qInfo - Connected c -> ttyContact c <> " connected" - ReceivedMessage c t -> 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 -> "" + Invitation qInfo -> ["ask your contact to enter: /accept " <> showName name <> " " <> (bPlain . serializeSmpQueueInfo) qInfo] + Connected c -> [ttyContact c <> " connected"] + 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)) = bPlain a - msgPlain = styleMarkdown . parseMarkdown . decodeUtf8With onError - onError _ _ = Just '?' + prependFirst :: StyledString -> [StyledString] -> [StyledString] + prependFirst s [] = [s] + prependFirst s (s' : ss) = (s <> s') : ss + msgPlain :: ByteString -> [StyledString] + msgPlain = map styleMarkdownText . T.lines . safeDecodeUtf8 -chatHelpInfo :: StyledString +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 ", + " (any unique string without spaces)", + highlight "/accept " <> " - accept ", + " (a string that starts from \"smp::\")", + " from your contact ", + highlight "/name " <> " - set to use in invitations", + highlight "@ " <> " - send (any string) to contact ", + " @ can be omitted to send to previous" + ] + where + highlight = Markdown (Colored Cyan) main :: IO () main = do diff --git a/Styled.hs b/Styled.hs index e3f8f23eaa..63f4ccecbe 100644 --- a/Styled.hs +++ b/Styled.hs @@ -3,6 +3,7 @@ module Styled 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 (setSGRCode) @@ -22,6 +23,9 @@ 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) = plain . T.unpack $ '`' `T.cons` s `T.snoc` '`' From 8fad84d3ec96a1fe5643dd6045c7118ceca5bbe7 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 11 Apr 2021 09:54:14 +0100 Subject: [PATCH 09/14] Secret markdown (#91) * secret text markdown * refactor --- ChatTerminal/Basic.hs | 2 +- Styled.hs | 34 +++++++++++++++++++++------------- 2 files changed, 22 insertions(+), 14 deletions(-) diff --git a/ChatTerminal/Basic.hs b/ChatTerminal/Basic.hs index 52b618e414..875313c645 100644 --- a/ChatTerminal/Basic.hs +++ b/ChatTerminal/Basic.hs @@ -61,7 +61,7 @@ setSGR = mapM_ $ \case getKey :: MonadTerminal m => m (Key, Modifiers) getKey = - awaitEvent >>= \case + flush >> awaitEvent >>= \case Left Interrupt -> liftIO exitSuccess Right (KeyEvent key ms) -> pure (key, ms) _ -> getKey diff --git a/Styled.hs b/Styled.hs index 63f4ccecbe..5b54644bad 100644 --- a/Styled.hs +++ b/Styled.hs @@ -1,4 +1,14 @@ -module Styled where +{-# LANGUAGE LambdaCase #-} + +module Styled + ( StyledString (..), + bPlain, + plain, + styleMarkdown, + styleMarkdownText, + sLength, + ) +where import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -6,7 +16,6 @@ import Data.String import Data.Text (Text) import qualified Data.Text as T import Simplex.Markdown -import System.Console.ANSI (setSGRCode) import System.Console.ANSI.Types data StyledString = Styled [SGR] String | StyledString :<>: StyledString @@ -28,8 +37,15 @@ styleMarkdownText = styleMarkdown . parseMarkdown styleMarkdown :: Markdown -> StyledString styleMarkdown (s1 :|: s2) = styleMarkdown s1 <> styleMarkdown s2 -styleMarkdown (Markdown Snippet s) = plain . T.unpack $ '`' `T.cons` s `T.snoc` '`' -styleMarkdown (Markdown f s) = Styled sgr $ T.unpack s +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] @@ -37,18 +53,10 @@ styleMarkdown (Markdown f s) = Styled sgr $ T.unpack s Underline -> [SetUnderlining SingleUnderline] StrikeThrough -> [SetSwapForegroundBackground True] Colored c -> [SetColor Foreground Vivid c] + Secret -> [SetColor Foreground Dull Black, SetColor Background Dull Black] Snippet -> [] NoFormat -> [] -styledToANSITerm :: StyledString -> String -styledToANSITerm (Styled [] s) = s -styledToANSITerm (Styled sgr s) = setSGRCode sgr <> s <> setSGRCode [Reset] -styledToANSITerm (s1 :<>: s2) = styledToANSITerm s1 <> styledToANSITerm s2 - -styledToPlain :: StyledString -> String -styledToPlain (Styled _ s) = s -styledToPlain (s1 :<>: s2) = styledToPlain s1 <> styledToPlain s2 - sLength :: StyledString -> Int sLength (Styled _ s) = length s sLength (s1 :<>: s2) = sLength s1 + sLength s2 From bad7e7f20b680afc9f2fb500f947a51153a24dc9 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 11 Apr 2021 09:55:57 +0100 Subject: [PATCH 10/14] fix left arrow key (#92) * fix left arrow key * remove LambdaCase --- ChatTerminal/Core.hs | 8 ++++---- Styled.hs | 2 -- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/ChatTerminal/Core.hs b/ChatTerminal/Core.hs index 92e16decdd..0b4cecf783 100644 --- a/ChatTerminal/Core.hs +++ b/ChatTerminal/Core.hs @@ -87,10 +87,10 @@ updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition | p == 0 = ts' (tail s, 0) | otherwise = let (b, a) = splitAt p s in ts' (b <> tail a, p) leftPos - | ms == mempty = min (length s) (p + 1) - | ms == shiftKey = length s - | ms == ctrlKey = nextWordPos - | ms == altKey = nextWordPos + | 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) diff --git a/Styled.hs b/Styled.hs index 5b54644bad..87f28a7867 100644 --- a/Styled.hs +++ b/Styled.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE LambdaCase #-} - module Styled ( StyledString (..), bPlain, From 7c6d67634c2e8ed176559ad0eb2d6df8a4892c3f Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 11 Apr 2021 10:17:17 +0100 Subject: [PATCH 11/14] markdown help (#93) * markdown help --- Main.hs | 31 ++++++++++++++++++++++++++++--- 1 file changed, 28 insertions(+), 3 deletions(-) diff --git a/Main.hs b/Main.hs index 7ef8218ee2..1ffc9f5d0d 100644 --- a/Main.hs +++ b/Main.hs @@ -61,6 +61,7 @@ data ChatClient = ChatClient -- | AddToGroup Contact data ChatCommand = ChatHelp + | MarkdownHelp | AddContact Contact | AcceptContact Contact SMPQueueInfo | ChatWith Contact @@ -70,6 +71,7 @@ data ChatCommand chatCommandP :: Parser ChatCommand chatCommandP = "/help" $> ChatHelp + <|> "/md" $> MarkdownHelp <|> "/add " *> (AddContact <$> contact) <|> "/accept " *> acceptContact <|> "/chat " *> chatWith @@ -84,6 +86,7 @@ chatCommandP = data ChatResponse = ChatHelpInfo + | MarkdownInfo | Invitation SMPQueueInfo | Connected Contact | ReceivedMessage Contact ByteString @@ -96,6 +99,7 @@ data ChatResponse serializeChatResponse :: Maybe Contact -> ChatResponse -> [StyledString] serializeChatResponse name = \case ChatHelpInfo -> chatHelpInfo + MarkdownInfo -> markdownInfo Invitation qInfo -> ["ask your contact to enter: /accept " <> showName name <> " " <> (bPlain . serializeSmpQueueInfo) qInfo] Connected c -> [ttyContact c <> " connected"] ReceivedMessage c t -> prependFirst (ttyFromContact c) $ msgPlain t @@ -126,11 +130,29 @@ chatHelpInfo = " from your contact ", highlight "/name " <> " - set to use in invitations", highlight "@ " <> " - send (any string) to contact ", - " @ can be omitted to send to previous" + " @ can be omitted to send to previous", + highlight "/md" <> " - markdown cheat-sheet" ] where 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", + " !r text! - " <> red "red text" <> " (red, green, blue, yellow, cyan, magenta)", + " !1 text! - " <> red "also red text" <> " (1-6)", + " #secret# - " <> Markdown Secret "secret text" <> " (can be copy-pasted)" + ] + where + red = Markdown (Colored Red) + main :: IO () main = do ChatOpts {dbFileName, smpServer, name, termMode} <- welcomeGetOpts @@ -179,14 +201,16 @@ receiveFromChatTerm t ct = forever $ do >>= processOrError . A.parseOnly (chatCommandP <* A.endOfInput) . encodeUtf8 . T.pack where processOrError = \case - Left err -> atomically . writeTBQueue (outQ t) . ErrorInput $ B.pack err - Right ChatHelp -> atomically . writeTBQueue (outQ t) $ ChatHelpInfo + Left err -> writeOutQ . ErrorInput $ B.pack err + Right ChatHelp -> writeOutQ ChatHelpInfo + Right MarkdownHelp -> writeOutQ MarkdownInfo Right (SetName a) -> atomically $ do let user = Just a writeTVar (username (t :: ChatClient)) user updateUsername ct user writeTBQueue (outQ t) YesYes Right cmd -> atomically $ writeTBQueue (inQ t) cmd + writeOutQ = atomically . writeTBQueue (outQ t) sendToChatTerm :: ChatClient -> ChatTerminal -> IO () sendToChatTerm ChatClient {outQ, username} ChatTerminal {outputQ} = forever $ do @@ -217,6 +241,7 @@ sendToAgent ChatClient {inQ, smpServer} ct AgentClient {rcvQ} = do ChatWith a -> transmission a SUB SendMessage a msg -> transmission a $ SEND msg ChatHelp -> Nothing + MarkdownHelp -> Nothing SetName _ -> Nothing transmission :: Contact -> ACommand 'Client -> Maybe (ATransmission 'Client) transmission (Contact a) cmd = Just ("1", a, cmd) From 6caab6f5391f3a16b2e1e8fbf48d6727a0c83ffd Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 11 Apr 2021 11:22:56 +0100 Subject: [PATCH 12/14] fix: initially blocked keys (#94) --- ChatTerminal.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/ChatTerminal.hs b/ChatTerminal.hs index f2dd2e2c4a..13b8d15e07 100644 --- a/ChatTerminal.hs +++ b/ChatTerminal.hs @@ -63,7 +63,7 @@ basicReceiveFromTTY ct = forever $ getLn >>= atomically . writeTBQueue (inputQ ct) basicSendToTTY :: ChatTerminal -> IO () -basicSendToTTY ct = forever $ atomically (readOutputQ ct) >>= mapM_ putStyledLn +basicSendToTTY ct = forever $ readOutputQ ct >>= mapM_ putStyledLn withTermLock :: MonadTerminal m => ChatTerminal -> m () -> m () withTermLock ChatTerminal {termLock} action = do @@ -94,11 +94,12 @@ receiveFromTTY ct@ChatTerminal {inputQ, activeContact, termSize, termState} = withTermLock ct $ printMessage ct [styleMessage msg] sendToTTY :: ChatTerminal -> IO () -sendToTTY ct = withTerminal . runTerminalT . forever $ do - msg <- atomically $ readOutputQ ct - withTermLock ct $ do +sendToTTY ct = forever $ do + -- `readOutputQ` should be outside of `withTerminal` (see #94) + msg <- readOutputQ ct + withTerminal . runTerminalT . withTermLock ct $ do printMessage ct msg updateInput ct -readOutputQ :: ChatTerminal -> STM [StyledString] -readOutputQ = readTBQueue . outputQ +readOutputQ :: ChatTerminal -> IO [StyledString] +readOutputQ = atomically . readTBQueue . outputQ From 3778c308f79ceaa39ae4c04c683333d655968526 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 11 Apr 2021 18:03:55 +0100 Subject: [PATCH 13/14] new chat UX: removed /name, add /delete and /reset, change /accept to /connect, allow command abbreviations (#95) * remove current user name * rename /accept to /connect, remove /chat, add /reset, allow 1-letter abbreviations * update help * /delete contact, separate response for confirmation * update invatation instruction * unset active contact only if it is the same as current --- ChatOptions.hs | 13 +--- ChatTerminal.hs | 16 +++-- ChatTerminal/Core.hs | 9 --- Main.hs | 138 ++++++++++++++++++++++--------------------- Types.hs | 2 +- 5 files changed, 82 insertions(+), 96 deletions(-) diff --git a/ChatOptions.hs b/ChatOptions.hs index bba310998a..8d0ffe876d 100644 --- a/ChatOptions.hs +++ b/ChatOptions.hs @@ -11,8 +11,7 @@ import System.FilePath (combine) import Types data ChatOpts = ChatOpts - { name :: Maybe ByteString, - dbFileName :: String, + { dbFileName :: String, smpServer :: SMPServer, termMode :: TermMode } @@ -20,15 +19,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" diff --git a/ChatTerminal.hs b/ChatTerminal.hs index 13b8d15e07..9a09027d16 100644 --- a/ChatTerminal.hs +++ b/ChatTerminal.hs @@ -7,7 +7,6 @@ module ChatTerminal ( ChatTerminal (..), newChatTerminal, chatTerminal, - updateUsername, ttyContact, ttyFromContact, ) @@ -25,26 +24,25 @@ import System.Terminal import Types import UnliftIO.STM -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 <- withTerminal . runTerminalT $ getWindowSize let lastRow = height termSize - 1 - termState <- newTVarIO $ newTermState user + 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 = "" } diff --git a/ChatTerminal/Core.hs b/ChatTerminal/Core.hs index 0b4cecf783..ab001cb548 100644 --- a/ChatTerminal/Core.hs +++ b/ChatTerminal/Core.hs @@ -20,7 +20,6 @@ data ChatTerminal = ChatTerminal { inputQ :: TBQueue String, outputQ :: TBQueue [StyledString], activeContact :: TVar (Maybe Contact), - username :: TVar (Maybe Contact), termMode :: TermMode, termState :: TVar TerminalState, termSize :: Size, @@ -127,14 +126,6 @@ safeDecodeUtf8 = decodeUtf8With onError where onError _ _ = Just '?' -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 <> "> " - ttyContact :: Contact -> StyledString ttyContact (Contact a) = Styled contactSGR $ B.unpack a diff --git a/Main.hs b/Main.hs index 1ffc9f5d0d..365fa67e6b 100644 --- a/Main.hs +++ b/Main.hs @@ -21,6 +21,7 @@ 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 @@ -53,8 +54,7 @@ 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 @@ -62,25 +62,23 @@ data ChatClient = ChatClient data ChatCommand = ChatHelp | MarkdownHelp - | AddContact Contact - | AcceptContact Contact SMPQueueInfo - | ChatWith Contact - | SetName Contact + | AddConnection Contact + | Connect Contact SMPQueueInfo + | DeleteConnection Contact + | ResetChat | SendMessage Contact ByteString chatCommandP :: Parser ChatCommand chatCommandP = - "/help" $> ChatHelp - <|> "/md" $> MarkdownHelp - <|> "/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) + <|> ("/reset" <> "/r") $> ResetChat <|> "@" *> 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 (== ' ') @@ -89,6 +87,7 @@ data ChatResponse | MarkdownInfo | Invitation SMPQueueInfo | Connected Contact + | Confirmation Contact | ReceivedMessage Contact ByteString | Disconnected Contact | YesYes @@ -96,12 +95,19 @@ data ChatResponse | ChatError AgentErrorType | NoChatResponse -serializeChatResponse :: Maybe Contact -> ChatResponse -> [StyledString] -serializeChatResponse name = \case +serializeChatResponse :: ChatResponse -> [StyledString] +serializeChatResponse = \case ChatHelpInfo -> chatHelpInfo MarkdownInfo -> markdownInfo - Invitation qInfo -> ["ask your contact to enter: /accept " <> showName name <> " " <> (bPlain . serializeSmpQueueInfo) qInfo] + 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!"] @@ -109,8 +115,6 @@ serializeChatResponse name = \case ChatError e -> ["chat error: " <> plain (show e)] NoChatResponse -> [""] where - showName Nothing = "" - showName (Just (Contact a)) = bPlain a prependFirst :: StyledString -> [StyledString] -> [StyledString] prependFirst s [] = [s] prependFirst s (s' : ss) = (s <> s') : ss @@ -122,18 +126,24 @@ chatHelpInfo = map styleMarkdown [ "Using chat:", - highlight "/add " <> " - create invitation to send out-of-band", - " to your contact ", - " (any unique string without spaces)", - highlight "/accept " <> " - accept ", - " (a string that starts from \"smp::\")", - " from your contact ", - highlight "/name " <> " - set to use in invitations", + 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 ", - " @ can be omitted to send to previous", - highlight "/md" <> " - markdown cheat-sheet" + " @ 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 "/reset" <> " - reset chat and all connections", + highlight "/markdown" <> " - markdown cheat-sheet", + "", + "Commands can be abbreviated to 1 letter: ", + listCommands ["/h", "/a", "/c", "/d", "/r", "/m"] ] where + listCommands = mconcat . intersperse ", " . map highlight highlight = Markdown (Colored Cyan) markdownInfo :: [StyledString] @@ -155,10 +165,9 @@ markdownInfo = 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 $ env <- newSMPAgentEnv cfg {dbFile = dbFileName} @@ -168,9 +177,9 @@ welcomeGetOpts :: IO ChatOpts welcomeGetOpts = do appDir <- getAppUserDataDirectory "simplex" opts@ChatOpts {dbFileName} <- getChatOpts appDir - putStrLn "simpleX chat prototype" + putStrLn "SimpleX chat prototype" putStrLn $ "db: " <> dbFileName - putStrLn "type \"/help\" for usage information" + putStrLn "type \"/help\" or \"/h\" for usage info" pure opts dogFoodChat :: ChatClient -> ChatTerminal -> Env -> IO () @@ -185,15 +194,14 @@ 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 @@ -204,21 +212,14 @@ receiveFromChatTerm t ct = forever $ do Left err -> writeOutQ . ErrorInput $ B.pack err Right ChatHelp -> writeOutQ ChatHelpInfo Right MarkdownHelp -> writeOutQ MarkdownInfo - Right (SetName a) -> atomically $ do - let user = Just a - writeTVar (username (t :: ChatClient)) user - updateUsername ct user - writeTBQueue (outQ t) YesYes 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 @@ -229,20 +230,19 @@ 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 + ResetChat -> transmission (Contact "") SUBALL SendMessage a msg -> transmission a $ SEND msg ChatHelp -> Nothing MarkdownHelp -> Nothing - SetName _ -> Nothing transmission :: Contact -> ACommand 'Client -> Maybe (ATransmission 'Client) transmission (Contact a) cmd = Just ("1", a, cmd) @@ -259,15 +259,21 @@ receiveFromAgent t ct c = forever . atomically $ do END -> Disconnected contact MSG {m_body} -> ReceivedMessage contact m_body SENT _ -> NoChatResponse - OK -> Connected contact -- 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/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) From d6cd82825741f4baa67e5acd26c8a66768e94158 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 12 Apr 2021 23:56:17 +0100 Subject: [PATCH 14/14] remove /reset command (#96) --- ChatOptions.hs | 1 - Main.hs | 9 ++------- 2 files changed, 2 insertions(+), 8 deletions(-) diff --git a/ChatOptions.hs b/ChatOptions.hs index 8d0ffe876d..8da33f816c 100644 --- a/ChatOptions.hs +++ b/ChatOptions.hs @@ -3,7 +3,6 @@ module ChatOptions (getChatOpts, ChatOpts (..)) where import qualified Data.Attoparsec.ByteString.Char8 as A -import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Options.Applicative import Simplex.Messaging.Agent.Transmission (SMPServer (..), smpServerP) diff --git a/Main.hs b/Main.hs index 365fa67e6b..cdc1152bc8 100644 --- a/Main.hs +++ b/Main.hs @@ -65,7 +65,6 @@ data ChatCommand | AddConnection Contact | Connect Contact SMPQueueInfo | DeleteConnection Contact - | ResetChat | SendMessage Contact ByteString chatCommandP :: Parser ChatCommand @@ -75,7 +74,6 @@ chatCommandP = <|> ("/add " <|> "/a ") *> (AddConnection <$> contact) <|> ("/connect " <> "/c ") *> connect <|> ("/delete " <> "/d ") *> (DeleteConnection <$> contact) - <|> ("/reset" <> "/r") $> ResetChat <|> "@" *> sendMessage where connect = Connect <$> contact <* A.space <*> smpQueueInfoP @@ -136,11 +134,10 @@ chatHelpInfo = " @ 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 "/reset" <> " - reset chat and all connections", highlight "/markdown" <> " - markdown cheat-sheet", "", "Commands can be abbreviated to 1 letter: ", - listCommands ["/h", "/a", "/c", "/d", "/r", "/m"] + listCommands ["/h", "/a", "/c", "/d", "/m"] ] where listCommands = mconcat . intersperse ", " . map highlight @@ -156,8 +153,7 @@ markdownInfo = " +underlined+ - " <> Markdown Underline "underlined text", " ~strikethrough~ - " <> Markdown StrikeThrough "strikethrough text" <> " (shown as inverse)", " `code snippet` - " <> Markdown Snippet "a + b // no *markdown* here", - " !r text! - " <> red "red text" <> " (red, green, blue, yellow, cyan, magenta)", - " !1 text! - " <> red "also red text" <> " (1-6)", + " !1 text! - " <> red "red text" <> " (1-6: red, green, blue, yellow, cyan, magenta)", " #secret# - " <> Markdown Secret "secret text" <> " (can be copy-pasted)" ] where @@ -239,7 +235,6 @@ sendToAgent ChatClient {inQ, smpServer} ct AgentClient {rcvQ} = do AddConnection a -> transmission a $ NEW smpServer Connect a qInfo -> transmission a $ JOIN qInfo $ ReplyVia smpServer DeleteConnection a -> transmission a DEL - ResetChat -> transmission (Contact "") SUBALL SendMessage a msg -> transmission a $ SEND msg ChatHelp -> Nothing MarkdownHelp -> Nothing