From 59ef46314dd2f6183ea01baf0f17553f775cb46f 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] 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 --- apps/dog-food/ChatOptions.hs | 3 +- apps/dog-food/ChatTerminal.hs | 65 ++++++++++++---------------- apps/dog-food/Main.hs | 35 +++++++++------ apps/dog-food/Styled.hs | 29 +++++++++++++ apps/dog-food/Terminal.hs | 81 +++++++++++++++++++++++++++++++++++ package.yaml | 1 + stack.yaml | 1 + 7 files changed, 163 insertions(+), 52 deletions(-) create mode 100644 apps/dog-food/Styled.hs create mode 100644 apps/dog-food/Terminal.hs diff --git a/apps/dog-food/ChatOptions.hs b/apps/dog-food/ChatOptions.hs index 0a7ff89f0..e51f576fd 100644 --- a/apps/dog-food/ChatOptions.hs +++ b/apps/dog-food/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/apps/dog-food/ChatTerminal.hs b/apps/dog-food/ChatTerminal.hs index ccc5a8761..9797fb040 100644 --- a/apps/dog-food/ChatTerminal.hs +++ b/apps/dog-food/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/apps/dog-food/Main.hs b/apps/dog-food/Main.hs index ac33b81e5..858997d6c 100644 --- a/apps/dog-food/Main.hs +++ b/apps/dog-food/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/apps/dog-food/Styled.hs b/apps/dog-food/Styled.hs new file mode 100644 index 000000000..f355a55c7 --- /dev/null +++ b/apps/dog-food/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/apps/dog-food/Terminal.hs b/apps/dog-food/Terminal.hs new file mode 100644 index 000000000..916eb06d1 --- /dev/null +++ b/apps/dog-food/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 diff --git a/package.yaml b/package.yaml index 83000817e..69014c761 100644 --- a/package.yaml +++ b/package.yaml @@ -63,6 +63,7 @@ executables: - ansi-terminal == 0.10.* - optparse-applicative == 0.15.* - simplex-messaging + - terminal == 0.2.* ghc-options: - -threaded diff --git a/stack.yaml b/stack.yaml index 0926d5374..7819ad877 100644 --- a/stack.yaml +++ b/stack.yaml @@ -38,6 +38,7 @@ extra-deps: - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 - simple-logger-0.1.0@sha256:be8ede4bd251a9cac776533bae7fb643369ebd826eb948a9a18df1a8dd252ff8,1079 + - terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977 # - network-run-0.2.4@sha256:7dbb06def522dab413bce4a46af476820bffdff2071974736b06f52f4ab57c96,885 # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a