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

.well-known/README.md

@@ -1,17 +0,0 @@
-# .well-known
-
-This website files allow opening SimpleX Chat links (1-time invitations, contact addresses and groups) directly in the app.
-
-## Android
-
-File `assetlinks.json` includes certificate hashes for:
-
-- Play Store (5E:3E:DC:C2:00:FB:A8:D5:F4:88:F3:CA:4C:32:5B:05:78:C5:6A:9C:03:A1:CC:B5:92:9C:D7:5C:7E:57:E2:4D)
-- APK in GitHub releases (3C:52:C4:FD:3C:AD:1C:07:C9:B0:0A:70:80:E3:58:FA:B9:FE:FC:B8:AF:5A:EC:14:77:65:F1:6D:0F:21:AD:85)
-- F-Droid (AE:C1:95:DC:FD:46:14:BD:3A:91:EC:26:D1:D5:14:C8:75:71:C5:CC:8D:CF:48:08:3F:92:83:14:3C:A2:B9:A6)
-
-## iOS
-
-`apple-app-site-association` needs to be served with `Content-type: application/json; charset=utf-8` and GitHub pages do not support adding this header to files without JSON extension.
-
-To workaround this (thanks to [StackOverflow - Serve json data from github pages](https://stackoverflow.com/questions/39199042/serve-json-data-from-github-pages)) we're creating directory named `apple-app-site-association` with `index.json` file that contains all the necessary configs.

.well-known/README/index.html

@@ -1,12 +0,0 @@
-<h1 id="well-known" tabindex="-1">.well-known</h1>
-<p>This website files allow opening SimpleX Chat links (1-time invitations, contact addresses and groups) directly in the app.</p>
-<h2 id="android" tabindex="-1">Android</h2>
-<p>File <code>assetlinks.json</code> includes certificate hashes for:</p>
-<ul>
-<li>Play Store (5E:3E:DC:C2:00:FB:A8:D5:F4:88:F3:CA:4C:32:5B:05:78:C5:6A:9C:03:A1:CC:B5:92:9C:D7:5C:7E:57:E2:4D)</li>
-<li>APK in GitHub releases (3C:52:C4:FD:3C:AD:1C:07:C9:B0:0A:70:80:E3:58:FA:B9:FE:FC:B8:AF:5A:EC:14:77:65:F1:6D:0F:21:AD:85)</li>
-<li>F-Droid (AE:C1:95:DC:FD:46:14:BD:3A:91:EC:26:D1:D5:14:C8:75:71:C5:CC:8D:CF:48:08:3F:92:83:14:3C:A2:B9:A6)</li>
-</ul>
-<h2 id="ios" tabindex="-1">iOS</h2>
-<p><code>apple-app-site-association</code> needs to be served with <code>Content-type: application/json; charset=utf-8</code> and GitHub pages do not support adding this header to files without JSON extension.</p>
-<p>To workaround this (thanks to <a href="https://stackoverflow.com/questions/39199042/serve-json-data-from-github-pages">StackOverflow - Serve json data from github pages</a>) we're creating directory named <code>apple-app-site-association</code> with <code>index.json</code> file that contains all the necessary configs.</p>

.well-known/apple-app-site-association/index.json

@@ -1,25 +0,0 @@
-{
-  "applinks": {
-    "details": [
-      {
-        "appIDs": [
-          "5NN7GUYB6T.chat.simplex.app"
-        ],
-        "components": [
-          {
-            "/": "/contact/*"
-          },
-          {
-            "/": "/contact"
-          },
-          {
-            "/": "/invitation/*"
-          },
-          {
-            "/": "/invitation"
-          }
-        ]
-      }
-    ]
-  }
-}

.well-known/assetlinks.json

@@ -1,16 +0,0 @@
-[
-    {
-        "relation": [
-            "delegate_permission/common.handle_all_urls"
-        ],
-        "target": {
-            "namespace": "android_app",
-            "package_name": "chat.simplex.app",
-            "sha256_cert_fingerprints": [
-                "5E:3E:DC:C2:00:FB:A8:D5:F4:88:F3:CA:4C:32:5B:05:78:C5:6A:9C:03:A1:CC:B5:92:9C:D7:5C:7E:57:E2:4D",
-                "3C:52:C4:FD:3C:AD:1C:07:C9:B0:0A:70:80:E3:58:FA:B9:FE:FC:B8:AF:5A:EC:14:77:65:F1:6D:0F:21:AD:85",
-                "AE:C1:95:DC:FD:46:14:BD:3A:91:EC:26:D1:D5:14:C8:75:71:C5:CC:8D:CF:48:08:3F:92:83:14:3C:A2:B9:A6"
-            ]
-        }
-    }
-]

.well-known/nostr.json

@@ -1,18 +0,0 @@
-{
-  "names": {
-    "_": "c998a5739f04f7fff202c54962aa5782b34ecb10d6f915bdfdd7582963bf9171"
-  },
-  "relays": {
-    "c998a5739f04f7fff202c54962aa5782b34ecb10d6f915bdfdd7582963bf9171": [
-      "wss://nostr.orangepill.dev",
-      "wss://eden.nostr.land",
-      "wss://relay.damus.io",
-      "wss://relay.snort.social",
-      "wss://relay.current.fyi",
-      "wss://nos.lol",
-      "wss://relay.nostr.bg",
-      "wss://nostr-verified.wellorder.net",
-      "wss://nostr.milou.lol"
-    ]
-  }
-}

.well-known/org.flathub.VerifiedApps.txt

@@ -1 +0,0 @@
-ae8b5b2e-76c9-4a31-a044-bcbda1cdf264

CNAME

@@ -1 +0,0 @@
-simplex.chat

ChatOptions.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE LambdaCase #-}
+
+module ChatOptions (getChatOpts, ChatOpts (..)) where
+
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Options.Applicative
+import Simplex.Messaging.Agent.Transmission (SMPServer (..), smpServerP)
+import System.FilePath (combine)
+import Types
+
+data ChatOpts = ChatOpts
+  { dbFileName :: String,
+    smpServer :: SMPServer,
+    termMode :: TermMode
+  }
+
+chatOpts :: FilePath -> Parser ChatOpts
+chatOpts appDir =
+  ChatOpts
+    <$> strOption
+      ( long "database"
+          <> short 'd'
+          <> metavar "DB_FILE"
+          <> help ("sqlite database file path (" <> defaultDbFilePath <> ")")
+          <> value defaultDbFilePath
+      )
+    <*> option
+      parseSMPServer
+      ( long "server"
+          <> short 's'
+          <> metavar "SERVER"
+          <> help "SMP server to use (smp.simplex.im:5223)"
+          <> value (SMPServer "smp.simplex.im" (Just "5223") Nothing)
+      )
+    <*> option
+      parseTermMode
+      ( long "term"
+          <> short 't'
+          <> metavar "TERM"
+          <> help ("terminal mode: editor or basic (" <> termModeName TermModeEditor <> ")")
+          <> value TermModeEditor
+      )
+  where
+    defaultDbFilePath = combine appDir "smp-chat.db"
+
+parseSMPServer :: ReadM SMPServer
+parseSMPServer = eitherReader $ A.parseOnly (smpServerP <* A.endOfInput) . B.pack
+
+parseTermMode :: ReadM TermMode
+parseTermMode = maybeReader $ \case
+  "basic" -> Just TermModeBasic
+  "editor" -> Just TermModeEditor
+  _ -> Nothing
+
+getChatOpts :: FilePath -> IO ChatOpts
+getChatOpts appDir = execParser opts
+  where
+    opts =
+      info
+        (chatOpts appDir <**> helper)
+        ( fullDesc
+            <> header "Chat prototype using Simplex Messaging Protocol (SMP)"
+            <> progDesc "Start chat with DB_FILE file and use SERVER as SMP server"
+        )

ChatTerminal.hs

@@ -0,0 +1,103 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChatTerminal
+  ( ChatTerminal (..),
+    newChatTerminal,
+    chatTerminal,
+    ttyContact,
+    ttyFromContact,
+  )
+where
+
+import ChatTerminal.Basic
+import ChatTerminal.Core
+import ChatTerminal.Editor
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (race_)
+import Control.Monad
+import Numeric.Natural
+import Styled
+import System.Terminal
+import Types
+import UnliftIO.STM
+
+newChatTerminal :: Natural -> TermMode -> IO ChatTerminal
+newChatTerminal qSize termMode = do
+  inputQ <- newTBQueueIO qSize
+  outputQ <- newTBQueueIO qSize
+  activeContact <- newTVarIO Nothing
+  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, termMode, termState, termSize, nextMessageRow, termLock}
+
+newTermState :: TerminalState
+newTermState =
+  TerminalState
+    { inputString = "",
+      inputPosition = 0,
+      inputPrompt = "> ",
+      previousInput = ""
+    }
+
+chatTerminal :: ChatTerminal -> IO ()
+chatTerminal ct
+  | termSize ct == Size 0 0 || termMode ct == TermModeBasic =
+    run basicReceiveFromTTY basicSendToTTY
+  | otherwise = do
+    withTerminal . runTerminalT $ updateInput ct
+    run receiveFromTTY sendToTTY
+  where
+    run receive send = race_ (receive ct) (send ct)
+
+basicReceiveFromTTY :: ChatTerminal -> IO ()
+basicReceiveFromTTY ct =
+  forever $ getLn >>= atomically . writeTBQueue (inputQ ct)
+
+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} =
+  withTerminal . runTerminalT . forever $
+    getKey >>= processKey >> withTermLock ct (updateInput ct)
+  where
+    processKey :: MonadTerminal m => (Key, Modifiers) -> m ()
+    processKey = \case
+      (EnterKey, _) -> submitInput
+      key -> atomically $ do
+        ac <- readTVar activeContact
+        modifyTVar termState $ updateTermState ac (width termSize) key
+
+    submitInput :: MonadTerminal m => m ()
+    submitInput = do
+      msg <- atomically $ do
+        ts <- readTVar termState
+        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 $ do
+  -- `readOutputQ` should be outside of `withTerminal` (see #94)
+  msg <- readOutputQ ct
+  withTerminal . runTerminalT . withTermLock ct $ do
+    printMessage ct msg
+    updateInput ct
+
+readOutputQ :: ChatTerminal -> IO [StyledString]
+readOutputQ = atomically . readTBQueue . outputQ

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

@@ -0,0 +1,279 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Main where
+
+import ChatOptions
+import ChatTerminal
+import ChatTerminal.Core
+import Control.Applicative ((<|>))
+import Control.Concurrent.STM
+import Control.Logger.Simple
+import Control.Monad.Reader
+import Data.Attoparsec.ByteString.Char8 (Parser)
+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 Styled
+import System.Console.ANSI.Types
+import System.Directory (getAppUserDataDirectory)
+import Types
+
+cfg :: AgentConfig
+cfg =
+  AgentConfig
+    { tcpPort = undefined, -- TODO maybe take it out of config
+      rsaKeySize = 2048 `div` 8,
+      connIdBytes = 12,
+      tbqSize = 16,
+      dbFile = "smp-chat.db",
+      smpCfg = smpDefaultConfig
+    }
+
+logCfg :: LogConfig
+logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
+
+data ChatClient = ChatClient
+  { inQ :: TBQueue ChatCommand,
+    outQ :: TBQueue ChatResponse,
+    smpServer :: SMPServer
+  }
+
+-- | GroupMessage ChatGroup ByteString
+-- | AddToGroup Contact
+data ChatCommand
+  = ChatHelp
+  | MarkdownHelp
+  | AddConnection Contact
+  | Connect Contact SMPQueueInfo
+  | DeleteConnection Contact
+  | ResetChat
+  | SendMessage Contact ByteString
+
+chatCommandP :: Parser ChatCommand
+chatCommandP =
+  ("/help" <|> "/h") $> ChatHelp
+    <|> ("/markdown" <|> "/m") $> MarkdownHelp
+    <|> ("/add " <|> "/a ") *> (AddConnection <$> contact)
+    <|> ("/connect " <> "/c ") *> connect
+    <|> ("/delete " <> "/d ") *> (DeleteConnection <$> contact)
+    <|> ("/reset" <> "/r") $> ResetChat
+    <|> "@" *> sendMessage
+  where
+    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
+  | ErrorInput ByteString
+  | ChatError AgentErrorType
+  | NoChatResponse
+
+serializeChatResponse :: ChatResponse -> [StyledString]
+serializeChatResponse = \case
+  ChatHelpInfo -> chatHelpInfo
+  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
+    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 =
+  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, termMode} <- welcomeGetOpts
+  t <- getChatClient smpServer
+  ct <- newChatTerminal (tbqSize cfg) termMode
+  -- setLogLevel LogInfo -- LogError
+  -- withGlobalLogging logCfg $
+  env <- newSMPAgentEnv cfg {dbFile = dbFileName}
+  dogFoodChat t ct env
+
+welcomeGetOpts :: IO ChatOpts
+welcomeGetOpts = do
+  appDir <- getAppUserDataDirectory "simplex"
+  opts@ChatOpts {dbFileName} <- getChatOpts appDir
+  putStrLn "SimpleX chat prototype"
+  putStrLn $ "db: " <> dbFileName
+  putStrLn "type \"/help\" or \"/h\" for usage info"
+  pure opts
+
+dogFoodChat :: ChatClient -> ChatTerminal -> Env -> IO ()
+dogFoodChat t ct env = do
+  c <- runReaderT getSMPAgentClient env
+  raceAny_
+    [ runReaderT (runSMPAgentClient c) env,
+      sendToAgent t ct c,
+      sendToChatTerm t ct,
+      receiveFromAgent t ct c,
+      receiveFromChatTerm t ct,
+      chatTerminal ct
+    ]
+
+getChatClient :: SMPServer -> IO ChatClient
+getChatClient srv = atomically $ newChatClient (tbqSize cfg) srv
+
+newChatClient :: Natural -> SMPServer -> STM ChatClient
+newChatClient qSize smpServer = do
+  inQ <- newTBQueue qSize
+  outQ <- newTBQueue qSize
+  return ChatClient {inQ, outQ, smpServer}
+
+receiveFromChatTerm :: ChatClient -> ChatTerminal -> IO ()
+receiveFromChatTerm t ct = forever $ do
+  atomically (readTBQueue $ inputQ ct)
+    >>= processOrError . A.parseOnly (chatCommandP <* A.endOfInput) . encodeUtf8 . T.pack
+  where
+    processOrError = \case
+      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} ChatTerminal {outputQ} = forever $ do
+  atomically (readTBQueue outQ) >>= \case
+    NoChatResponse -> return ()
+    resp -> atomically . writeTBQueue outputQ $ serializeChatResponse resp
+
+sendToAgent :: ChatClient -> ChatTerminal -> AgentClient -> IO ()
+sendToAgent ChatClient {inQ, smpServer} ct AgentClient {rcvQ} = do
+  atomically $ writeTBQueue rcvQ ("1", "", SUBALL) -- hack for subscribing to all
+  forever . atomically $ do
+    cmd <- readTBQueue inQ
+    writeTBQueue rcvQ `mapM_` agentTransmission cmd
+    setActiveContact cmd
+  where
+    setActiveContact :: ChatCommand -> STM ()
+    setActiveContact = \case
+      SendMessage a _ -> setActive ct a
+      DeleteConnection a -> unsetActive ct a
+      _ -> pure ()
+    agentTransmission :: ChatCommand -> Maybe (ATransmission 'Client)
+    agentTransmission = \case
+      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
+      MarkdownHelp -> Nothing
+    transmission :: Contact -> ACommand 'Client -> Maybe (ATransmission 'Client)
+    transmission (Contact a) cmd = Just ("1", a, cmd)
+
+receiveFromAgent :: ChatClient -> ChatTerminal -> AgentClient -> IO ()
+receiveFromAgent t ct c = forever . atomically $ do
+  resp <- chatResponse <$> readTBQueue (sndQ c)
+  writeTBQueue (outQ t) resp
+  setActiveContact resp
+  where
+    chatResponse :: ATransmission 'Agent -> ChatResponse
+    chatResponse (_, a, resp) = case resp of
+      INV qInfo -> Invitation qInfo
+      CON -> Connected contact
+      END -> Disconnected contact
+      MSG {m_body} -> ReceivedMessage contact m_body
+      SENT _ -> NoChatResponse
+      OK -> Confirmation contact
+      ERR e -> ChatError e
+      where
+        contact = Contact a
+    setActiveContact :: ChatResponse -> STM ()
+    setActiveContact = \case
+      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

@@ -0,0 +1,14 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Types where
+
+import Data.ByteString.Char8 (ByteString)
+
+newtype Contact = Contact {toBs :: ByteString} deriving (Eq)
+
+data TermMode = TermModeBasic | TermModeEditor deriving (Eq)
+
+termModeName :: TermMode -> String
+termModeName = \case
+  TermModeBasic -> "basic"
+  TermModeEditor -> "editor"