Merge branch 'master' into v2

ChatOptions.hs

@@ -7,12 +7,10 @@ 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
 
 data ChatOpts = ChatOpts
-  { name :: Maybe B.ByteString,
-    dbFileName :: String,
+  { dbFileName :: String,
     smpServer :: SMPServer,
     termMode :: TermMode
   }
@@ -20,15 +18,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"
@@ -48,14 +38,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 $ parseAll smpServerP . B.pack

ChatTerminal.hs

@@ -7,315 +7,97 @@ module ChatTerminal
   ( ChatTerminal (..),
     newChatTerminal,
     chatTerminal,
-    updateUsername,
     ttyContact,
     ttyFromContact,
   )
 where
 
+import ChatTerminal.Basic
+import ChatTerminal.Core
+import ChatTerminal.Editor
 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 Styled
+import System.Terminal
 import Types
+import UnliftIO.STM
 
-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,
-    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
+newChatTerminal :: Natural -> TermMode -> IO ChatTerminal
+newChatTerminal qSize termMode = 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
+  termSize <- withTerminal . runTerminalT $ getWindowSize
+  let lastRow = height termSize - 1
+  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 = ""
     }
 
 chatTerminal :: ChatTerminal -> IO ()
 chatTerminal ct
-  | termSize ct == (0, 0) || termMode ct == TermModeBasic =
-    run receiveFromTTY sendToTTY
+  | termSize ct == Size 0 0 || termMode ct == TermModeBasic =
+    run basicReceiveFromTTY basicSendToTTY
   | otherwise = do
-    setTTY NoBuffering
-    hSetEcho stdin False
-    updateInput ct
-    run receiveFromTTY' sendToTTY'
+    withTerminal . runTerminalT $ updateInput ct
+    run receiveFromTTY sendToTTY
   where
     run receive send = race_ (receive ct) (send ct)
 
-receiveFromTTY :: ChatTerminal -> IO ()
-receiveFromTTY ct =
-  forever $ getLn stdin >>= atomically . writeTBQueue (inputQ ct)
+basicReceiveFromTTY :: ChatTerminal -> IO ()
+basicReceiveFromTTY ct =
+  forever $ getLn >>= atomically . writeTBQueue (inputQ ct)
 
-withTermLock :: ChatTerminal -> IO () -> IO ()
+basicSendToTTY :: ChatTerminal -> IO ()
+basicSendToTTY ct = forever $ readOutputQ ct >>= mapM_ putStyledLn
+
+withTermLock :: MonadTerminal m => ChatTerminal -> m () -> m ()
 withTermLock ChatTerminal {termLock} action = do
   _ <- atomically $ takeTMVar termLock
   action
   atomically $ putTMVar termLock ()
 
-receiveFromTTY' :: ChatTerminal -> IO ()
-receiveFromTTY' ct@ChatTerminal {inputQ, activeContact, termSize, termState} =
-  forever $
+receiveFromTTY :: ChatTerminal -> IO ()
+receiveFromTTY ct@ChatTerminal {inputQ, activeContact, termSize, termState} =
+  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 msg = encodeUtf8 . T.pack $ inputString ts
-        writeTBQueue inputQ msg
-        return 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
-      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 <> "> "
+        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 $ readOutputQ ct >>= putLn stdout
-
-sendToTTY' :: ChatTerminal -> IO ()
-sendToTTY' ct = forever $ do
+sendToTTY ct = forever $ do
+  -- `readOutputQ` should be outside of `withTerminal` (see #94)
   msg <- readOutputQ ct
-  withTermLock ct $ do
+  withTerminal . runTerminalT . withTermLock ct $ do
     printMessage ct msg
     updateInput ct
 
-readOutputQ :: ChatTerminal -> IO ByteString
+readOutputQ :: ChatTerminal -> IO [StyledString]
 readOutputQ = atomically . readTBQueue . outputQ
-
-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)
-
-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])

ChatTerminal/Basic.hs

@@ -0,0 +1,89 @@
+{-# LANGUAGE LambdaCase #-}
+
+module ChatTerminal.Basic 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
+
+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
+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
+
+getKey :: MonadTerminal m => m (Key, Modifiers)
+getKey =
+  flush >> awaitEvent >>= \case
+    Left Interrupt -> liftIO exitSuccess
+    Right (KeyEvent key ms) -> pure (key, ms)
+    _ -> getKey
+
+getTermLine :: MonadTerminal m => m String
+getTermLine = getChars ""
+  where
+    getChars s =
+      getKey >>= \(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

ChatTerminal/Core.hs

@@ -0,0 +1,139 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+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 Data.Text.Encoding
+import Styled
+import System.Console.ANSI.Types
+import System.Terminal hiding (insertChars)
+import Types
+
+data ChatTerminal = ChatTerminal
+  { inputQ :: TBQueue String,
+    outputQ :: TBQueue [StyledString],
+    activeContact :: TVar (Maybe Contact),
+    termMode :: TermMode,
+    termState :: TVar TerminalState,
+    termSize :: Size,
+    nextMessageRow :: TVar Int,
+    termLock :: TMVar ()
+  }
+
+data TerminalState = TerminalState
+  { inputPrompt :: String,
+    inputString :: String,
+    inputPosition :: Int,
+    previousInput :: String
+  }
+
+inputHeight :: TerminalState -> ChatTerminal -> Int
+inputHeight ts ct = length (inputPrompt ts <> inputString ts) `div` width (termSize ct) + 1
+
+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
+  DeleteKey -> deleteChar
+  HomeKey -> setPosition 0
+  EndKey -> setPosition $ length s
+  ArrowKey d -> case d of
+    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 if p' > 0 then setPosition p' else ts
+      | otherwise -> ts
+    Downwards
+      | ms == mempty -> let p' = p + tw in if p' <= length s then setPosition p' else ts
+      | otherwise -> ts
+  _ -> 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' (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)
+    leftPos
+      | 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)
+      | ms == shiftKey = length s
+      | ms == ctrlKey = nextWordPos
+      | ms == altKey = nextWordPos
+      | otherwise = p
+    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 = styleMarkdownText . T.pack
+
+safeDecodeUtf8 :: ByteString -> Text
+safeDecodeUtf8 = decodeUtf8With onError
+  where
+    onError _ _ = Just '?'
+
+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]

ChatTerminal/Editor.hs

@@ -0,0 +1,61 @@
+{-# 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 :: 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}
+  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

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
@@ -20,17 +21,21 @@ 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
+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.Parsers (parseAll)
-import Simplex.Messaging.Util (bshow, raceAny_)
+import Simplex.Messaging.Util (raceAny_)
+import Styled
+import System.Console.ANSI.Types
 import System.Directory (getAppUserDataDirectory)
-import System.Exit (exitFailure)
-import System.Info (os)
 import Types
 
 cfg :: AgentConfig
@@ -50,39 +55,38 @@ 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
 -- | AddToGroup Contact
 data ChatCommand
   = ChatHelp
-  | AddContact Contact
-  | AcceptContact Contact SMPQueueInfo
-  | ChatWith Contact
-  | SetName Contact
+  | MarkdownHelp
+  | AddConnection Contact
+  | Connect Contact SMPQueueInfo
+  | DeleteConnection Contact
   | SendMessage Contact ByteString
 
 chatCommandP :: Parser ChatCommand
 chatCommandP =
-  "/help" $> ChatHelp
-    <|> "/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)
     <|> "@" *> 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 (== ' ')
 
 data ChatResponse
   = ChatHelpInfo
+  | MarkdownInfo
   | Invitation SMPQueueInfo
   | Connected Contact
+  | Confirmation Contact
   | ReceivedMessage Contact ByteString
   | Disconnected Contact
   | YesYes
@@ -90,40 +94,77 @@ data ChatResponse
   | ChatError AgentErrorType
   | NoChatResponse
 
-serializeChatResponse :: Maybe Contact -> ChatResponse -> ByteString
-serializeChatResponse name = \case
+serializeChatResponse :: ChatResponse -> [StyledString]
+serializeChatResponse = \case
   ChatHelpInfo -> chatHelpInfo
-  Invitation qInfo -> "ask your contact to enter: /accept " <> showName name <> " " <> serializeSmpQueueInfo qInfo
-  Connected c -> ttyContact c <> " connected"
-  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
-  ChatError e -> "chat error: " <> bshow e
-  NoChatResponse -> ""
+  MarkdownInfo -> markdownInfo
+  Invitation qInfo ->
+    [ "pass this invitation to your contact (via any channel): ",
+      "",
+      (bPlain . serializeSmpQueueInfo) qInfo,
+      "",
+      "and ask them to connect: /c <name_for_you> <invitation_above>"
+    ]
+  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!"]
+  ErrorInput t -> ["invalid input: " <> bPlain t]
+  ChatError e -> ["chat error: " <> plain (show e)]
+  NoChatResponse -> [""]
   where
-    showName Nothing = "<your name>"
-    showName (Just (Contact a)) = a
+    prependFirst :: StyledString -> [StyledString] -> [StyledString]
+    prependFirst s [] = [s]
+    prependFirst s (s' : ss) = (s <> s') : ss
+    msgPlain :: ByteString -> [StyledString]
+    msgPlain = map styleMarkdownText . T.lines . safeDecodeUtf8
 
-chatHelpInfo :: ByteString
+chatHelpInfo :: [StyledString]
 chatHelpInfo =
-  "Using chat:\n\
-  \/add <name>       - create invitation to send out-of-band\n\
-  \                    to your contact <name>\n\
-  \                    (any unique string without spaces)\n\
-  \/accept <name> <invitation> - accept <invitation>\n\
-  \                    (a string that starts from \"smp::\")\n\
-  \                    from your contact <name>\n\
-  \/name <name>      - set <name> to use in invitations\n\
-  \@<name> <message> - send <message> (any string) to contact <name>\n\
-  \                    @<name> can be omitted to send to previous"
+  map
+    styleMarkdown
+    [ "Using chat:",
+      highlight "/add <name>" <> "       - create invitation to send out-of-band to your contact <name>",
+      "                    (<name> is the alias you choose to message your contact)",
+      highlight "/connect <name> <invitation>" <> " - connect using <invitation>",
+      "                    (a string returned by /add that starts from \"smp::\")",
+      "                    if /connect is used by your contact,",
+      "                    <name> is the alias your contact chooses to message you",
+      highlight "@<name> <message>" <> " - send <message> (any string) to contact <name>",
+      "                    @<name> 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"]
+    ]
+  where
+    listCommands = mconcat . intersperse ", " . map highlight
+    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",
+      "  !1 text!        - " <> red "red text" <> " (1-6: red, green, blue, yellow, cyan, magenta)",
+      "  #secret#        - " <> Markdown Secret "secret text" <> " (can be copy-pasted)"
+    ]
+  where
+    red = Markdown (Colored Red)
 
 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 $ do
   env <- newSMPAgentEnv cfg {dbFile = dbFileName}
@@ -132,22 +173,12 @@ main = do
 welcomeGetOpts :: IO ChatOpts
 welcomeGetOpts = do
   appDir <- getAppUserDataDirectory "simplex"
-  opts@ChatOpts {dbFileName, termMode} <- getChatOpts appDir
-  putStrLn "simpleX chat prototype"
+  opts@ChatOpts {dbFileName} <- getChatOpts appDir
+  putStrLn "SimpleX chat prototype"
   putStrLn $ "db: " <> dbFileName
-  when (os == "mingw32") $ windowsWarning termMode
-  putStrLn "type \"/help\" for usage information"
+  putStrLn "type \"/help\" or \"/h\" for usage info"
   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
@@ -160,38 +191,32 @@ 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
   atomically (readTBQueue $ inputQ ct)
-    >>= processOrError . parseAll chatCommandP
+    >>= processOrError . parseAll chatCommandP . encodeUtf8 . T.pack
   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
-        let user = Just a
-        writeTVar (username (t :: ChatClient)) user
-        updateUsername ct user
-        writeTBQueue (outQ t) YesYes
+      Left err -> writeOutQ . ErrorInput $ B.pack err
+      Right ChatHelp -> writeOutQ ChatHelpInfo
+      Right MarkdownHelp -> writeOutQ MarkdownInfo
       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
@@ -202,19 +227,18 @@ 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
       SendMessage a msg -> transmission a $ SEND msg
       ChatHelp -> Nothing
-      SetName _ -> Nothing
+      MarkdownHelp -> Nothing
     transmission :: Contact -> ACommand 'Client -> Maybe (ATransmission 'Client)
     transmission (Contact a) cmd = Just ("1", a, cmd)
 
@@ -227,17 +251,25 @@ 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 -> 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'

Styled.hs

@@ -0,0 +1,60 @@
+module Styled
+  ( StyledString (..),
+    bPlain,
+    plain,
+    styleMarkdown,
+    styleMarkdownText,
+    sLength,
+  )
+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.Types
+
+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
+
+styleMarkdownText :: Text -> StyledString
+styleMarkdownText = styleMarkdown . parseMarkdown
+
+styleMarkdown :: Markdown -> StyledString
+styleMarkdown (s1 :|: s2) = styleMarkdown s1 <> styleMarkdown s2
+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]
+      Italic -> [SetUnderlining SingleUnderline, SetItalicized True]
+      Underline -> [SetUnderlining SingleUnderline]
+      StrikeThrough -> [SetSwapForegroundBackground True]
+      Colored c -> [SetColor Foreground Vivid c]
+      Secret -> [SetColor Foreground Dull Black, SetColor Background Dull Black]
+      Snippet -> []
+      NoFormat -> []
+
+sLength :: StyledString -> Int
+sLength (Styled _ s) = length s
+sLength (s1 :<>: s2) = sLength s1 + sLength s2

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)