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

@@ -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

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

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}

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)