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] 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 12480ecb0..7051796a8 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 8a4661631..78a167982 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 b245d39ba..d93094565 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 2dee7ac16..8f0a3c945 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)