dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-05-15 05:15:07 +00:00
Code Issues Packages Projects Releases Wiki Activity

Support windows terminal in basic mode (#80)

Browse Source 
* 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
This commit is contained in:
Evgeny Poberezkin
2021-04-07 20:20:32 +01:00
committed by GitHub
parent d8965d4a23
commit 59ef46314d
7 changed files with 163 additions and 52 deletions
Download Patch File Download Diff File Expand all files Collapse all files
apps/dog-food/ChatOptions.hs
+2 -1
View File
@@ -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
apps/dog-food/ChatTerminal.hs
+28 -37
View File
@@ -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])
apps/dog-food/Main.hs
+21 -14
View File
@@ -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 = "<your name>"
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 <name> - 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
apps/dog-food/Styled.hs
+29
View File
@@ -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
apps/dog-food/Terminal.hs
+81
View File
@@ -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
package.yaml
+1
View File
@@ -63,6 +63,7 @@ executables:
- ansi-terminal == 0.10.*
- optparse-applicative == 0.15.*
- simplex-messaging
- terminal == 0.2.*
ghc-options:
- -threaded
stack.yaml
+1
View File
@@ -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