new chat UX: removed /name, add /delete and /reset, change /accept to /connect, allow command abbreviations (#95)

* remove current user name

* rename /accept to /connect, remove /chat, add /reset, allow 1-letter abbreviations

* update help

* /delete contact, separate response for confirmation

* update invatation instruction

* unset active contact only if it is the same as current

ChatOptions.hs

@@ -8,12 +8,10 @@ import qualified Data.ByteString.Char8 as B
 import Options.Applicative
 import Simplex.Messaging.Agent.Transmission (SMPServer (..), smpServerP)
 import System.FilePath (combine)
-import System.Info (os)
 import Types
 
 data ChatOpts = ChatOpts
-  { name :: Maybe ByteString,
-    dbFileName :: String,
+  { dbFileName :: String,
     smpServer :: SMPServer,
     termMode :: TermMode
   }
@@ -21,15 +19,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"
@@ -49,14 +39,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 $ A.parseOnly (smpServerP <* A.endOfInput) . B.pack

ChatTerminal.hs

@@ -7,54 +7,51 @@ module ChatTerminal
   ( ChatTerminal (..),
     newChatTerminal,
     chatTerminal,
-    updateUsername,
     ttyContact,
     ttyFromContact,
   )
 where
 
-import ChatTerminal.Basic (getLn, putLn)
+import ChatTerminal.Basic
 import ChatTerminal.Core
-import ChatTerminal.POSIX
+import ChatTerminal.Editor
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.Async (race_)
-import Control.Concurrent.STM
 import Control.Monad
-import Data.Maybe (fromMaybe)
 import Numeric.Natural
 import Styled
-import qualified System.Console.ANSI as C
+import System.Terminal
 import Types
+import UnliftIO.STM
 
-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 =
+  | termSize ct == Size 0 0 || termMode ct == TermModeBasic =
     run basicReceiveFromTTY basicSendToTTY
   | otherwise = do
-    initTTY
-    updateInput ct
+    withTerminal . runTerminalT $ updateInput ct
     run receiveFromTTY sendToTTY
   where
     run receive send = race_ (receive ct) (send ct)
@@ -64,9 +61,9 @@ basicReceiveFromTTY ct =
   forever $ getLn >>= atomically . writeTBQueue (inputQ ct)
 
 basicSendToTTY :: ChatTerminal -> IO ()
-basicSendToTTY ct = forever $ readOutputQ ct >>= putLn
+basicSendToTTY ct = forever $ readOutputQ ct >>= mapM_ putStyledLn
 
-withTermLock :: ChatTerminal -> IO () -> IO ()
+withTermLock :: MonadTerminal m => ChatTerminal -> m () -> m ()
 withTermLock ChatTerminal {termLock} action = do
   _ <- atomically $ takeTMVar termLock
   action
@@ -74,32 +71,33 @@ withTermLock ChatTerminal {termLock} action = do
 
 receiveFromTTY :: ChatTerminal -> IO ()
 receiveFromTTY ct@ChatTerminal {inputQ, activeContact, termSize, termState} =
-  forever $
+  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 s = inputString ts
+        writeTVar termState $ ts {inputString = "", inputPosition = 0, previousInput = s}
         writeTBQueue inputQ s
         return s
-      withTermLock ct . printMessage ct $ styleMessage msg
+      withTermLock ct $ printMessage ct [styleMessage msg]
 
 sendToTTY :: ChatTerminal -> IO ()
 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 StyledString
+readOutputQ :: ChatTerminal -> IO [StyledString]
 readOutputQ = atomically . readTBQueue . outputQ

ChatTerminal/Basic.hs

@@ -11,11 +11,15 @@ import System.Terminal as C
 getLn :: IO String
 getLn = withTerminal $ runTerminalT getTermLine
 
-putLn :: StyledString -> IO ()
-putLn s =
+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
@@ -55,12 +59,18 @@ setSGR = mapM_ $ \case
       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 = awaitEvent >>= processKey s
-    processKey s = \case
-      Right (KeyEvent key ms) -> case key of
+    getChars s =
+      getKey >>= \(key, ms) -> case key of
         CharKey c
           | ms == mempty || ms == shiftKey -> do
             C.putChar c
@@ -77,5 +87,3 @@ getTermLine = getChars ""
           flush
           getChars $ if null s then s else tail s
         _ -> getChars s
-      Left Interrupt -> liftIO exitSuccess
-      _ -> getChars s

ChatTerminal/Core.hs

@@ -1,25 +1,28 @@
 {-# 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 SimplexMarkdown
+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,
+    outputQ :: TBQueue [StyledString],
     activeContact :: TVar (Maybe Contact),
-    username :: TVar (Maybe Contact),
     termMode :: TermMode,
     termState :: TVar TerminalState,
-    termSize :: (Int, Int),
+    termSize :: Size,
     nextMessageRow :: TVar Int,
     termLock :: TMVar ()
   }
@@ -27,46 +30,41 @@ data ChatTerminal = ChatTerminal
 data TerminalState = TerminalState
   { inputPrompt :: String,
     inputString :: String,
-    inputPosition :: Int
+    inputPosition :: Int,
+    previousInput :: String
   }
 
-data Key
-  = KeyLeft
-  | KeyRight
-  | KeyUp
-  | KeyDown
-  | KeyAltLeft
-  | KeyAltRight
-  | KeyCtrlLeft
-  | KeyCtrlRight
-  | KeyShiftLeft
-  | KeyShiftRight
-  | KeyEnter
-  | KeyBack
-  | KeyTab
-  | KeyEsc
-  | KeyChars String
-  | KeyUnsupported
-  deriving (Eq)
-
 inputHeight :: TerminalState -> ChatTerminal -> Int
-inputHeight ts ct = length (inputPrompt ts <> inputString ts) `div` snd (termSize ct) + 1
+inputHeight ts ct = length (inputPrompt ts <> inputString ts) `div` width (termSize ct) + 1
 
-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
+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
@@ -81,10 +79,24 @@ updateTermState ac tw key ts@TerminalState {inputString = s, inputPosition = p}
       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)
+      | 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
@@ -107,21 +119,18 @@ styleMessage = \case
   s -> markdown s
   where
     markdown :: String -> StyledString
-    markdown = styleMarkdown . parseMarkdown . T.pack
+    markdown = styleMarkdownText . T.pack
 
-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 <> "> "
+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 <> ">"
+ttyFromContact (Contact a) = Styled contactSGR $ B.unpack a <> "> "
 
 contactSGR :: [SGR]
 contactSGR = [SetColor Foreground Vivid Yellow]

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

ChatTerminal/POSIX.hs

@@ -1,102 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-
-module ChatTerminal.POSIX where
-
-import ChatTerminal.Core
-import Control.Concurrent.STM
-import Styled
-import qualified System.Console.ANSI as C
-import System.IO
-
-initTTY :: IO ()
-initTTY = do
-  hSetEcho stdin False
-  hSetBuffering stdin NoBuffering
-  hSetBuffering stdout NoBuffering
-
-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)
-
-printMessage :: ChatTerminal -> StyledString -> 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 -> 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 + (length l `div` tw) + 1) 0 ls
-
-    print_ :: [String] -> IO ()
-    print_ [] = return ()
-    print_ (l : ls) = do
-      putStr l
-      C.clearFromCursorToLineEnd
-      putStr "\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)

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,20 +21,20 @@ 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.Util (raceAny_)
-import SimplexMarkdown
 import Styled
+import System.Console.ANSI.Types
 import System.Directory (getAppUserDataDirectory)
-import System.Exit (exitFailure)
-import System.Info (os)
 import Types
 
 cfg :: AgentConfig
@@ -53,39 +54,40 @@ 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
+  | ResetChat
   | 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)
+    <|> ("/reset" <> "/r") $> ResetChat
     <|> "@" *> 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
@@ -93,42 +95,79 @@ data ChatResponse
   | ChatError AgentErrorType
   | NoChatResponse
 
-serializeChatResponse :: Maybe Contact -> ChatResponse -> StyledString
-serializeChatResponse name = \case
+serializeChatResponse :: ChatResponse -> [StyledString]
+serializeChatResponse = \case
   ChatHelpInfo -> chatHelpInfo
-  Invitation qInfo -> "ask your contact to enter: /accept " <> showName name <> " " <> (bPlain . serializeSmpQueueInfo) qInfo
-  Connected c -> ttyContact c <> " connected"
-  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: " <> bPlain t
-  ChatError e -> "chat error: " <> plain (show 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)) = bPlain a
-    msgPlain = styleMarkdown . parseMarkdown . decodeUtf8With onError
-    onError _ _ = Just '?'
+    prependFirst :: StyledString -> [StyledString] -> [StyledString]
+    prependFirst s [] = [s]
+    prependFirst s (s' : ss) = (s <> s') : ss
+    msgPlain :: ByteString -> [StyledString]
+    msgPlain = map styleMarkdownText . T.lines . safeDecodeUtf8
 
-chatHelpInfo :: StyledString
+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 "/reset" <> "            - reset chat and all connections",
+      highlight "/markdown" <> "         - markdown cheat-sheet",
+      "",
+      "Commands can be abbreviated to 1 letter: ",
+      listCommands ["/h", "/a", "/c", "/d", "/r", "/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",
+      "  !r text!        - " <> red "red text" <> " (red, green, blue, yellow, cyan, magenta)",
+      "  !1 text!        - " <> red "also red text" <> " (1-6)",
+      "  #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 $
   env <- newSMPAgentEnv cfg {dbFile = dbFileName}
@@ -137,22 +176,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
@@ -165,15 +194,14 @@ 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
@@ -181,22 +209,17 @@ receiveFromChatTerm t ct = forever $ do
     >>= processOrError . A.parseOnly (chatCommandP <* A.endOfInput) . 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
@@ -207,19 +230,19 @@ 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
+      ResetChat -> transmission (Contact "") SUBALL
       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)
 
@@ -236,15 +259,21 @@ receiveFromAgent t ct c = forever . atomically $ do
       END -> Disconnected contact
       MSG {m_body} -> ReceivedMessage contact m_body
       SENT _ -> NoChatResponse
-      OK -> Connected contact -- 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'

SimplexMarkdown.hs

@@ -1,122 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module SimplexMarkdown where
-
-import Control.Applicative ((<|>))
-import Data.Attoparsec.Text (Parser)
-import qualified Data.Attoparsec.Text as A
-import Data.Either (fromRight)
-import Data.Functor (($>))
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
-import Data.String
-import Data.Text (Text)
-import qualified Data.Text as T
-import Styled
-import System.Console.ANSI.Types
-
-data Markdown = Markdown Format Text | Markdown :|: Markdown
-  deriving (Show)
-
-data Format
-  = Bold
-  | Italic
-  | Underline
-  | StrikeThrough
-  | Colored Color
-  | NoFormat
-  deriving (Show)
-
-instance Semigroup Markdown where (<>) = (:|:)
-
-instance Monoid Markdown where mempty = unmarked ""
-
-instance IsString Markdown where fromString = unmarked . T.pack
-
-unmarked :: Text -> Markdown
-unmarked = Markdown NoFormat
-
-styleMarkdown :: Markdown -> StyledString
-styleMarkdown (s1 :|: s2) = styleMarkdown s1 <> styleMarkdown s2
-styleMarkdown (Markdown f s) = Styled sgr $ T.unpack s
-  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]
-      NoFormat -> []
-
-formats :: Map Char Format
-formats =
-  M.fromList
-    [ ('*', Bold),
-      ('_', Italic),
-      ('+', Underline),
-      ('~', StrikeThrough),
-      ('^', Colored White)
-    ]
-
-colors :: Map Text Color
-colors =
-  M.fromList
-    [ ("red", Red),
-      ("green", Green),
-      ("blue", Blue),
-      ("yellow", Yellow),
-      ("cyan", Cyan),
-      ("magenta", Magenta),
-      ("r", Red),
-      ("g", Green),
-      ("b", Blue),
-      ("y", Yellow),
-      ("c", Cyan),
-      ("m", Magenta)
-    ]
-
-parseMarkdown :: Text -> Markdown
-parseMarkdown s = fromRight (unmarked s) $ A.parseOnly (markdownP <* A.endOfInput) s
-
-markdownP :: Parser Markdown
-markdownP = merge <$> A.many' fragmentP
-  where
-    merge :: [Markdown] -> Markdown
-    merge [] = ""
-    merge [f] = f
-    merge (f : fs) = foldl (:|:) f fs
-    fragmentP :: Parser Markdown
-    fragmentP =
-      A.anyChar >>= \case
-        ' ' -> unmarked . (" " <>) <$> A.takeWhile (== ' ')
-        c -> case M.lookup c formats of
-          Just (Colored White) -> coloredP
-          Just f -> formattedP c "" f
-          Nothing -> unformattedP c
-    formattedP :: Char -> Text -> Format -> Parser Markdown
-    formattedP c p f = do
-      s <- A.takeTill (== c)
-      (A.char c $> Markdown f s) <|> noFormat (T.singleton c <> p <> s)
-    coloredP :: Parser Markdown
-    coloredP = do
-      color <- A.takeWhile (\c -> c /= ' ' && c /= '^')
-      case M.lookup color colors of
-        Just c ->
-          let f = Colored c
-           in (A.char ' ' *> formattedP '^' (color <> " ") f)
-                <|> (A.char '^' $> Markdown f color)
-                <|> noFormat ("^" <> color)
-        _ -> noFormat ("^" <> color)
-    unformattedP :: Char -> Parser Markdown
-    unformattedP c = unmarked . (T.singleton c <>) <$> wordsP
-    wordsP :: Parser Text
-    wordsP = do
-      s <- (<>) <$> A.takeTill (== ' ') <*> A.takeWhile (== ' ')
-      A.peekChar >>= \case
-        Nothing -> pure s
-        Just c -> case M.lookup c formats of
-          Just _ -> pure s
-          Nothing -> (s <>) <$> wordsP
-    noFormat :: Text -> Parser Markdown
-    noFormat = pure . unmarked

Styled.hs

@@ -1,9 +1,20 @@
-module Styled (StyledString (..), plain, bPlain, styledToANSITerm, styledToPlain) where
+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 System.Console.ANSI (SGR (..), setSGRCode)
+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
 
@@ -19,11 +30,31 @@ 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
+styleMarkdownText :: Text -> StyledString
+styleMarkdownText = styleMarkdown . parseMarkdown
 
-styledToPlain :: StyledString -> String
-styledToPlain (Styled _ s) = s
-styledToPlain (s1 :<>: s2) = styledToPlain s1 <> styledToPlain s2
+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)