From 88e799797c0612b3895af12d23656611706d2701 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 31 Jan 2021 17:29:16 +0000 Subject: [PATCH 01/34] chat prototype (#35) * chat prototype * chat prototype now compiles * chat prototype works * agent: respond SENT mId to SEND (instead of OK), ne repsonse to chat message in terminal * chat prototype help, update commands * chat CLI options * add active contact to ChatClient (not used yet) * refactor agentTransmission * InviteContact -> AddContact * automatically insert active contact * highlight contact in chat * name for invitations * do not ask name on start * change default server to smp.simplex.im --- ChatOptions.hs | 56 +++++++++++ Main.hs | 257 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 313 insertions(+) create mode 100644 ChatOptions.hs create mode 100644 Main.hs diff --git a/ChatOptions.hs b/ChatOptions.hs new file mode 100644 index 0000000000..0f1a36652f --- /dev/null +++ b/ChatOptions.hs @@ -0,0 +1,56 @@ +module ChatOptions (getChatOpts, ChatOpts (..)) where + +import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteString.Char8 as B +import Options.Applicative +import Simplex.Messaging.Agent.Transmission (SMPServer (..), smpServerP) + +data ChatOpts = ChatOpts + { name :: Maybe B.ByteString, + dbFileName :: String, + smpServer :: SMPServer + } + +chatOpts :: Parser ChatOpts +chatOpts = + ChatOpts + <$> option + parseName + ( long "name" + <> short 'n' + <> metavar "NAME" + <> help "optional name to use for invitations" + <> value Nothing + ) + <*> strOption + ( long "database" + <> short 'd' + <> metavar "DB_FILE" + <> help "sqlite database filename (smp-chat.db)" + <> value "smp-chat.db" + ) + <*> option + parseSMPServer + ( long "server" + <> short 's' + <> metavar "SERVER" + <> help "SMP server to use (localhost:5223)" + <> value (SMPServer "smp.simplex.im" (Just "5223") Nothing) + ) + +parseName :: ReadM (Maybe B.ByteString) +parseName = maybeReader $ Just . Just . B.pack + +parseSMPServer :: ReadM SMPServer +parseSMPServer = eitherReader $ A.parseOnly (smpServerP <* A.endOfInput) . B.pack + +getChatOpts :: IO ChatOpts +getChatOpts = execParser opts + where + opts = + info + (chatOpts <**> helper) + ( fullDesc + <> header "Chat prototype using Simplex Messaging Protocol (SMP)" + <> progDesc "Start chat with DB_FILE file and use SERVER as SMP server" + ) diff --git a/Main.hs b/Main.hs new file mode 100644 index 0000000000..61bf9d81c2 --- /dev/null +++ b/Main.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import ChatOptions +import Control.Applicative ((<|>)) +import Control.Concurrent.STM +import Control.Logger.Simple +import Control.Monad.Reader +import Data.Attoparsec.ByteString.Char8 (Parser) +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.Transport (getLn, putLn) +import Simplex.Messaging.Util (bshow, raceAny_) +import qualified System.Console.ANSI as C +import System.IO + +cfg :: AgentConfig +cfg = + AgentConfig + { tcpPort = undefined, -- TODO maybe take it out of config + tbqSize = 16, + connIdBytes = 12, + dbFile = "smp-chat.db", + smpCfg = smpDefaultConfig + } + +logCfg :: LogConfig +logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} + +data ChatClient = ChatClient + { inQ :: TBQueue ChatCommand, + outQ :: TBQueue ChatResponse, + smpServer :: SMPServer, + activeContact :: TVar (Maybe Contact), + username :: TVar (Maybe Contact) + } + +newtype Contact = Contact {toBs :: ByteString} + +-- | GroupMessage ChatGroup ByteString +-- | AddToGroup Contact +data ChatCommand + = ChatHelp + | AddContact Contact + | AcceptContact Contact SMPQueueInfo + | ChatWith Contact + | SetName Contact + | SendMessage Contact ByteString + +chatCommandP :: Parser ChatCommand +chatCommandP = + "/help" $> ChatHelp + <|> "/add " *> (AddContact <$> contact) + <|> "/accept " *> acceptContact + <|> "/chat " *> chatWith + <|> "/name " *> setName + <|> "@" *> sendMessage + where + acceptContact = AcceptContact <$> contact <* A.space <*> smpQueueInfoP + chatWith = ChatWith <$> contact + setName = SetName <$> contact + sendMessage = SendMessage <$> contact <* A.space <*> A.takeByteString + contact = Contact <$> A.takeTill (== ' ') + +data ChatResponse + = ChatHelpInfo + | Invitation SMPQueueInfo + | Connected Contact + | ReceivedMessage Contact ByteString + | Disconnected Contact + | YesYes + | ErrorInput ByteString + | ChatError AgentErrorType + | NoChatResponse + +serializeChatResponse :: Maybe Contact -> ChatResponse -> ByteString +serializeChatResponse name = \case + ChatHelpInfo -> chatHelpInfo + Invitation qInfo -> "ask your contact to enter: /accept " <> showName name <> " " <> serializeSmpQueueInfo qInfo + Connected c -> ttyContact c <> " connected" + ReceivedMessage c t -> ttyContact c <> ": " <> t + Disconnected c -> "disconnected from " <> ttyContact c <> " - try \"/chat " <> toBs c <> "\"" + YesYes -> "you got it!" + ErrorInput t -> "invalid input: " <> t + ChatError e -> "chat error: " <> bshow e + NoChatResponse -> "" + where + showName Nothing = "" + showName (Just (Contact a)) = a + +chatHelpInfo :: ByteString +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\ + \/chat - resume chat with \n\ + \/name - set to use in invitations\n\ + \@ - send (any string) to contact \n\ + \ @ can be omitted to send to previous" + +main :: IO () +main = do + ChatOpts {dbFileName, smpServer, name} <- getChatOpts + putStrLn "simpleX chat prototype (no encryption), \"/help\" for usage information" + t <- getChatClient smpServer (Contact <$> name) + -- setLogLevel LogInfo -- LogError + -- withGlobalLogging logCfg $ + env <- newSMPAgentEnv cfg {dbFile = dbFileName} + dogFoodChat t env + +dogFoodChat :: ChatClient -> Env -> IO () +dogFoodChat t env = do + c <- runReaderT getSMPAgentClient env + raceAny_ + [ runReaderT (runSMPAgentClient c) env, + sendToAgent t c, + sendToTTY t, + receiveFromAgent t c, + receiveFromTTY t + ] + +getChatClient :: SMPServer -> Maybe Contact -> IO ChatClient +getChatClient srv name = atomically $ newChatClient (tbqSize cfg) srv name + +newChatClient :: Natural -> SMPServer -> Maybe Contact -> STM ChatClient +newChatClient qSize smpServer name = do + inQ <- newTBQueue qSize + outQ <- newTBQueue qSize + activeContact <- newTVar Nothing + username <- newTVar name + return ChatClient {inQ, outQ, smpServer, activeContact, username} + +receiveFromTTY :: ChatClient -> IO () +receiveFromTTY t = + forever $ getChatLn t >>= processOrError . A.parseOnly (chatCommandP <* A.endOfInput) + where + processOrError = \case + Left err -> atomically . writeTBQueue (outQ t) . ErrorInput $ B.pack err + Right ChatHelp -> atomically . writeTBQueue (outQ t) $ ChatHelpInfo + Right (SetName a) -> atomically $ do + writeTVar (username t) $ Just a + writeTBQueue (outQ t) YesYes + Right cmd -> atomically $ writeTBQueue (inQ t) cmd + +sendToTTY :: ChatClient -> IO () +sendToTTY ChatClient {outQ, username} = forever $ do + atomically (readTBQueue outQ) >>= \case + NoChatResponse -> return () + resp -> do + name <- readTVarIO username + putLn stdout $ serializeChatResponse name resp + +sendToAgent :: ChatClient -> AgentClient -> IO () +sendToAgent ChatClient {inQ, smpServer, activeContact} AgentClient {rcvQ} = + forever . atomically $ do + cmd <- readTBQueue inQ + writeTBQueue rcvQ `mapM_` agentTransmission cmd + setActiveContact cmd + where + setActiveContact :: ChatCommand -> STM () + setActiveContact cmd = + writeTVar activeContact $ case cmd of + ChatWith a -> Just a + SendMessage a _ -> Just a + _ -> Nothing + 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 + SendMessage a msg -> transmission a $ SEND msg + ChatHelp -> Nothing + SetName _ -> Nothing + transmission :: Contact -> ACommand 'Client -> Maybe (ATransmission 'Client) + transmission (Contact a) cmd = Just ("1", a, cmd) + +receiveFromAgent :: ChatClient -> AgentClient -> IO () +receiveFromAgent t c = forever . atomically $ do + resp <- chatResponse <$> readTBQueue (sndQ c) + writeTBQueue (outQ t) resp + setActiveContact resp + where + 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 + SENT _ -> NoChatResponse + OK -> YesYes + ERR e -> ChatError e + setActiveContact :: ChatResponse -> STM () + setActiveContact = \case + Connected a -> set $ Just a + ReceivedMessage a _ -> set $ Just a + Disconnected _ -> set Nothing + _ -> return () + where + set a = writeTVar (activeContact t) a + +getChatLn :: ChatClient -> IO ByteString +getChatLn t = do + setTTY NoBuffering + getChar >>= \case + '/' -> getRest "/" + '@' -> getRest "@" + ch -> do + let s = encodeUtf8 $ T.singleton ch + readTVarIO (activeContact t) >>= \case + Nothing -> getRest s + Just a -> getWithContact a s + where + getWithContact :: Contact -> ByteString -> IO ByteString + getWithContact a s = do + C.cursorBackward 1 + B.hPut stdout $ " " <> ttyContact a <> " " <> s + getRest $ "@" <> toBs a <> " " <> s + getRest :: ByteString -> IO ByteString + getRest s = do + setTTY LineBuffering + (s <>) <$> getLn stdin + +setTTY :: BufferMode -> IO () +setTTY mode = do + hSetBuffering stdin mode + hSetBuffering stdout mode + +ttyContact :: Contact -> ByteString +ttyContact (Contact a) = withSGR contactSGR $ "@" <> a + +contactSGR :: [C.SGR] +contactSGR = [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]) From 3de4fa7518284204a6a53af574b22217074a7ad1 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 14 Feb 2021 12:00:04 +0000 Subject: [PATCH 02/34] Sign / verify SMP commands (#37) * generate key pair * crypto: sign/verify functions * remove extension * parse/serialize keys * use RSA recipient/sender keys (TODO sign/verify) * make PublicKey newtype, assign 0s to private_p & private_q * replace SMP command parsing with Attoparsec * rename types: Signed->Transmission, Transmission->SignedTransmission * sign and verify commands (server tests skipped, agent tests pass) * SMP client: avoid seralizing transmission twice when sending commands * update SMP server tests to use command signatures * remove support for "SEND :msg" syntax from SMP server protocol * rename RSA module name to R to avoid confusion with C used for S.M.Crypto * update key sizes to use bits `div` 8 * tidy up --- Main.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Main.hs b/Main.hs index 61bf9d81c2..f1685f0f9d 100644 --- a/Main.hs +++ b/Main.hs @@ -36,8 +36,9 @@ cfg :: AgentConfig cfg = AgentConfig { tcpPort = undefined, -- TODO maybe take it out of config - tbqSize = 16, + rsaKeySize = 2048 `div` 8, connIdBytes = 12, + tbqSize = 16, dbFile = "smp-chat.db", smpCfg = smpDefaultConfig } From be17af4321f4c061b27fd265e841820678d2516b Mon Sep 17 00:00:00 2001 From: Efim Poberezkin Date: Mon, 15 Feb 2021 23:00:19 +0400 Subject: [PATCH 03/34] dog-food: distinguish self from contacts (#42) * dog-food: distinguish self from contacts * add missing space * rename tty functions * return indents * remove indentation in sent messages Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> --- Main.hs | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/Main.hs b/Main.hs index f1685f0f9d..9975622cb1 100644 --- a/Main.hs +++ b/Main.hs @@ -97,7 +97,7 @@ serializeChatResponse name = \case ChatHelpInfo -> chatHelpInfo Invitation qInfo -> "ask your contact to enter: /accept " <> showName name <> " " <> serializeSmpQueueInfo qInfo Connected c -> ttyContact c <> " connected" - ReceivedMessage c t -> ttyContact c <> ": " <> t + ReceivedMessage c t -> ttyFromContact c <> " " <> t Disconnected c -> "disconnected from " <> ttyContact c <> " - try \"/chat " <> toBs c <> "\"" YesYes -> "you got it!" ErrorInput t -> "invalid input: " <> t @@ -236,7 +236,7 @@ getChatLn t = do getWithContact :: Contact -> ByteString -> IO ByteString getWithContact a s = do C.cursorBackward 1 - B.hPut stdout $ " " <> ttyContact a <> " " <> s + B.hPut stdout $ ttyToContact a <> " " <> s getRest $ "@" <> toBs a <> " " <> s getRest :: ByteString -> IO ByteString getRest s = do @@ -249,10 +249,19 @@ setTTY mode = do hSetBuffering stdout mode ttyContact :: Contact -> ByteString -ttyContact (Contact a) = withSGR contactSGR $ "@" <> a +ttyContact (Contact a) = withSGR contactSGR a + +ttyFromContact :: Contact -> ByteString +ttyFromContact (Contact a) = withSGR contactSGR $ a <> ">" + +ttyToContact :: Contact -> ByteString +ttyToContact (Contact a) = withSGR selfSGR $ "@" <> a contactSGR :: [C.SGR] -contactSGR = [C.SetColor C.Foreground C.Vivid C.Cyan] +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]) From 0ef6e4e26aa004927c20229ccf5ff5ef7a1e9e1a Mon Sep 17 00:00:00 2001 From: Efim Poberezkin Date: Tue, 16 Feb 2021 01:01:46 +0400 Subject: [PATCH 04/34] add instructions on how to run chat client to README (#43) * add instructions on how to run chat client to README * wording * wording * corrections to the manual Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> --- ChatOptions.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ChatOptions.hs b/ChatOptions.hs index 0f1a36652f..12480ecb00 100644 --- a/ChatOptions.hs +++ b/ChatOptions.hs @@ -34,7 +34,7 @@ chatOpts = ( long "server" <> short 's' <> metavar "SERVER" - <> help "SMP server to use (localhost:5223)" + <> help "SMP server to use (smp.simplex.im:5223)" <> value (SMPServer "smp.simplex.im" (Just "5223") Nothing) ) From c379c16569a0226c22c7912abefb75e5f6fe1006 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 20 Feb 2021 22:26:27 +0000 Subject: [PATCH 05/34] terminal UI (#44) * separate terminal IO to separate thread via queues * terminal input arithmetics (WIP) * editable multiline terminal input * print messages above input area * support Up/Down arrows * terminal chat: move by word, move to the beginning/end of input * insert active contact when typing starts * refactor inserting active contact * highlight "to contact" * add username to prompt * change beginning/end of line keys to shoft-arrow * remove unused code * add ctrl arrow key bindings * add comment for debugging keys in terminal Co-authored-by: Efim Poberezkin --- ChatTerminal.hs | 329 ++++++++++++++++++++++++++++++++++++++++++++++++ Main.hs | 106 +++++----------- Types.hs | 5 + 3 files changed, 364 insertions(+), 76 deletions(-) create mode 100644 ChatTerminal.hs create mode 100644 Types.hs diff --git a/ChatTerminal.hs b/ChatTerminal.hs new file mode 100644 index 0000000000..11777c6c32 --- /dev/null +++ b/ChatTerminal.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module ChatTerminal + ( ChatTerminal (..), + newChatTerminal, + chatTerminal, + updateUsername, + ttyContact, + ttyFromContact, + ) +where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (race_) +import Control.Concurrent.STM +import Control.Monad +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.List (dropWhileEnd) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Data.Text.Encoding +import Numeric.Natural +import Simplex.Messaging.Transport (getLn, putLn) +import qualified System.Console.ANSI as C +import System.IO +import Types + +data ChatTerminal = ChatTerminal + { inputQ :: TBQueue ByteString, + outputQ :: TBQueue ByteString, + activeContact :: TVar (Maybe Contact), + username :: TVar (Maybe Contact), + termState :: TVar TerminalState, + termSize :: (Int, Int), + nextMessageRow :: TVar Int + } + +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 -> IO ChatTerminal +newChatTerminal qSize user = do + inputQ <- newTBQueueIO qSize + outputQ <- newTBQueueIO qSize + activeContact <- newTVarIO Nothing + username <- newTVarIO user + termSize <- fromMaybe (0, 0) <$> C.getTerminalSize + let lastRow = fst termSize - 1 + termState <- newTVarIO $ newTermState user + nextMessageRow <- newTVarIO lastRow + threadDelay 500000 -- this delay is the same as timeout in getTerminalSize + return ChatTerminal {inputQ, outputQ, activeContact, username, termState, termSize, nextMessageRow} + +newTermState :: Maybe Contact -> TerminalState +newTermState user = + TerminalState + { inputString = "", + inputPosition = 0, + inputPrompt = promptString user + } + +chatTerminal :: ChatTerminal -> IO () +chatTerminal ct = + if termSize ct /= (0, 0) + then do + hSetBuffering stdin NoBuffering + hSetBuffering stdout NoBuffering + hSetEcho stdin False + updateInput ct + run receiveFromTTY' sendToTTY' + else run receiveFromTTY sendToTTY + where + run receive send = race_ (receive ct) (send ct) + +receiveFromTTY :: ChatTerminal -> IO () +receiveFromTTY ct@ChatTerminal {inputQ} = + forever $ getChatLn ct >>= atomically . writeTBQueue inputQ + +receiveFromTTY' :: ChatTerminal -> IO () +receiveFromTTY' ct@ChatTerminal {inputQ, activeContact, termSize, termState} = + forever $ + getKey >>= processKey >> updateInput ct + where + processKey :: Key -> IO () + processKey = \case + KeyEnter -> submitInput + key -> atomically $ do + ac <- readTVar activeContact + modifyTVar termState $ updateTermState ac (snd termSize) key + + submitInput :: IO () + submitInput = do + msg <- atomically $ do + ts <- readTVar termState + writeTVar termState $ ts {inputString = "", inputPosition = 0} + let msg = encodeUtf8 . T.pack $ inputString ts + writeTBQueue inputQ msg + return msg + printMessage ct $ highlightContact msg + + updateTermState :: Maybe Contact -> Int -> Key -> TerminalState -> TerminalState + updateTermState ac tw key ts@TerminalState {inputString = s, inputPosition = p} = case key of + KeyChars cs -> insertCharsWithContact cs + KeyTab -> insertChars " " + KeyBack -> backDeleteChar + KeyLeft -> setPosition $ max 0 (p - 1) + KeyRight -> setPosition $ min (length s) (p + 1) + KeyUp -> setPosition $ let p' = p - tw in if p' > 0 then p' else p + KeyDown -> setPosition $ let p' = p + tw in if p' <= length s then p' else p + KeyAltLeft -> setPosition prevWordPos + KeyAltRight -> setPosition nextWordPos + KeyCtrlLeft -> setPosition prevWordPos + KeyCtrlRight -> setPosition nextWordPos + KeyShiftLeft -> setPosition 0 + KeyShiftRight -> setPosition $ length s + _ -> ts + where + insertCharsWithContact cs + | null s && cs /= "@" && cs /= "/" = + insertChars $ contactPrefix <> cs + | otherwise = insertChars cs + insertChars = ts' . if p >= length s then append else insert + append cs = let s' = s <> cs in (s', length s') + insert cs = let (b, a) = splitAt p s in (b <> cs <> a, p + length cs) + contactPrefix = case ac of + Just (Contact c) -> "@" <> B.unpack c <> " " + Nothing -> "" + backDeleteChar + | p == 0 || null s = ts + | p >= length s = ts' backDeleteLast + | otherwise = ts' backDelete + backDeleteLast = if null s then (s, 0) else let s' = init s in (s', length s') + backDelete = let (b, a) = splitAt p s in (init b <> a, p - 1) + setPosition p' = ts' (s, p') + prevWordPos + | p == 0 || null s = p + | otherwise = + let before = take p s + beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before + in max 0 $ p - length before + length beforeWord + nextWordPos + | p >= length s || null s = p + | otherwise = + let after = drop p s + afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after + in min (length s) $ p + length after - length afterWord + ts' (s', p') = ts {inputString = s', inputPosition = p'} + +highlightContact :: ByteString -> ByteString +highlightContact = \case + "" -> "" + s -> + if B.head s == '@' + then let (c, rest) = B.span (/= ' ') $ B.drop 1 s in ttyToContact (Contact c) <> rest + else s + +updateInput :: ChatTerminal -> IO () +updateInput ct@ChatTerminal {termSize, termState, nextMessageRow} = do + C.hideCursor + ts <- readTVarIO termState + nmr <- readTVarIO nextMessageRow + let (th, tw) = termSize + ih = inputHeight ts ct + iStart = th - ih + prompt = inputPrompt ts + (cRow, cCol) = relativeCursorPosition tw $ length prompt + inputPosition ts + if nmr >= iStart + then atomically $ writeTVar nextMessageRow iStart + else clearLines nmr iStart + C.setCursorPosition (max nmr iStart) 0 + putStr $ prompt <> inputString ts <> " " + C.clearFromCursorToLineEnd + C.setCursorPosition (iStart + cRow) cCol + C.showCursor + where + clearLines :: Int -> Int -> IO () + clearLines from till + | from >= till = return () + | otherwise = do + C.setCursorPosition from 0 + C.clearFromCursorToLineEnd + clearLines (from + 1) till + + relativeCursorPosition :: Int -> Int -> (Int, Int) + relativeCursorPosition width pos = + let row = pos `div` width + col = pos - row * width + in (row, col) + +updateUsername :: ChatTerminal -> Maybe Contact -> STM () +updateUsername ct a = do + writeTVar (username ct) a + modifyTVar (termState ct) $ \ts -> ts {inputPrompt = promptString a} + +promptString :: Maybe Contact -> String +promptString a = maybe "" (B.unpack . toBs) a <> "> " + +sendToTTY :: ChatTerminal -> IO () +sendToTTY ChatTerminal {outputQ} = + forever $ atomically (readTBQueue outputQ) >>= putLn stdout + +sendToTTY' :: ChatTerminal -> IO () +sendToTTY' ct@ChatTerminal {outputQ} = + forever $ atomically (readTBQueue outputQ) >>= printMessage ct >> updateInput ct + +printMessage :: ChatTerminal -> ByteString -> IO () +printMessage ChatTerminal {termSize, nextMessageRow} msg = do + nmr <- readTVarIO nextMessageRow + C.setCursorPosition nmr 0 + let (th, tw) = termSize + lc <- printLines tw msg + atomically . writeTVar nextMessageRow $ min (th - 1) (nmr + lc) + where + printLines :: Int -> ByteString -> IO Int + printLines tw s = do + let ls + | B.null s = [""] + | otherwise = B.lines s <> ["" | B.last s == '\n'] + print_ ls + return $ foldl (\lc l -> lc + (B.length l `div` tw) + 1) 0 ls + + print_ :: [ByteString] -> IO () + print_ [] = return () + print_ (l : ls) = do + B.hPut stdout l + C.clearFromCursorToLineEnd + B.hPut stdout "\n" + print_ ls + +getKey :: IO Key +getKey = charsToKey . reverse <$> keyChars "" + where + charsToKey = \case + "\ESC" -> KeyEsc + "\ESC[A" -> KeyUp + "\ESC[B" -> KeyDown + "\ESC[D" -> KeyLeft + "\ESC[C" -> KeyRight + "\ESCb" -> KeyAltLeft + "\ESCf" -> KeyAltRight + "\ESC[1;5D" -> KeyCtrlLeft + "\ESC[1;5C" -> KeyCtrlRight + "\ESC[1;2D" -> KeyShiftLeft + "\ESC[1;2C" -> KeyShiftRight + "\n" -> KeyEnter + "\DEL" -> KeyBack + "\t" -> KeyTab + '\ESC' : _ -> KeyUnsupported + cs -> KeyChars cs + + keyChars cs = do + c <- getChar + more <- hReady stdin + -- for debugging - uncomment this, comment line after: + -- (if more then keyChars else \c' -> print (reverse c') >> return c') (c : cs) + (if more then keyChars else return) (c : cs) + +getChatLn :: ChatTerminal -> IO ByteString +getChatLn ct = do + setTTY NoBuffering + getChar >>= \case + '/' -> getRest "/" + '@' -> getRest "@" + ch -> do + let s = encodeUtf8 $ T.singleton ch + readTVarIO (activeContact ct) >>= \case + Nothing -> getRest s + Just a -> getWithContact a s + where + getWithContact :: Contact -> ByteString -> IO ByteString + getWithContact a s = do + C.cursorBackward 1 + B.hPut stdout $ ttyToContact a <> " " <> s + getRest $ "@" <> toBs a <> " " <> s + getRest :: ByteString -> IO ByteString + getRest s = do + setTTY LineBuffering + (s <>) <$> getLn stdin + +setTTY :: BufferMode -> IO () +setTTY mode = do + hSetBuffering stdin mode + hSetBuffering stdout mode + +ttyContact :: Contact -> ByteString +ttyContact (Contact a) = withSGR contactSGR a + +ttyFromContact :: Contact -> ByteString +ttyFromContact (Contact a) = withSGR contactSGR $ a <> ">" + +ttyToContact :: Contact -> ByteString +ttyToContact (Contact a) = withSGR selfSGR $ "@" <> a + +contactSGR :: [C.SGR] +contactSGR = [C.SetColor C.Foreground C.Vivid C.Yellow] + +selfSGR :: [C.SGR] +selfSGR = [C.SetColor C.Foreground C.Vivid C.Cyan] + +withSGR :: [C.SGR] -> ByteString -> ByteString +withSGR sgr s = B.pack (C.setSGRCode sgr) <> s <> B.pack (C.setSGRCode [C.Reset]) diff --git a/Main.hs b/Main.hs index 9975622cb1..6b875473ae 100644 --- a/Main.hs +++ b/Main.hs @@ -10,6 +10,7 @@ module Main where import ChatOptions +import ChatTerminal import Control.Applicative ((<|>)) import Control.Concurrent.STM import Control.Logger.Simple @@ -19,18 +20,14 @@ 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.Transport (getLn, putLn) import Simplex.Messaging.Util (bshow, raceAny_) -import qualified System.Console.ANSI as C -import System.IO +import Types cfg :: AgentConfig cfg = @@ -50,12 +47,9 @@ data ChatClient = ChatClient { inQ :: TBQueue ChatCommand, outQ :: TBQueue ChatResponse, smpServer :: SMPServer, - activeContact :: TVar (Maybe Contact), username :: TVar (Maybe Contact) } -newtype Contact = Contact {toBs :: ByteString} - -- | GroupMessage ChatGroup ByteString -- | AddToGroup Contact data ChatCommand @@ -125,21 +119,24 @@ main :: IO () main = do ChatOpts {dbFileName, smpServer, name} <- getChatOpts putStrLn "simpleX chat prototype (no encryption), \"/help\" for usage information" - t <- getChatClient smpServer (Contact <$> name) + let user = Contact <$> name + t <- getChatClient smpServer user + ct <- newChatTerminal (tbqSize cfg) user -- setLogLevel LogInfo -- LogError -- withGlobalLogging logCfg $ env <- newSMPAgentEnv cfg {dbFile = dbFileName} - dogFoodChat t env + dogFoodChat t ct env -dogFoodChat :: ChatClient -> Env -> IO () -dogFoodChat t env = do +dogFoodChat :: ChatClient -> ChatTerminal -> Env -> IO () +dogFoodChat t ct env = do c <- runReaderT getSMPAgentClient env raceAny_ [ runReaderT (runSMPAgentClient c) env, - sendToAgent t c, - sendToTTY t, - receiveFromAgent t c, - receiveFromTTY t + sendToAgent t ct c, + sendToChatTerm t ct, + receiveFromAgent t ct c, + receiveFromChatTerm t ct, + chatTerminal ct ] getChatClient :: SMPServer -> Maybe Contact -> IO ChatClient @@ -149,32 +146,34 @@ newChatClient :: Natural -> SMPServer -> Maybe Contact -> STM ChatClient newChatClient qSize smpServer name = do inQ <- newTBQueue qSize outQ <- newTBQueue qSize - activeContact <- newTVar Nothing username <- newTVar name - return ChatClient {inQ, outQ, smpServer, activeContact, username} + return ChatClient {inQ, outQ, smpServer, username} -receiveFromTTY :: ChatClient -> IO () -receiveFromTTY t = - forever $ getChatLn t >>= processOrError . A.parseOnly (chatCommandP <* A.endOfInput) +receiveFromChatTerm :: ChatClient -> ChatTerminal -> IO () +receiveFromChatTerm t ct = forever $ do + atomically (readTBQueue $ inputQ ct) + >>= processOrError . A.parseOnly (chatCommandP <* A.endOfInput) where processOrError = \case Left err -> atomically . writeTBQueue (outQ t) . ErrorInput $ B.pack err Right ChatHelp -> atomically . writeTBQueue (outQ t) $ ChatHelpInfo Right (SetName a) -> atomically $ do - writeTVar (username t) $ Just a + let user = Just a + writeTVar (username (t :: ChatClient)) user + updateUsername ct user writeTBQueue (outQ t) YesYes Right cmd -> atomically $ writeTBQueue (inQ t) cmd -sendToTTY :: ChatClient -> IO () -sendToTTY ChatClient {outQ, username} = forever $ do +sendToChatTerm :: ChatClient -> ChatTerminal -> IO () +sendToChatTerm ChatClient {outQ, username} ChatTerminal {outputQ} = forever $ do atomically (readTBQueue outQ) >>= \case NoChatResponse -> return () resp -> do name <- readTVarIO username - putLn stdout $ serializeChatResponse name resp + atomically . writeTBQueue outputQ $ serializeChatResponse name resp -sendToAgent :: ChatClient -> AgentClient -> IO () -sendToAgent ChatClient {inQ, smpServer, activeContact} AgentClient {rcvQ} = +sendToAgent :: ChatClient -> ChatTerminal -> AgentClient -> IO () +sendToAgent ChatClient {inQ, smpServer} ct AgentClient {rcvQ} = forever . atomically $ do cmd <- readTBQueue inQ writeTBQueue rcvQ `mapM_` agentTransmission cmd @@ -182,7 +181,7 @@ sendToAgent ChatClient {inQ, smpServer, activeContact} AgentClient {rcvQ} = where setActiveContact :: ChatCommand -> STM () setActiveContact cmd = - writeTVar activeContact $ case cmd of + writeTVar (activeContact ct) $ case cmd of ChatWith a -> Just a SendMessage a _ -> Just a _ -> Nothing @@ -197,8 +196,8 @@ sendToAgent ChatClient {inQ, smpServer, activeContact} AgentClient {rcvQ} = transmission :: Contact -> ACommand 'Client -> Maybe (ATransmission 'Client) transmission (Contact a) cmd = Just ("1", a, cmd) -receiveFromAgent :: ChatClient -> AgentClient -> IO () -receiveFromAgent t c = forever . atomically $ do +receiveFromAgent :: ChatClient -> ChatTerminal -> AgentClient -> IO () +receiveFromAgent t ct c = forever . atomically $ do resp <- chatResponse <$> readTBQueue (sndQ c) writeTBQueue (outQ t) resp setActiveContact resp @@ -219,49 +218,4 @@ receiveFromAgent t c = forever . atomically $ do Disconnected _ -> set Nothing _ -> return () where - set a = writeTVar (activeContact t) a - -getChatLn :: ChatClient -> IO ByteString -getChatLn t = do - setTTY NoBuffering - getChar >>= \case - '/' -> getRest "/" - '@' -> getRest "@" - ch -> do - let s = encodeUtf8 $ T.singleton ch - readTVarIO (activeContact t) >>= \case - Nothing -> getRest s - Just a -> getWithContact a s - where - getWithContact :: Contact -> ByteString -> IO ByteString - getWithContact a s = do - C.cursorBackward 1 - B.hPut stdout $ ttyToContact a <> " " <> s - getRest $ "@" <> toBs a <> " " <> s - getRest :: ByteString -> IO ByteString - getRest s = do - setTTY LineBuffering - (s <>) <$> getLn stdin - -setTTY :: BufferMode -> IO () -setTTY mode = do - hSetBuffering stdin mode - hSetBuffering stdout mode - -ttyContact :: Contact -> ByteString -ttyContact (Contact a) = withSGR contactSGR a - -ttyFromContact :: Contact -> ByteString -ttyFromContact (Contact a) = withSGR contactSGR $ a <> ">" - -ttyToContact :: Contact -> ByteString -ttyToContact (Contact a) = withSGR selfSGR $ "@" <> a - -contactSGR :: [C.SGR] -contactSGR = [C.SetColor C.Foreground C.Vivid C.Yellow] - -selfSGR :: [C.SGR] -selfSGR = [C.SetColor C.Foreground C.Vivid C.Cyan] - -withSGR :: [C.SGR] -> ByteString -> ByteString -withSGR sgr s = B.pack (C.setSGRCode sgr) <> s <> B.pack (C.setSGRCode [C.Reset]) + set a = writeTVar (activeContact ct) a diff --git a/Types.hs b/Types.hs new file mode 100644 index 0000000000..2dee7ac16b --- /dev/null +++ b/Types.hs @@ -0,0 +1,5 @@ +module Types where + +import Data.ByteString.Char8 (ByteString) + +newtype Contact = Contact {toBs :: ByteString} From d5ea9793dce896a6eb52ebaca25d5b022a414a38 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 22 Feb 2021 23:22:45 +0000 Subject: [PATCH 06/34] add mutex to prevent ansi codes appearing in the output (#50) --- ChatTerminal.hs | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/ChatTerminal.hs b/ChatTerminal.hs index 11777c6c32..8a4661631f 100644 --- a/ChatTerminal.hs +++ b/ChatTerminal.hs @@ -35,7 +35,8 @@ data ChatTerminal = ChatTerminal username :: TVar (Maybe Contact), termState :: TVar TerminalState, termSize :: (Int, Int), - nextMessageRow :: TVar Int + nextMessageRow :: TVar Int, + termLock :: TMVar () } data TerminalState = TerminalState @@ -75,9 +76,10 @@ newChatTerminal qSize user = do termSize <- fromMaybe (0, 0) <$> C.getTerminalSize let lastRow = fst termSize - 1 termState <- newTVarIO $ newTermState user + termLock <- newTMVarIO () nextMessageRow <- newTVarIO lastRow threadDelay 500000 -- this delay is the same as timeout in getTerminalSize - return ChatTerminal {inputQ, outputQ, activeContact, username, termState, termSize, nextMessageRow} + return ChatTerminal {inputQ, outputQ, activeContact, username, termState, termSize, nextMessageRow, termLock} newTermState :: Maybe Contact -> TerminalState newTermState user = @@ -104,10 +106,16 @@ receiveFromTTY :: ChatTerminal -> IO () receiveFromTTY ct@ChatTerminal {inputQ} = forever $ getChatLn ct >>= atomically . writeTBQueue inputQ +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} = forever $ - getKey >>= processKey >> updateInput ct + getKey >>= processKey >> withTermLock ct (updateInput ct) where processKey :: Key -> IO () processKey = \case @@ -124,7 +132,7 @@ receiveFromTTY' ct@ChatTerminal {inputQ, activeContact, termSize, termState} = let msg = encodeUtf8 . T.pack $ inputString ts writeTBQueue inputQ msg return msg - printMessage ct $ highlightContact msg + withTermLock ct . printMessage ct $ highlightContact msg updateTermState :: Maybe Contact -> Int -> Key -> TerminalState -> TerminalState updateTermState ac tw key ts@TerminalState {inputString = s, inputPosition = p} = case key of @@ -228,8 +236,11 @@ sendToTTY ChatTerminal {outputQ} = forever $ atomically (readTBQueue outputQ) >>= putLn stdout sendToTTY' :: ChatTerminal -> IO () -sendToTTY' ct@ChatTerminal {outputQ} = - forever $ atomically (readTBQueue outputQ) >>= printMessage ct >> updateInput ct +sendToTTY' ct@ChatTerminal {outputQ} = forever $ do + msg <- atomically (readTBQueue outputQ) + withTermLock ct $ do + printMessage ct msg + updateInput ct printMessage :: ChatTerminal -> ByteString -> IO () printMessage ChatTerminal {termSize, nextMessageRow} msg = do @@ -279,7 +290,7 @@ getKey = charsToKey . reverse <$> keyChars "" keyChars cs = do c <- getChar more <- hReady stdin - -- for debugging - uncomment this, comment line after: + -- 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 4da27e0dfa2c04b65d72a358b9c5bfe2f1fc0d6c Mon Sep 17 00:00:00 2001 From: Efim Poberezkin Date: Thu, 25 Feb 2021 01:36:05 +0400 Subject: [PATCH 07/34] chat: fix welcome line (#51) --- Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Main.hs b/Main.hs index 6b875473ae..43e1450660 100644 --- a/Main.hs +++ b/Main.hs @@ -118,7 +118,7 @@ chatHelpInfo = main :: IO () main = do ChatOpts {dbFileName, smpServer, name} <- getChatOpts - putStrLn "simpleX chat prototype (no encryption), \"/help\" for usage information" + putStrLn "simpleX chat prototype, \"/help\" for usage information" let user = Contact <$> name t <- getChatClient smpServer user ct <- newChatTerminal (tbqSize cfg) user From 97e80cfb0764e0de3e290c122869d88bf9f6c871 Mon Sep 17 00:00:00 2001 From: Efim Poberezkin Date: Sat, 6 Mar 2021 15:39:00 +0400 Subject: [PATCH 08/34] chat: subscribe to all connections on startup (#70) --- Main.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Main.hs b/Main.hs index 43e1450660..b245d39ba8 100644 --- a/Main.hs +++ b/Main.hs @@ -110,7 +110,6 @@ chatHelpInfo = \/accept - accept \n\ \ (a string that starts from \"smp::\")\n\ \ from your contact \n\ - \/chat - resume chat with \n\ \/name - set to use in invitations\n\ \@ - send (any string) to contact \n\ \ @ can be omitted to send to previous" @@ -173,7 +172,8 @@ sendToChatTerm ChatClient {outQ, username} ChatTerminal {outputQ} = forever $ do atomically . writeTBQueue outputQ $ serializeChatResponse name resp sendToAgent :: ChatClient -> ChatTerminal -> AgentClient -> IO () -sendToAgent ChatClient {inQ, smpServer} ct AgentClient {rcvQ} = +sendToAgent ChatClient {inQ, smpServer} ct AgentClient {rcvQ} = do + atomically $ writeTBQueue rcvQ ("1", "", SUBALL) -- hack for subscribing to all forever . atomically $ do cmd <- readTBQueue inQ writeTBQueue rcvQ `mapM_` agentTransmission cmd @@ -209,7 +209,7 @@ receiveFromAgent t ct c = forever . atomically $ do END -> Disconnected $ Contact a MSG {m_body} -> ReceivedMessage (Contact a) m_body SENT _ -> NoChatResponse - OK -> YesYes + OK -> Connected $ Contact a -- hack for subscribing to all ERR e -> ChatError e setActiveContact :: ChatResponse -> STM () setActiveContact = \case From a3e987b78a91bf24e7cd0d5af7594647a829cd1e Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Tue, 9 Mar 2021 07:05:08 +0000 Subject: [PATCH 09/34] Windows terminal editing (#71) * windows-compatible getChar without buffering, option to use terminal without editing * option to choose terminal mode, conditional compilation for Windows * conditional extension * add basic terminal mode (no contact insertion) * option help --- ChatOptions.hs | 26 +++++++++++++---- ChatTerminal.hs | 78 +++++++++++++++++++++++++++++++++---------------- Main.hs | 4 +-- Types.hs | 2 ++ 4 files changed, 78 insertions(+), 32 deletions(-) diff --git a/ChatOptions.hs b/ChatOptions.hs index 12480ecb00..7051796a88 100644 --- a/ChatOptions.hs +++ b/ChatOptions.hs @@ -1,21 +1,25 @@ +{-# LANGUAGE LambdaCase #-} + module ChatOptions (getChatOpts, ChatOpts (..)) where import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import Options.Applicative import Simplex.Messaging.Agent.Transmission (SMPServer (..), smpServerP) +import Types data ChatOpts = ChatOpts { name :: Maybe B.ByteString, dbFileName :: String, - smpServer :: SMPServer + smpServer :: SMPServer, + termMode :: TermMode } chatOpts :: Parser ChatOpts chatOpts = ChatOpts <$> option - parseName + (Just <$> str) ( long "name" <> short 'n' <> metavar "NAME" @@ -37,13 +41,25 @@ chatOpts = <> help "SMP server to use (smp.simplex.im:5223)" <> value (SMPServer "smp.simplex.im" (Just "5223") Nothing) ) - -parseName :: ReadM (Maybe B.ByteString) -parseName = maybeReader $ Just . Just . B.pack + <*> option + parseTermMode + ( long "term" + <> short 't' + <> metavar "TERM" + <> help "terminal mode: \"editor\", \"simple\" or \"basic\" (editor)" + <> value TermModeEditor + ) parseSMPServer :: ReadM SMPServer parseSMPServer = eitherReader $ A.parseOnly (smpServerP <* A.endOfInput) . B.pack +parseTermMode :: ReadM TermMode +parseTermMode = maybeReader $ \case + "basic" -> Just TermModeBasic + "simple" -> Just TermModeSimple + "editor" -> Just TermModeEditor + _ -> Nothing + getChatOpts :: IO ChatOpts getChatOpts = execParser opts where diff --git a/ChatTerminal.hs b/ChatTerminal.hs index 8a4661631f..78a167982d 100644 --- a/ChatTerminal.hs +++ b/ChatTerminal.hs @@ -1,7 +1,12 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +#ifdef mingw32_HOST_OS +{-# LANGUAGE ForeignFunctionInterface #-} +#endif + module ChatTerminal ( ChatTerminal (..), newChatTerminal, @@ -28,11 +33,17 @@ import qualified System.Console.ANSI as C import System.IO import Types +#ifdef mingw32_HOST_OS +import Data.Char +import Foreign.C.Types +#endif + data ChatTerminal = ChatTerminal { inputQ :: TBQueue ByteString, outputQ :: TBQueue ByteString, activeContact :: TVar (Maybe Contact), username :: TVar (Maybe Contact), + termMode :: TermMode, termState :: TVar TerminalState, termSize :: (Int, Int), nextMessageRow :: TVar Int, @@ -67,8 +78,8 @@ data Key | KeyUnsupported deriving (Eq) -newChatTerminal :: Natural -> Maybe Contact -> IO ChatTerminal -newChatTerminal qSize user = do +newChatTerminal :: Natural -> Maybe Contact -> TermMode -> IO ChatTerminal +newChatTerminal qSize user termMode = do inputQ <- newTBQueueIO qSize outputQ <- newTBQueueIO qSize activeContact <- newTVarIO Nothing @@ -79,7 +90,7 @@ newChatTerminal qSize user = do termLock <- newTMVarIO () nextMessageRow <- newTVarIO lastRow threadDelay 500000 -- this delay is the same as timeout in getTerminalSize - return ChatTerminal {inputQ, outputQ, activeContact, username, termState, termSize, nextMessageRow, termLock} + return ChatTerminal {inputQ, outputQ, activeContact, username, termMode, termState, termSize, nextMessageRow, termLock} newTermState :: Maybe Contact -> TerminalState newTermState user = @@ -90,21 +101,22 @@ newTermState user = } chatTerminal :: ChatTerminal -> IO () -chatTerminal ct = - if termSize ct /= (0, 0) - then do - hSetBuffering stdin NoBuffering - hSetBuffering stdout NoBuffering - hSetEcho stdin False - updateInput ct - run receiveFromTTY' sendToTTY' - else run receiveFromTTY sendToTTY +chatTerminal ct + | termMode ct == TermModeBasic = + run (receiveFromTTY $ getLn stdin) sendToTTY + | termSize ct == (0, 0) || termMode ct == TermModeSimple = + run (receiveFromTTY $ getChatLn ct) sendToTTY + | otherwise = do + setTTY NoBuffering + hSetEcho stdin False + updateInput ct + run receiveFromTTY' sendToTTY' where run receive send = race_ (receive ct) (send ct) -receiveFromTTY :: ChatTerminal -> IO () -receiveFromTTY ct@ChatTerminal {inputQ} = - forever $ getChatLn ct >>= atomically . writeTBQueue inputQ +receiveFromTTY :: IO ByteString -> ChatTerminal -> IO () +receiveFromTTY get ct = + forever $ get >>= atomically . writeTBQueue (inputQ ct) withTermLock :: ChatTerminal -> IO () -> IO () withTermLock ChatTerminal {termLock} action = do @@ -232,16 +244,18 @@ promptString :: Maybe Contact -> String promptString a = maybe "" (B.unpack . toBs) a <> "> " sendToTTY :: ChatTerminal -> IO () -sendToTTY ChatTerminal {outputQ} = - forever $ atomically (readTBQueue outputQ) >>= putLn stdout +sendToTTY ct = forever $ readOutputQ ct >>= putLn stdout sendToTTY' :: ChatTerminal -> IO () -sendToTTY' ct@ChatTerminal {outputQ} = forever $ do - msg <- atomically (readTBQueue outputQ) +sendToTTY' ct = forever $ do + msg <- readOutputQ ct withTermLock ct $ do printMessage ct msg updateInput ct +readOutputQ :: ChatTerminal -> IO ByteString +readOutputQ = atomically . readTBQueue . outputQ + printMessage :: ChatTerminal -> ByteString -> IO () printMessage ChatTerminal {termSize, nextMessageRow} msg = do nmr <- readTVarIO nextMessageRow @@ -288,7 +302,7 @@ getKey = charsToKey . reverse <$> keyChars "" cs -> KeyChars cs keyChars cs = do - c <- getChar + c <- getHiddenChar more <- hReady stdin -- for debugging - uncomment this, comment line after: -- (if more then keyChars else \c' -> print (reverse c') >> return c') (c : cs) @@ -297,25 +311,39 @@ getKey = charsToKey . reverse <$> keyChars "" getChatLn :: ChatTerminal -> IO ByteString getChatLn ct = do setTTY NoBuffering - getChar >>= \case - '/' -> getRest "/" - '@' -> getRest "@" + hSetEcho stdin False + getHiddenChar >>= \case + '/' -> getWithChar "/" + '@' -> getWithChar "@" ch -> do let s = encodeUtf8 $ T.singleton ch readTVarIO (activeContact ct) >>= \case - Nothing -> getRest s + Nothing -> getWithChar s Just a -> getWithContact a s where + getWithChar :: ByteString -> IO ByteString + getWithChar c = do + B.hPut stdout c + getRest c getWithContact :: Contact -> ByteString -> IO ByteString getWithContact a s = do - C.cursorBackward 1 B.hPut stdout $ ttyToContact a <> " " <> s getRest $ "@" <> toBs a <> " " <> s getRest :: ByteString -> IO ByteString getRest s = do setTTY LineBuffering + hSetEcho stdin True (s <>) <$> getLn stdin +getHiddenChar :: IO Char +#ifdef mingw32_HOST_OS +getHiddenChar = fmap (chr.fromEnum) c_getch +foreign import ccall unsafe "conio.h getch" + c_getch :: IO CInt +#else +getHiddenChar = getChar +#endif + setTTY :: BufferMode -> IO () setTTY mode = do hSetBuffering stdin mode diff --git a/Main.hs b/Main.hs index b245d39ba8..d930945659 100644 --- a/Main.hs +++ b/Main.hs @@ -116,11 +116,11 @@ chatHelpInfo = main :: IO () main = do - ChatOpts {dbFileName, smpServer, name} <- getChatOpts + ChatOpts {dbFileName, smpServer, name, termMode} <- getChatOpts putStrLn "simpleX chat prototype, \"/help\" for usage information" let user = Contact <$> name t <- getChatClient smpServer user - ct <- newChatTerminal (tbqSize cfg) user + ct <- newChatTerminal (tbqSize cfg) user termMode -- setLogLevel LogInfo -- LogError -- withGlobalLogging logCfg $ env <- newSMPAgentEnv cfg {dbFile = dbFileName} diff --git a/Types.hs b/Types.hs index 2dee7ac16b..8f0a3c945b 100644 --- a/Types.hs +++ b/Types.hs @@ -3,3 +3,5 @@ module Types where import Data.ByteString.Char8 (ByteString) newtype Contact = Contact {toBs :: ByteString} + +data TermMode = TermModeBasic | TermModeSimple | TermModeEditor deriving (Eq) From 94c756adb571eeef691620031ed57b6df37f49c2 Mon Sep 17 00:00:00 2001 From: Efim Poberezkin <8711996+efim-poberezkin@users.noreply.github.com> Date: Mon, 29 Mar 2021 19:18:54 +0400 Subject: [PATCH 10/34] agent sqlite: initialize database in home directory by default (#74) --- ChatOptions.hs | 16 +++++++++------- Main.hs | 8 ++++++-- 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/ChatOptions.hs b/ChatOptions.hs index 7051796a88..c95ddea85f 100644 --- a/ChatOptions.hs +++ b/ChatOptions.hs @@ -6,6 +6,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import Options.Applicative import Simplex.Messaging.Agent.Transmission (SMPServer (..), smpServerP) +import System.FilePath (combine) import Types data ChatOpts = ChatOpts @@ -15,8 +16,9 @@ data ChatOpts = ChatOpts termMode :: TermMode } -chatOpts :: Parser ChatOpts -chatOpts = +chatOpts :: FilePath -> Parser ChatOpts +chatOpts appDir = do + let defaultDbFilePath = combine appDir "smp-chat.db" ChatOpts <$> option (Just <$> str) @@ -30,8 +32,8 @@ chatOpts = ( long "database" <> short 'd' <> metavar "DB_FILE" - <> help "sqlite database filename (smp-chat.db)" - <> value "smp-chat.db" + <> help ("sqlite database file path (" ++ defaultDbFilePath ++ ")") + <> value defaultDbFilePath ) <*> option parseSMPServer @@ -60,12 +62,12 @@ parseTermMode = maybeReader $ \case "editor" -> Just TermModeEditor _ -> Nothing -getChatOpts :: IO ChatOpts -getChatOpts = execParser opts +getChatOpts :: FilePath -> IO ChatOpts +getChatOpts appDir = execParser opts where opts = info - (chatOpts <**> helper) + (chatOpts appDir <**> helper) ( fullDesc <> header "Chat prototype using Simplex Messaging Protocol (SMP)" <> progDesc "Start chat with DB_FILE file and use SERVER as SMP server" diff --git a/Main.hs b/Main.hs index d930945659..4c1f87abb4 100644 --- a/Main.hs +++ b/Main.hs @@ -27,6 +27,7 @@ import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Transmission import Simplex.Messaging.Client (smpDefaultConfig) import Simplex.Messaging.Util (bshow, raceAny_) +import System.Directory (getAppUserDataDirectory) import Types cfg :: AgentConfig @@ -116,8 +117,11 @@ chatHelpInfo = main :: IO () main = do - ChatOpts {dbFileName, smpServer, name, termMode} <- getChatOpts - putStrLn "simpleX chat prototype, \"/help\" for usage information" + appDir <- getAppUserDataDirectory "simplex" + ChatOpts {dbFileName, smpServer, name, termMode} <- getChatOpts appDir + putStrLn "simpleX chat prototype" + putStrLn $ "db: " ++ dbFileName + putStrLn "type \"/help\" for usage information" let user = Contact <$> name t <- getChatClient smpServer user ct <- newChatTerminal (tbqSize cfg) user termMode From c1fdcfb906ffb34f634ec4d91be5325a1d0e13ff Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 3 Apr 2021 20:39:37 +0100 Subject: [PATCH 11/34] enforce windows terminal mode to basic, warning message (#77) --- ChatOptions.hs | 15 ++++++++++----- ChatTerminal.hs | 26 +++++++++++++------------- Main.hs | 27 ++++++++++++++++++++++----- Types.hs | 8 ++++++++ 4 files changed, 53 insertions(+), 23 deletions(-) diff --git a/ChatOptions.hs b/ChatOptions.hs index c95ddea85f..72bc6f9854 100644 --- a/ChatOptions.hs +++ b/ChatOptions.hs @@ -7,6 +7,7 @@ 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 @@ -17,8 +18,7 @@ data ChatOpts = ChatOpts } chatOpts :: FilePath -> Parser ChatOpts -chatOpts appDir = do - let defaultDbFilePath = combine appDir "smp-chat.db" +chatOpts appDir = ChatOpts <$> option (Just <$> str) @@ -32,7 +32,7 @@ chatOpts appDir = do ( long "database" <> short 'd' <> metavar "DB_FILE" - <> help ("sqlite database file path (" ++ defaultDbFilePath ++ ")") + <> help ("sqlite database file path (" <> defaultDbFilePath <> ")") <> value defaultDbFilePath ) <*> option @@ -48,9 +48,14 @@ chatOpts appDir = do ( long "term" <> short 't' <> metavar "TERM" - <> help "terminal mode: \"editor\", \"simple\" or \"basic\" (editor)" - <> value TermModeEditor + <> help ("terminal mode: editor, simple or basic (" <> termModeName deafultTermMode <> ")") + <> value deafultTermMode ) + 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 78a167982d..641daf55bf 100644 --- a/ChatTerminal.hs +++ b/ChatTerminal.hs @@ -3,9 +3,9 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -#ifdef mingw32_HOST_OS -{-# LANGUAGE ForeignFunctionInterface #-} -#endif +-- #ifdef mingw32_HOST_OS +-- {-# LANGUAGE ForeignFunctionInterface #-} +-- #endif module ChatTerminal ( ChatTerminal (..), @@ -33,10 +33,10 @@ import qualified System.Console.ANSI as C import System.IO import Types -#ifdef mingw32_HOST_OS -import Data.Char -import Foreign.C.Types -#endif +-- #ifdef mingw32_HOST_OS +-- import Data.Char +-- import Foreign.C.Types +-- #endif data ChatTerminal = ChatTerminal { inputQ :: TBQueue ByteString, @@ -336,13 +336,13 @@ getChatLn ct = do (s <>) <$> getLn stdin getHiddenChar :: IO Char -#ifdef mingw32_HOST_OS -getHiddenChar = fmap (chr.fromEnum) c_getch -foreign import ccall unsafe "conio.h getch" - c_getch :: IO CInt -#else +-- #ifdef mingw32_HOST_OS +-- getHiddenChar = fmap (chr.fromEnum) c_getch +-- foreign import ccall unsafe "conio.h getch" +-- c_getch :: IO CInt +-- #else getHiddenChar = getChar -#endif +-- #endif setTTY :: BufferMode -> IO () setTTY mode = do diff --git a/Main.hs b/Main.hs index 4c1f87abb4..ac33b81e50 100644 --- a/Main.hs +++ b/Main.hs @@ -28,6 +28,8 @@ import Simplex.Messaging.Agent.Transmission import Simplex.Messaging.Client (smpDefaultConfig) import Simplex.Messaging.Util (bshow, raceAny_) import System.Directory (getAppUserDataDirectory) +import System.Exit (exitFailure) +import System.Info (os) import Types cfg :: AgentConfig @@ -117,11 +119,7 @@ chatHelpInfo = main :: IO () main = do - appDir <- getAppUserDataDirectory "simplex" - ChatOpts {dbFileName, smpServer, name, termMode} <- getChatOpts appDir - putStrLn "simpleX chat prototype" - putStrLn $ "db: " ++ dbFileName - putStrLn "type \"/help\" for usage information" + ChatOpts {dbFileName, smpServer, name, termMode} <- welcomeGetOpts let user = Contact <$> name t <- getChatClient smpServer user ct <- newChatTerminal (tbqSize cfg) user termMode @@ -130,6 +128,25 @@ main = do env <- newSMPAgentEnv cfg {dbFile = dbFileName} dogFoodChat t ct env +welcomeGetOpts :: IO ChatOpts +welcomeGetOpts = do + appDir <- getAppUserDataDirectory "simplex" + opts@ChatOpts {dbFileName, termMode} <- 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/Types.hs b/Types.hs index 8f0a3c945b..2b5c9b6d6e 100644 --- a/Types.hs +++ b/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + module Types where import Data.ByteString.Char8 (ByteString) @@ -5,3 +7,9 @@ import Data.ByteString.Char8 (ByteString) newtype Contact = Contact {toBs :: ByteString} data TermMode = TermModeBasic | TermModeSimple | TermModeEditor deriving (Eq) + +termModeName :: TermMode -> String +termModeName = \case + TermModeBasic -> "basic" + TermModeSimple -> "simple" + TermModeEditor -> "editor" From 578e06cd750e4cb13a6707482bf519a2e664730f Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 3 Apr 2021 21:53:16 +0100 Subject: [PATCH 12/34] remove terminal mode "simple" (#78) --- ChatOptions.hs | 3 +-- ChatTerminal.hs | 59 +++++-------------------------------------------- Types.hs | 3 +-- 3 files changed, 8 insertions(+), 57 deletions(-) diff --git a/ChatOptions.hs b/ChatOptions.hs index 72bc6f9854..0a7ff89f09 100644 --- a/ChatOptions.hs +++ b/ChatOptions.hs @@ -48,7 +48,7 @@ chatOpts appDir = ( long "term" <> short 't' <> metavar "TERM" - <> help ("terminal mode: editor, simple or basic (" <> termModeName deafultTermMode <> ")") + <> help ("terminal mode: editor or basic (" <> termModeName deafultTermMode <> ")") <> value deafultTermMode ) where @@ -63,7 +63,6 @@ parseSMPServer = eitherReader $ A.parseOnly (smpServerP <* A.endOfInput) . B.pac parseTermMode :: ReadM TermMode parseTermMode = maybeReader $ \case "basic" -> Just TermModeBasic - "simple" -> Just TermModeSimple "editor" -> Just TermModeEditor _ -> Nothing diff --git a/ChatTerminal.hs b/ChatTerminal.hs index 641daf55bf..ccc5a87616 100644 --- a/ChatTerminal.hs +++ b/ChatTerminal.hs @@ -3,10 +3,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} --- #ifdef mingw32_HOST_OS --- {-# LANGUAGE ForeignFunctionInterface #-} --- #endif - module ChatTerminal ( ChatTerminal (..), newChatTerminal, @@ -33,11 +29,6 @@ import qualified System.Console.ANSI as C import System.IO import Types --- #ifdef mingw32_HOST_OS --- import Data.Char --- import Foreign.C.Types --- #endif - data ChatTerminal = ChatTerminal { inputQ :: TBQueue ByteString, outputQ :: TBQueue ByteString, @@ -102,10 +93,8 @@ newTermState user = chatTerminal :: ChatTerminal -> IO () chatTerminal ct - | termMode ct == TermModeBasic = - run (receiveFromTTY $ getLn stdin) sendToTTY - | termSize ct == (0, 0) || termMode ct == TermModeSimple = - run (receiveFromTTY $ getChatLn ct) sendToTTY + | termSize ct == (0, 0) || termMode ct == TermModeBasic = + run receiveFromTTY sendToTTY | otherwise = do setTTY NoBuffering hSetEcho stdin False @@ -114,9 +103,9 @@ chatTerminal ct where run receive send = race_ (receive ct) (send ct) -receiveFromTTY :: IO ByteString -> ChatTerminal -> IO () -receiveFromTTY get ct = - forever $ get >>= atomically . writeTBQueue (inputQ ct) +receiveFromTTY :: ChatTerminal -> IO () +receiveFromTTY ct = + forever $ getLn stdin >>= atomically . writeTBQueue (inputQ ct) withTermLock :: ChatTerminal -> IO () -> IO () withTermLock ChatTerminal {termLock} action = do @@ -302,48 +291,12 @@ getKey = charsToKey . reverse <$> keyChars "" cs -> KeyChars cs keyChars cs = do - c <- getHiddenChar + 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) -getChatLn :: ChatTerminal -> IO ByteString -getChatLn ct = do - setTTY NoBuffering - hSetEcho stdin False - getHiddenChar >>= \case - '/' -> getWithChar "/" - '@' -> getWithChar "@" - ch -> do - let s = encodeUtf8 $ T.singleton ch - readTVarIO (activeContact ct) >>= \case - Nothing -> getWithChar s - Just a -> getWithContact a s - where - getWithChar :: ByteString -> IO ByteString - getWithChar c = do - B.hPut stdout c - getRest c - getWithContact :: Contact -> ByteString -> IO ByteString - getWithContact a s = do - B.hPut stdout $ ttyToContact a <> " " <> s - getRest $ "@" <> toBs a <> " " <> s - getRest :: ByteString -> IO ByteString - getRest s = do - setTTY LineBuffering - hSetEcho stdin True - (s <>) <$> getLn stdin - -getHiddenChar :: IO Char --- #ifdef mingw32_HOST_OS --- getHiddenChar = fmap (chr.fromEnum) c_getch --- foreign import ccall unsafe "conio.h getch" --- c_getch :: IO CInt --- #else -getHiddenChar = getChar --- #endif - setTTY :: BufferMode -> IO () setTTY mode = do hSetBuffering stdin mode diff --git a/Types.hs b/Types.hs index 2b5c9b6d6e..ae03c01989 100644 --- a/Types.hs +++ b/Types.hs @@ -6,10 +6,9 @@ import Data.ByteString.Char8 (ByteString) newtype Contact = Contact {toBs :: ByteString} -data TermMode = TermModeBasic | TermModeSimple | TermModeEditor deriving (Eq) +data TermMode = TermModeBasic | TermModeEditor deriving (Eq) termModeName :: TermMode -> String termModeName = \case TermModeBasic -> "basic" - TermModeSimple -> "simple" TermModeEditor -> "editor" From 0ccde5871c84d1885c9060a2e15aa532c4d37807 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 5 Apr 2021 13:10:16 +0100 Subject: [PATCH 13/34] transport encryption (#65) * transport encryption (WIP - using fixed key, parsing/serialization works, SMP tests fail) * transport encryption * transport encryption: separate keys to receive and to send, counter-based IVs * docs: update transport encryption and handshake * transport encryption handshake (TODO: validate key hash, welcome block, move keys to system environment) * change KeyHash type to newtype of Digest SHA256 * transport encryption: validate public key hash * send and receive welcome block with SMP version * refactor: parsing SMPServer * remove unused function * verify that client version is compatible with server version (major version is not smaller) * update (fix) SMP server tests --- ChatOptions.hs | 4 ++-- Main.hs | 5 +++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/ChatOptions.hs b/ChatOptions.hs index 0a7ff89f09..0940c34b8f 100644 --- a/ChatOptions.hs +++ b/ChatOptions.hs @@ -2,10 +2,10 @@ module ChatOptions (getChatOpts, ChatOpts (..)) where -import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import Options.Applicative import Simplex.Messaging.Agent.Transmission (SMPServer (..), smpServerP) +import Simplex.Messaging.Parsers (parseAll) import System.FilePath (combine) import System.Info (os) import Types @@ -58,7 +58,7 @@ chatOpts appDir = | otherwise = TermModeEditor parseSMPServer :: ReadM SMPServer -parseSMPServer = eitherReader $ A.parseOnly (smpServerP <* A.endOfInput) . B.pack +parseSMPServer = eitherReader $ parseAll smpServerP . B.pack parseTermMode :: ReadM TermMode parseTermMode = maybeReader $ \case diff --git a/Main.hs b/Main.hs index ac33b81e50..bc2c1c198f 100644 --- a/Main.hs +++ b/Main.hs @@ -26,6 +26,7 @@ import Simplex.Messaging.Agent.Client (AgentClient (..)) import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Transmission import Simplex.Messaging.Client (smpDefaultConfig) +import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Util (bshow, raceAny_) import System.Directory (getAppUserDataDirectory) import System.Exit (exitFailure) @@ -124,7 +125,7 @@ main = do t <- getChatClient smpServer user ct <- newChatTerminal (tbqSize cfg) user termMode -- setLogLevel LogInfo -- LogError - -- withGlobalLogging logCfg $ + -- withGlobalLogging logCfg $ do env <- newSMPAgentEnv cfg {dbFile = dbFileName} dogFoodChat t ct env @@ -172,7 +173,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 . parseAll chatCommandP where processOrError = \case Left err -> atomically . writeTBQueue (outQ t) . ErrorInput $ B.pack err 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 14/34] 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 15/34] 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 16/34] 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 17/34] 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 18/34] 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 19/34] 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 20/34] 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 21/34] 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 22/34] 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 23/34] 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 24/34] 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 25/34] 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 26/34] 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 27/34] 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 From f767d1f8ff84c3509d0adeb27d9ca85a9e0859f2 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 19 Apr 2021 08:40:23 +0100 Subject: [PATCH 28/34] chat: add connection errors in chat, fix catch (#103) --- Main.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/Main.hs b/Main.hs index b7127be0d5..f4100e9a18 100644 --- a/Main.hs +++ b/Main.hs @@ -90,6 +90,7 @@ data ChatResponse | ReceivedMessage Contact ByteString | Disconnected Contact | YesYes + | ContactError ConnectionErrorType Contact | ErrorInput ByteString | ChatError AgentErrorType | NoChatResponse @@ -110,6 +111,10 @@ serializeChatResponse = \case ReceivedMessage c t -> prependFirst (ttyFromContact c) $ msgPlain t Disconnected c -> ["disconnected from " <> ttyContact c <> " - try \"/chat " <> bPlain (toBs c) <> "\""] YesYes -> ["you got it!"] + ContactError e c -> case e of + UNKNOWN -> ["no contact " <> ttyContact c] + DUPLICATE -> ["contact " <> ttyContact c <> " already exists"] + SIMPLEX -> ["contact " <> ttyContact c <> " did not accept invitation yet"] ErrorInput t -> ["invalid input: " <> bPlain t] ChatError e -> ["chat error: " <> plain (show e)] NoChatResponse -> [""] @@ -256,6 +261,7 @@ receiveFromAgent t ct c = forever . atomically $ do MSG {m_body} -> ReceivedMessage contact m_body SENT _ -> NoChatResponse OK -> Confirmation contact + ERR (CONN e) -> ContactError e contact ERR e -> ChatError e where contact = Contact a From 88314ebadbfd1dfe44edacdd75c4c557eeca0729 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 26 Apr 2021 20:18:20 +0100 Subject: [PATCH 29/34] set different default server (#107) * set different default server * remove comment --- ChatOptions.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/ChatOptions.hs b/ChatOptions.hs index 7b501b3ff4..8d0a0560f4 100644 --- a/ChatOptions.hs +++ b/ChatOptions.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module ChatOptions (getChatOpts, ChatOpts (..)) where @@ -30,8 +31,8 @@ chatOpts appDir = ( long "server" <> short 's' <> metavar "SERVER" - <> help "SMP server to use (smp.simplex.im:5223)" - <> value (SMPServer "smp.simplex.im" (Just "5223") Nothing) + <> help "SMP server to use (smp1.simplex.im:5223#pLdiGvm0jD1CMblnov6Edd/391OrYsShw+RgdfR0ChA=)" + <> value (SMPServer "smp1.simplex.im" (Just "5223") (Just "pLdiGvm0jD1CMblnov6Edd/391OrYsShw+RgdfR0ChA=")) ) <*> option parseTermMode From 7b31fafc2df0c20b6cc93cd4e7c8ac05ed1559c3 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 26 Apr 2021 20:34:28 +0100 Subject: [PATCH 30/34] Store log (#108) * StoreLog (WIP) * add log records to map * revert Protocol change * revert Server change * fix parseLogRecord * optionally save/restore queues to/from store log * refactor * refactor delQueueAndMsgs * move store log to /var/opt/simplex * use ini file --- Main.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Main.hs b/Main.hs index f4100e9a18..bf874285d8 100644 --- a/Main.hs +++ b/Main.hs @@ -109,6 +109,7 @@ serializeChatResponse = \case Connected c -> [ttyContact c <> " connected"] Confirmation c -> [ttyContact c <> " ok"] ReceivedMessage c t -> prependFirst (ttyFromContact c) $ msgPlain t + -- TODO either add command to re-connect or update message below Disconnected c -> ["disconnected from " <> ttyContact c <> " - try \"/chat " <> bPlain (toBs c) <> "\""] YesYes -> ["you got it!"] ContactError e c -> case e of From 8aaf0df8e70d26cea74f002208a54fb9718e42d1 Mon Sep 17 00:00:00 2001 From: Mark Aleksander Hil <32651095+markaleksanderh@users.noreply.github.com> Date: Thu, 29 Apr 2021 10:27:07 +0100 Subject: [PATCH 31/34] Updated ChatHelpInfo (#112) --- Main.hs | 61 ++++++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 45 insertions(+), 16 deletions(-) diff --git a/Main.hs b/Main.hs index cdc1152bc8..d7100d2e5b 100644 --- a/Main.hs +++ b/Main.hs @@ -119,29 +119,58 @@ serializeChatResponse = \case msgPlain :: ByteString -> [StyledString] msgPlain = map styleMarkdownText . T.lines . safeDecodeUtf8 + chatHelpInfo :: [StyledString] chatHelpInfo = map styleMarkdown - [ "Using chat:", - highlight "/add " <> " - create invitation to send out-of-band to your contact ", - " ( is the alias you choose to message your contact)", - highlight "/connect " <> " - connect using ", - " (a string returned by /add that starts from \"smp::\")", - " if /connect is used by your contact,", - " is the alias your contact chooses to message you", - highlight "@ " <> " - send (any string) to contact ", - " @ will be auto-typed to send to the previous contact -", - " just start typing the message!", - highlight "/delete" <> " - delete contact and all messages you had with them", - highlight "/markdown" <> " - markdown cheat-sheet", - "", - "Commands can be abbreviated to 1 letter: ", - listCommands ["/h", "/a", "/c", "/d", "/m"] - ] + [ + "", + Markdown (Colored Green) "Using Simplex chat prototype:", + indent <> "A connection is established in three steps.", + indent <> "The following example shows how to set up a connection and message a contact.", + "", + Markdown (Colored Green) "Step 1:", + indent <> "Alice enters the add command to add her contact, Bob.", + "", + indent <> Markdown (Colored Yellow) "/add bob", + "", + indent <> "The add command creates an invitation.", + indent <> "Alice adds a name for her contact, Bob.", + indent <> "The command outputs an invitation to the terminal.", + indent <> "Alice copies the key and sends it to her contact,", + indent <> "Bob, out of band using a trusted method.", + "", + Markdown (Colored Green) "Step 2:", + indent <> "When Bob receives the invitation from Alice,", + indent <> "he uses the connect command to establish a connection.", + "", + indent <> Markdown (Colored Yellow) "/connect alice ", + "", + + indent <> "Bob enters the command, followed by a name for his contact,", + indent <> "- in this case Alice - followed by the invitation he received out of band from Alice.", + "", + Markdown (Colored Green) "Step 3:", + indent <> "Bob and Alice are notified once the connection is established.", + indent <> "Both may now use the message command to send a message.", + "", + indent <> Markdown (Colored Yellow) "@bob Hello, Alice!", + "", + "", + Markdown (Colored Green) "Other commands:", + indent <> Markdown (Colored Yellow) "/delete" <> " - deletes contact and all communications with them.", + indent <> Markdown (Colored Yellow) "/markdown" <> " - displays cheatsheet of markdown syntax.", + "", + "The above commands may be abbreviated to a single letter: ", + listCommands ["/a", "/c", "/m", "/d"] + + ] + where listCommands = mconcat . intersperse ", " . map highlight highlight = Markdown (Colored Cyan) + indent = " " markdownInfo :: [StyledString] markdownInfo = From 28b7d01117df6d3476299568d023161998cc09e5 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Fri, 30 Apr 2021 09:06:59 +0100 Subject: [PATCH 32/34] reduce help size (#113) --- Main.hs | 68 +++++++++++++++++++-------------------------------------- 1 file changed, 23 insertions(+), 45 deletions(-) diff --git a/Main.hs b/Main.hs index d7100d2e5b..7204971cda 100644 --- a/Main.hs +++ b/Main.hs @@ -119,58 +119,36 @@ serializeChatResponse = \case msgPlain :: ByteString -> [StyledString] msgPlain = map styleMarkdownText . T.lines . safeDecodeUtf8 - chatHelpInfo :: [StyledString] chatHelpInfo = map styleMarkdown - [ - "", - Markdown (Colored Green) "Using Simplex chat prototype:", - indent <> "A connection is established in three steps.", - indent <> "The following example shows how to set up a connection and message a contact.", - "", - Markdown (Colored Green) "Step 1:", - indent <> "Alice enters the add command to add her contact, Bob.", - "", - indent <> Markdown (Colored Yellow) "/add bob", - "", - indent <> "The add command creates an invitation.", - indent <> "Alice adds a name for her contact, Bob.", - indent <> "The command outputs an invitation to the terminal.", - indent <> "Alice copies the key and sends it to her contact,", - indent <> "Bob, out of band using a trusted method.", - "", - Markdown (Colored Green) "Step 2:", - indent <> "When Bob receives the invitation from Alice,", - indent <> "he uses the connect command to establish a connection.", - "", - indent <> Markdown (Colored Yellow) "/connect alice ", - "", - - indent <> "Bob enters the command, followed by a name for his contact,", - indent <> "- in this case Alice - followed by the invitation he received out of band from Alice.", - "", - Markdown (Colored Green) "Step 3:", - indent <> "Bob and Alice are notified once the connection is established.", - indent <> "Both may now use the message command to send a message.", - "", - indent <> Markdown (Colored Yellow) "@bob Hello, Alice!", - "", - "", - Markdown (Colored Green) "Other commands:", - indent <> Markdown (Colored Yellow) "/delete" <> " - deletes contact and all communications with them.", - indent <> Markdown (Colored Yellow) "/markdown" <> " - displays cheatsheet of markdown syntax.", - "", - "The above commands may be abbreviated to a single letter: ", - listCommands ["/a", "/c", "/m", "/d"] - - ] - + [ Markdown (Colored Cyan) "Using Simplex chat prototype.", + "Follow these steps to set up a connection:", + "", + Markdown (Colored Green) "Step 1: " <> Markdown (Colored Cyan) "/add bob" <> " -- Alice adds her contact, Bob (she can use any name).", + indent <> "Alice should send the invitation printed by the /add command", + indent <> "to her contact, Bob, out-of-band, via any trusted channel.", + "", + Markdown (Colored Green) "Step 2: " <> Markdown (Colored Cyan) "/connect alice " <> " -- Bob accepts the invitation.", + indent <> "Bob also can use any name for his contact, Alice,", + indent <> "followed by the invitation he received out-of-band.", + "", + Markdown (Colored Green) "Step 3: " <> "Bob and Alice are notified that the connection is set up,", + indent <> "both can now send messages:", + indent <> Markdown (Colored Cyan) "@bob Hello, Bob!" <> " -- Alice messages Bob.", + indent <> Markdown (Colored Cyan) "@alice Hey, Alice!" <> " -- Bob replies to Alice.", + "", + Markdown (Colored Green) "Other commands:", + indent <> Markdown (Colored Cyan) "/delete" <> " -- deletes contact and all messages with them.", + indent <> Markdown (Colored Cyan) "/markdown" <> " -- prints the supported markdown syntax.", + "", + "The commands may be abbreviated to a single letter: " <> listCommands ["/a", "/c", "/d", "/m"] + ] where listCommands = mconcat . intersperse ", " . map highlight highlight = Markdown (Colored Cyan) - indent = " " + indent = " " markdownInfo :: [StyledString] markdownInfo = From 6a589688c643d50db43925bf6f3d4e12435297bd Mon Sep 17 00:00:00 2001 From: Efim Poberezkin <8711996+efim-poberezkin@users.noreply.github.com> Date: Sun, 2 May 2021 00:38:32 +0400 Subject: [PATCH 33/34] agent: verify msg integrity based on previous msg hash and id (#110) Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> --- Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Main.hs b/Main.hs index bf874285d8..3517746a5a 100644 --- a/Main.hs +++ b/Main.hs @@ -259,7 +259,7 @@ receiveFromAgent t ct c = forever . atomically $ do INV qInfo -> Invitation qInfo CON -> Connected contact END -> Disconnected contact - MSG {m_body} -> ReceivedMessage contact m_body + MSG {msgBody} -> ReceivedMessage contact msgBody SENT _ -> NoChatResponse OK -> Confirmation contact ERR (CONN e) -> ContactError e contact From f7d561e9ea6a8659df19a7bb96ea02d6e74d416d Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 2 May 2021 20:40:13 +0100 Subject: [PATCH 34/34] move chat files to src --- ChatOptions.hs => src/ChatOptions.hs | 0 ChatTerminal.hs => src/ChatTerminal.hs | 0 {ChatTerminal => src/ChatTerminal}/Basic.hs | 0 {ChatTerminal => src/ChatTerminal}/Core.hs | 0 {ChatTerminal => src/ChatTerminal}/Editor.hs | 0 Main.hs => src/Main.hs | 0 Styled.hs => src/Styled.hs | 0 Types.hs => src/Types.hs | 0 8 files changed, 0 insertions(+), 0 deletions(-) rename ChatOptions.hs => src/ChatOptions.hs (100%) rename ChatTerminal.hs => src/ChatTerminal.hs (100%) rename {ChatTerminal => src/ChatTerminal}/Basic.hs (100%) rename {ChatTerminal => src/ChatTerminal}/Core.hs (100%) rename {ChatTerminal => src/ChatTerminal}/Editor.hs (100%) rename Main.hs => src/Main.hs (100%) rename Styled.hs => src/Styled.hs (100%) rename Types.hs => src/Types.hs (100%) diff --git a/ChatOptions.hs b/src/ChatOptions.hs similarity index 100% rename from ChatOptions.hs rename to src/ChatOptions.hs diff --git a/ChatTerminal.hs b/src/ChatTerminal.hs similarity index 100% rename from ChatTerminal.hs rename to src/ChatTerminal.hs diff --git a/ChatTerminal/Basic.hs b/src/ChatTerminal/Basic.hs similarity index 100% rename from ChatTerminal/Basic.hs rename to src/ChatTerminal/Basic.hs diff --git a/ChatTerminal/Core.hs b/src/ChatTerminal/Core.hs similarity index 100% rename from ChatTerminal/Core.hs rename to src/ChatTerminal/Core.hs diff --git a/ChatTerminal/Editor.hs b/src/ChatTerminal/Editor.hs similarity index 100% rename from ChatTerminal/Editor.hs rename to src/ChatTerminal/Editor.hs diff --git a/Main.hs b/src/Main.hs similarity index 100% rename from Main.hs rename to src/Main.hs diff --git a/Styled.hs b/src/Styled.hs similarity index 100% rename from Styled.hs rename to src/Styled.hs diff --git a/Types.hs b/src/Types.hs similarity index 100% rename from Types.hs rename to src/Types.hs