move files to src folder (to allow testing) (#70)

src/Simplex/Chat.hs

@@ -0,0 +1,278 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.Chat where
+
+import Control.Applicative ((<|>))
+import Control.Monad.Except
+import Control.Monad.IO.Unlift
+import Control.Monad.Reader
+import qualified Data.Aeson as J
+import Data.Attoparsec.ByteString.Char8 (Parser)
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Bifunctor (first)
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Functor (($>))
+import Data.List (find)
+import Data.Maybe (isJust)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Simplex.Chat.Controller
+import Simplex.Chat.Help
+import Simplex.Chat.Notification
+import Simplex.Chat.Protocol
+import Simplex.Chat.Store
+import Simplex.Chat.Styled (plain)
+import Simplex.Chat.Terminal
+import Simplex.Chat.Types
+import Simplex.Chat.View
+import Simplex.Messaging.Agent
+import Simplex.Messaging.Agent.Protocol
+import Simplex.Messaging.Parsers (parseAll)
+import Simplex.Messaging.Util (bshow, raceAny_)
+import System.Exit (exitFailure)
+import System.IO (hFlush, stdout)
+import Text.Read (readMaybe)
+import qualified UnliftIO.Exception as E
+import UnliftIO.STM
+
+data ChatCommand
+  = ChatHelp
+  | MarkdownHelp
+  | AddContact
+  | Connect SMPQueueInfo
+  | DeleteContact ContactRef
+  | SendMessage ContactRef ByteString
+  deriving (Show)
+
+runChatController :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
+runChatController =
+  raceAny_
+    [ inputSubscriber,
+      agentSubscriber,
+      chatSubscriber,
+      notificationSubscriber
+    ]
+
+inputSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
+inputSubscriber = do
+  q <- asks inputQ
+  forever $
+    atomically (readTBQueue q) >>= \case
+      InputControl _ -> pure ()
+      InputCommand s ->
+        case parseAll chatCommandP . encodeUtf8 $ T.pack s of
+          Left e -> printToView [plain s, "invalid input: " <> plain e]
+          Right cmd -> do
+            case cmd of
+              SendMessage c msg -> showSentMessage c msg
+              _ -> printToView [plain s]
+            user <- asks currentUser
+            runExceptT (processChatCommand user cmd) >>= \case
+              Left e -> showChatError e
+              _ -> pure ()
+
+processChatCommand :: ChatMonad m => User -> ChatCommand -> m ()
+processChatCommand User {userId, profile} = \case
+  ChatHelp -> printToView chatHelpInfo
+  MarkdownHelp -> printToView markdownInfo
+  AddContact -> do
+    (connId, qInfo) <- withAgent createConnection
+    withStore $ \st -> createDirectConnection st userId connId
+    showInvitation qInfo
+  Connect qInfo -> do
+    connId <- withAgent $ \agent -> joinConnection agent qInfo $ LB.toStrict (J.encode profile)
+    withStore $ \st -> createDirectConnection st userId connId
+  DeleteContact cRef -> do
+    conns <- withStore $ \st -> getContactConnections st userId cRef
+    withAgent $ \smp -> forM_ conns $ \Connection {agentConnId} ->
+      deleteConnection smp agentConnId `catchError` \(_ :: AgentErrorType) -> pure ()
+    withStore $ \st -> deleteContact st userId cRef
+    unsetActive $ ActiveC cRef
+    when (null conns) . throwError . ChatErrorContact $ CENotFound cRef
+    showContactDeleted cRef
+  SendMessage cRef msg -> do
+    Connection {agentConnId} <- withStore $ \st -> getContactConnection st userId cRef
+    let body = MsgBodyContent {contentType = SimplexContentType XCText, contentHash = Nothing, contentData = MBFull $ MsgData msg}
+        rawMsg = rawChatMessage ChatMessage {chatMsgId = Nothing, chatMsgEvent = XMsgNew MTText, chatMsgBody = [body], chatDAGIdx = Nothing}
+    void . withAgent $ \smp -> sendMessage smp agentConnId $ serializeRawChatMessage rawMsg
+    setActive $ ActiveC cRef
+
+agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
+agentSubscriber = do
+  aQ <- asks $ subQ . smpAgent
+  cQ <- asks chatQ
+  forever $ do
+    (_, agentConnId, resp) <- atomically (readTBQueue aQ)
+    User {userId} <- asks currentUser
+    runExceptT (withStore $ \st -> getConnectionChatDirection st userId agentConnId) >>= \case
+      -- TODO handle errors
+      Left e -> liftIO $ print e
+      Right chatDirection -> do
+        case resp of
+          MSG agentMsgMeta msgBody -> do
+            atomically . writeTBQueue cQ $
+              case first B.pack (parseAll rawChatMessageP msgBody) >>= toChatMessage of
+                Right chatMessage -> ChatTransmission {agentMsgMeta, chatDirection, chatMessage}
+                Left msgError -> ChatTransmissionError {agentMsgMeta, chatDirection, msgBody, msgError}
+          agentMessage ->
+            atomically $ writeTBQueue cQ AgentTransmission {agentConnId, chatDirection, agentMessage}
+
+chatSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
+chatSubscriber = do
+  cQ <- asks chatQ
+  forever $ do
+    User {userId, profile} <- asks currentUser
+    atomically (readTBQueue cQ) >>= \case
+      ChatTransmission
+        { agentMsgMeta = meta,
+          chatDirection = ReceivedDirectMessage Contact {localContactRef = c},
+          chatMessage = ChatMessage {chatMsgEvent, chatMsgBody}
+        } ->
+          case chatMsgEvent of
+            XMsgNew MTText -> do
+              case find (isSimplexContentType XCText) chatMsgBody of
+                Just MsgBodyContent {contentData = MBFull (MsgData bs)} -> do
+                  let text = safeDecodeUtf8 bs
+                  showReceivedMessage c (snd $ broker meta) text (integrity meta)
+                  showToast ("@" <> c) text
+                  setActive $ ActiveC c
+                _ -> pure ()
+            _ -> pure ()
+      AgentTransmission {agentConnId, chatDirection = ReceivedDirectMessage NewContact {activeConn}, agentMessage} ->
+        void . runExceptT $ case agentMessage of
+          CONF confId connInfo -> do
+            -- TODO update connection status
+            saveContact userId activeConn connInfo
+            withAgent $ \a -> allowConnection a agentConnId confId $ LB.toStrict (J.encode profile)
+          INFO connInfo ->
+            saveContact userId activeConn connInfo
+          _ -> pure ()
+      AgentTransmission {chatDirection = ReceivedDirectMessage Contact {localContactRef = c}, agentMessage} ->
+        case agentMessage of
+          CON -> do
+            -- TODO update connection status
+            showContactConnected c
+            showToast ("@" <> c) "connected"
+            setActive $ ActiveC c
+          END -> do
+            showContactDisconnected c
+            showToast ("@" <> c) "disconnected"
+            unsetActive $ ActiveC c
+          _ -> pure ()
+      _ -> pure ()
+  where
+    saveContact userId activeConn connInfo = do
+      p <- liftEither . first (ChatErrorContact . CEProfile) $ J.eitherDecodeStrict' connInfo
+      withStore $ \st -> createDirectContact st userId activeConn p
+
+getCreateActiveUser :: SQLiteStore -> IO User
+getCreateActiveUser st = do
+  user <-
+    getUsers st >>= \case
+      [] -> newUser
+      users -> maybe (selectUser users) pure (find activeUser users)
+  putStrLn $ "Current user: " <> userStr user
+  pure user
+  where
+    newUser :: IO User
+    newUser = do
+      putStrLn
+        "No user profiles found, it will be created now.\n\
+        \Please choose your alias and your profile name.\n\
+        \They will be sent to your contacts when you connect.\n\
+        \They are only stored on your device and you can change them later."
+      loop
+      where
+        loop = do
+          contactRef <- getContactRef
+          displayName <- T.pack <$> getWithPrompt "profile name (optional)"
+          liftIO (runExceptT $ createUser st Profile {contactRef, displayName} True) >>= \case
+            Left SEDuplicateContactRef -> do
+              putStrLn "chosen alias already used by another profile on this device, choose another one"
+              loop
+            Left e -> putStrLn ("database error " <> show e) >> exitFailure
+            Right user -> pure user
+    selectUser :: [User] -> IO User
+    selectUser [user] = do
+      liftIO $ setActiveUser st (userId user)
+      pure user
+    selectUser users = do
+      putStrLn "Select user profile:"
+      forM_ (zip [1 ..] users) $ \(n :: Int, user) -> putStrLn $ show n <> " - " <> userStr user
+      loop
+      where
+        loop = do
+          nStr <- getWithPrompt $ "user profile number (1 .. " <> show (length users) <> ")"
+          case readMaybe nStr :: Maybe Int of
+            Nothing -> putStrLn "invalid user number" >> loop
+            Just n
+              | n <= 0 || n > length users -> putStrLn "invalid user number" >> loop
+              | otherwise -> do
+                let user = users !! (n - 1)
+                liftIO $ setActiveUser st (userId user)
+                pure user
+    userStr :: User -> String
+    userStr User {localContactRef, profile = Profile {displayName}} =
+      T.unpack $ localContactRef <> if T.null displayName then "" else " (" <> displayName <> ")"
+    getContactRef :: IO ContactRef
+    getContactRef = do
+      contactRef <- getWithPrompt "alias (no spaces)"
+      if null contactRef || isJust (find (== ' ') contactRef)
+        then putStrLn "alias has space(s), choose another one" >> getContactRef
+        else pure $ T.pack contactRef
+    getWithPrompt :: String -> IO String
+    getWithPrompt s = putStr (s <> ": ") >> hFlush stdout >> getLine
+
+showToast :: (MonadUnliftIO m, MonadReader ChatController m) => Text -> Text -> m ()
+showToast title text = atomically . (`writeTBQueue` Notification {title, text}) =<< asks notifyQ
+
+notificationSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
+notificationSubscriber = do
+  ChatController {notifyQ, sendNotification} <- ask
+  forever $ atomically (readTBQueue notifyQ) >>= liftIO . sendNotification
+
+withAgent :: ChatMonad m => (AgentClient -> ExceptT AgentErrorType m a) -> m a
+withAgent action =
+  asks smpAgent
+    >>= runExceptT . action
+    >>= liftEither . first ChatErrorAgent
+
+withStore ::
+  ChatMonad m =>
+  (forall m'. (MonadUnliftIO m', MonadError StoreError m') => SQLiteStore -> m' a) ->
+  m a
+withStore action = do
+  st <- asks chatStore
+  runExceptT (action st `E.catch` handleInternal) >>= \case
+    Right c -> pure c
+    Left e -> throwError $ storeError e
+  where
+    -- TODO when parsing exception happens in store, the agent hangs;
+    -- changing SQLError to SomeException does not help
+    handleInternal :: (MonadError StoreError m') => E.SomeException -> m' a
+    handleInternal e = throwError . SEInternal $ bshow e
+    storeError :: StoreError -> ChatError
+    storeError = \case
+      SEContactNotFound c -> ChatErrorContact $ CENotFound c
+      e -> ChatErrorStore e
+
+chatCommandP :: Parser ChatCommand
+chatCommandP =
+  ("/help" <|> "/h") $> ChatHelp
+    <|> ("/add" <|> "/a") $> AddContact
+    <|> ("/connect " <|> "/c ") *> (Connect <$> smpQueueInfoP)
+    <|> ("/delete " <|> "/d ") *> (DeleteContact <$> contactRef)
+    <|> A.char '@' *> (SendMessage <$> contactRef <*> (A.space *> A.takeByteString))
+    <|> ("/markdown" <|> "/m") $> MarkdownHelp
+  where
+    contactRef = safeDecodeUtf8 <$> A.takeTill (== ' ')

src/Simplex/Chat/Controller.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Chat.Controller where
+
+import Control.Exception
+import Control.Monad.Except
+import Control.Monad.IO.Unlift
+import Control.Monad.Reader
+import Numeric.Natural
+import Simplex.Chat.Notification
+import Simplex.Chat.Protocol
+import Simplex.Chat.Store (StoreError)
+import Simplex.Chat.Terminal
+import Simplex.Chat.Types
+import Simplex.Messaging.Agent (AgentClient)
+import Simplex.Messaging.Agent.Protocol (AgentErrorType)
+import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
+import UnliftIO.STM
+
+data ChatController = ChatController
+  { currentUser :: User,
+    smpAgent :: AgentClient,
+    chatTerminal :: ChatTerminal,
+    chatStore :: SQLiteStore,
+    chatQ :: TBQueue ChatTransmission,
+    inputQ :: TBQueue InputEvent,
+    notifyQ :: TBQueue Notification,
+    sendNotification :: Notification -> IO ()
+  }
+
+data InputEvent = InputCommand String | InputControl Char
+
+data ChatError
+  = ChatErrorContact ContactError
+  | ChatErrorAgent AgentErrorType
+  | ChatErrorStore StoreError
+  deriving (Show, Exception)
+
+data ContactError = CENotFound ContactRef | CEProfile String
+  deriving (Show, Exception)
+
+type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m)
+
+newChatController :: AgentClient -> ChatTerminal -> SQLiteStore -> User -> (Notification -> IO ()) -> Natural -> STM ChatController
+newChatController smpAgent chatTerminal chatStore currentUser sendNotification qSize = do
+  inputQ <- newTBQueue qSize
+  notifyQ <- newTBQueue qSize
+  chatQ <- newTBQueue qSize
+  pure ChatController {currentUser, smpAgent, chatTerminal, chatStore, chatQ, inputQ, notifyQ, sendNotification}
+
+setActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
+setActive to = asks (activeTo . chatTerminal) >>= atomically . (`writeTVar` to)
+
+unsetActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
+unsetActive a = asks (activeTo . chatTerminal) >>= atomically . (`modifyTVar` unset)
+  where
+    unset a' = if a == a' then ActiveNone else a'

src/Simplex/Chat/Help.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Chat.Help where
+
+import Data.List (intersperse)
+import Simplex.Chat.Markdown
+import Simplex.Chat.Styled
+import System.Console.ANSI.Types
+
+chatHelpInfo :: [StyledString]
+chatHelpInfo =
+  map
+    styleMarkdown
+    [ Markdown (Colored Cyan) "Using Simplex chat prototype.",
+      "Follow these steps to set up a connection:",
+      "",
+      Markdown (Colored Green) "Step 1: " <> Markdown (Colored Cyan) "/add bob" <> " -- Alice adds her contact, Bob (she can use any name).",
+      indent <> "Alice should send the invitation printed by the /add command",
+      indent <> "to her contact, Bob, out-of-band, via any trusted channel.",
+      "",
+      Markdown (Colored Green) "Step 2: " <> Markdown (Colored Cyan) "/connect alice <invitation>" <> " -- Bob accepts the invitation.",
+      indent <> "Bob also can use any name for his contact, Alice,",
+      indent <> "followed by the invitation he received out-of-band.",
+      "",
+      Markdown (Colored Green) "Step 3: " <> "Bob and Alice are notified that the connection is set up,",
+      indent <> "both can now send messages:",
+      indent <> Markdown (Colored Cyan) "@bob Hello, Bob!" <> " -- Alice messages Bob.",
+      indent <> Markdown (Colored Cyan) "@alice Hey, Alice!" <> " -- Bob replies to Alice.",
+      "",
+      Markdown (Colored Green) "Other commands:",
+      indent <> Markdown (Colored Cyan) "/delete" <> " -- deletes contact and all messages with them.",
+      indent <> Markdown (Colored Cyan) "/markdown" <> " -- prints the supported markdown syntax.",
+      "",
+      "The commands may be abbreviated to a single letter: " <> listCommands ["/a", "/c", "/d", "/m"]
+    ]
+  where
+    listCommands = mconcat . intersperse ", " . map highlight
+    highlight = Markdown (Colored Cyan)
+    indent = "        "
+
+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)

src/Simplex/Chat/Input.hs

@@ -0,0 +1,117 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Simplex.Chat.Input where
+
+import Control.Monad.IO.Unlift
+import Control.Monad.Reader
+import Data.List (dropWhileEnd)
+import qualified Data.Text as T
+import Simplex.Chat.Controller
+import Simplex.Chat.Terminal
+import System.Exit (exitSuccess)
+import System.Terminal hiding (insertChars)
+import UnliftIO.STM
+
+getKey :: MonadTerminal m => m (Key, Modifiers)
+getKey =
+  flush >> awaitEvent >>= \case
+    Left Interrupt -> liftIO exitSuccess
+    Right (KeyEvent key ms) -> pure (key, ms)
+    _ -> getKey
+
+runTerminalInput :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
+runTerminalInput = do
+  ChatController {inputQ, chatTerminal = ct} <- ask
+  liftIO . withTerminal . runTerminalT $ do
+    updateInput ct
+    receiveFromTTY inputQ ct
+
+receiveFromTTY :: MonadTerminal m => TBQueue InputEvent -> ChatTerminal -> m ()
+receiveFromTTY inputQ ct@ChatTerminal {activeTo, termSize, termState} =
+  forever $ getKey >>= processKey >> withTermLock ct (updateInput ct)
+  where
+    processKey :: MonadTerminal m => (Key, Modifiers) -> m ()
+    processKey = \case
+      (EnterKey, _) -> submitInput
+      key -> atomically $ do
+        ac <- readTVar activeTo
+        modifyTVar termState $ updateTermState ac (width termSize) key
+
+    submitInput :: MonadTerminal m => m ()
+    submitInput = atomically $ do
+      ts <- readTVar termState
+      let s = inputString ts
+      writeTVar termState $ ts {inputString = "", inputPosition = 0, previousInput = s}
+      writeTBQueue inputQ $ InputCommand s
+
+updateTermState :: ActiveTo -> 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 /= "#" && 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
+      ActiveNone -> ""
+      ActiveC c -> "@" <> T.unpack c <> " "
+    -- ActiveG (Group g) -> "#" <> B.unpack g <> " "
+    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'}

src/Simplex/Chat/Notification.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Chat.Notification (Notification (..), initializeNotifications) where
+
+import Control.Monad (void)
+import Data.Char (toLower)
+import Data.List (isInfixOf)
+import Data.Text (Text)
+import qualified Data.Text as T
+import System.Directory (doesFileExist, getAppUserDataDirectory)
+import System.FilePath (combine)
+import System.Info (os)
+import System.Process (readCreateProcess, shell)
+
+data Notification = Notification {title :: Text, text :: Text}
+
+initializeNotifications :: IO (Notification -> IO ())
+initializeNotifications = case os of
+  "darwin" -> pure $ notify macScript
+  "mingw32" -> initWinNotify
+  "linux" ->
+    doesFileExist "/proc/sys/kernel/osrelease" >>= \case
+      False -> pure $ notify linuxScript
+      True -> do
+        v <- readFile "/proc/sys/kernel/osrelease"
+        if "wsl" `isInfixOf` map toLower v
+          then initWinNotify
+          else pure $ notify linuxScript
+  _ -> pure . const $ pure ()
+
+notify :: (Notification -> Text) -> Notification -> IO ()
+notify script notification =
+  void $ readCreateProcess (shell . T.unpack $ script notification) ""
+
+linuxScript :: Notification -> Text
+linuxScript Notification {title, text} = "notify-send \"" <> title <> "\" \"" <> text <> "\""
+
+macScript :: Notification -> Text
+macScript Notification {title, text} = "osascript -e 'display notification \"" <> text <> "\" with title \"" <> title <> "\"'"
+
+initWinNotify :: IO (Notification -> IO ())
+initWinNotify = notify . winScript <$> savePowershellScript
+
+winScript :: FilePath -> Notification -> Text
+winScript path Notification {title, text} = "powershell.exe \"" <> T.pack path <> " \'" <> title <> "\' \'" <> text <> "\'\""
+
+savePowershellScript :: IO FilePath
+savePowershellScript = do
+  appDir <- getAppUserDataDirectory "simplex"
+  let psScript = combine appDir "win-toast-notify.ps1"
+  writeFile
+    psScript
+    "[Windows.UI.Notifications.ToastNotificationManager, Windows.UI.Notifications, ContentType = WindowsRuntime] > $null\n\
+    \$Template = [Windows.UI.Notifications.ToastNotificationManager]::GetTemplateContent([Windows.UI.Notifications.ToastTemplateType]::ToastText02)\n\
+    \$RawXml = [xml] $Template.GetXml()\n\
+    \($RawXml.toast.visual.binding.text|where {$_.id -eq \"1\"}).AppendChild($RawXml.CreateTextNode($args[0])) > $null\n\
+    \($RawXml.toast.visual.binding.text|where {$_.id -eq \"2\"}).AppendChild($RawXml.CreateTextNode($args[1])) > $null\n\
+    \$SerializedXml = New-Object Windows.Data.Xml.Dom.XmlDocument\n\
+    \$SerializedXml.LoadXml($RawXml.OuterXml)\n\
+    \$Toast = [Windows.UI.Notifications.ToastNotification]::new($SerializedXml)\n\
+    \$Toast.Tag = \"simplex-chat\"\n\
+    \$Toast.Group = \"simplex-chat\"\n\
+    \$Toast.ExpirationTime = [DateTimeOffset]::Now.AddMinutes(1)\n\
+    \$Notifier = [Windows.UI.Notifications.ToastNotificationManager]::CreateToastNotifier(\"PowerShell\")\n\
+    \$Notifier.Show($Toast);\n"
+  return psScript

src/Simplex/Chat/Options.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Chat.Options (getChatOpts, ChatOpts (..)) where
+
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import qualified Data.ByteString.Char8 as B
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as L
+import Options.Applicative
+import Simplex.Messaging.Agent.Protocol (SMPServer (..), smpServerP)
+import Simplex.Messaging.Parsers (parseAll)
+import System.FilePath (combine)
+
+data ChatOpts = ChatOpts
+  { dbFile :: String,
+    smpServers :: NonEmpty SMPServer
+  }
+
+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(s) to use (smp1.simplex.im#pLdiGvm0jD1CMblnov6Edd/391OrYsShw+RgdfR0ChA=)"
+          <> value (L.fromList ["smp1.simplex.im#pLdiGvm0jD1CMblnov6Edd/391OrYsShw+RgdfR0ChA="])
+      )
+  where
+    defaultDbFilePath = combine appDir "simplex"
+
+parseSMPServer :: ReadM (NonEmpty SMPServer)
+parseSMPServer = eitherReader $ parseAll servers . B.pack
+  where
+    servers = L.fromList <$> smpServerP `A.sepBy1` A.char ','
+
+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"
+        )

src/Simplex/Chat/Store.hs

@@ -0,0 +1,289 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Simplex.Chat.Store
+  ( SQLiteStore,
+    StoreError (..),
+    createStore,
+    createUser,
+    getUsers,
+    setActiveUser,
+    createDirectConnection,
+    createDirectContact,
+    deleteContact,
+    getContactConnection,
+    getContactConnections,
+    getConnectionChatDirection,
+  )
+where
+
+import Control.Exception (Exception)
+import qualified Control.Exception as E
+import Control.Monad.Except
+import Control.Monad.IO.Unlift
+import Data.ByteString.Char8 (ByteString)
+import Data.FileEmbed (embedDir, makeRelativeToProject)
+import Data.Function (on)
+import Data.Int (Int64)
+import Data.List (sortBy)
+import Data.Maybe (listToMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8)
+import Data.Time.Clock (UTCTime)
+import Database.SQLite.Simple (NamedParam (..), Only (..), SQLError)
+import qualified Database.SQLite.Simple as DB
+import Database.SQLite.Simple.QQ (sql)
+import Simplex.Chat.Protocol
+import Simplex.Chat.Types
+import Simplex.Messaging.Agent.Protocol (AParty (..), ConnId)
+import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, withTransaction)
+import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
+import Simplex.Messaging.Util (bshow, liftIOEither, (<$$>))
+import System.FilePath (takeBaseName, takeExtension)
+
+-- | The list of migrations in ascending order by date
+migrations :: [Migration]
+migrations =
+  sortBy (compare `on` name) . map migration . filter sqlFile $
+    $(makeRelativeToProject "migrations" >>= embedDir)
+  where
+    sqlFile (file, _) = takeExtension file == ".sql"
+    migration (file, qStr) = Migration {name = takeBaseName file, up = decodeUtf8 qStr}
+
+createStore :: FilePath -> Int -> IO SQLiteStore
+createStore dbFilePath poolSize = createSQLiteStore dbFilePath poolSize migrations
+
+checkConstraint :: StoreError -> IO (Either StoreError a) -> IO (Either StoreError a)
+checkConstraint err action = action `E.catch` (pure . Left . handleSQLError err)
+
+handleSQLError :: StoreError -> SQLError -> StoreError
+handleSQLError err e
+  | DB.sqlError e == DB.ErrorConstraint = err
+  | otherwise = SEInternal $ bshow e
+
+insertedRowId :: DB.Connection -> IO Int64
+insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid();"
+
+createUser :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> Profile -> Bool -> m User
+createUser st Profile {contactRef, displayName} activeUser =
+  liftIOEither . checkConstraint SEDuplicateContactRef . withTransaction st $ \db -> do
+    DB.execute db "INSERT INTO contact_profiles (contact_ref, display_name) VALUES (?, ?);" (contactRef, displayName)
+    profileId <- insertedRowId db
+    DB.execute db "INSERT INTO users (contact_id, active_user) VALUES (0, ?);" (Only activeUser)
+    userId <- insertedRowId db
+    DB.execute
+      db
+      "INSERT INTO contacts (contact_profile_id, local_contact_ref, lcr_base, user_id, user) VALUES (?, ?, ?, ?, 1);"
+      (profileId, contactRef, contactRef, userId)
+    contactId <- insertedRowId db
+    DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?;" (contactId, userId)
+    pure . Right $ toUser (userId, activeUser, contactRef, displayName)
+
+getUsers :: SQLiteStore -> IO [User]
+getUsers st =
+  withTransaction st $ \db ->
+    map toUser
+      <$> DB.query_
+        db
+        [sql|
+          SELECT u.user_id, u.active_user, c.local_contact_ref, p.display_name
+          FROM users u
+          JOIN contacts c ON u.contact_id = c.contact_id
+          JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id
+        |]
+
+toUser :: (UserId, Bool, ContactRef, Text) -> User
+toUser (userId, activeUser, contactRef, displayName) =
+  let profile = Profile {contactRef, displayName}
+   in User {userId, localContactRef = contactRef, profile, activeUser}
+
+setActiveUser :: MonadUnliftIO m => SQLiteStore -> UserId -> m ()
+setActiveUser st userId = do
+  liftIO . withTransaction st $ \db -> do
+    DB.execute_ db "UPDATE users SET active_user = 0;"
+    DB.execute db "UPDATE users SET active_user = 1 WHERE user_id = ?;" (Only userId)
+
+createDirectConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> ConnId -> m ()
+createDirectConnection st userId agentConnId =
+  liftIO . withTransaction st $ \db ->
+    DB.execute
+      db
+      [sql|
+        INSERT INTO connections
+          (user_id, agent_conn_id, conn_status, conn_type) VALUES (?,?,?,?);
+      |]
+      (userId, agentConnId, ConnNew, ConnContact)
+
+createDirectContact ::
+  (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> Connection -> Profile -> m ()
+createDirectContact st userId Connection {connId} Profile {contactRef, displayName} =
+  liftIOEither . withTransaction st $ \db -> do
+    DB.execute db "INSERT INTO contact_profiles (contact_ref, display_name) VALUES (?, ?);" (contactRef, displayName)
+    profileId <- insertedRowId db
+    lcrSuffix <- getLcrSuffix db
+    create db profileId lcrSuffix 20
+  where
+    getLcrSuffix :: DB.Connection -> IO Int
+    getLcrSuffix db =
+      maybe 0 ((+ 1) . fromOnly) . listToMaybe
+        <$> DB.queryNamed
+          db
+          [sql|
+            SELECT lcr_suffix FROM contacts
+            WHERE user_id = :user_id AND lcr_base = :contact_ref
+            ORDER BY lcr_suffix DESC
+            LIMIT 1;
+          |]
+          [":user_id" := userId, ":contact_ref" := contactRef]
+    create :: DB.Connection -> Int64 -> Int -> Int -> IO (Either StoreError ())
+    create _ _ _ 0 = pure $ Left SEDuplicateContactRef
+    create db profileId lcrSuffix attempts = do
+      let lcr = localContactRef' lcrSuffix
+      E.try (insertUser lcr) >>= \case
+        Right () -> do
+          contactId <- insertedRowId db
+          DB.execute db "UPDATE connections SET contact_id = ? WHERE connection_id = ?" (contactId, connId)
+          pure $ Right ()
+        Left e
+          | DB.sqlError e == DB.ErrorConstraint -> create db profileId (lcrSuffix + 1) (attempts - 1)
+          | otherwise -> E.throwIO e
+      where
+        localContactRef' 0 = contactRef
+        localContactRef' n = contactRef <> T.pack ('_' : show n)
+        insertUser lcr =
+          DB.execute
+            db
+            [sql|
+              INSERT INTO contacts
+                (contact_profile_id, local_contact_ref, lcr_base, lcr_suffix, user_id) VALUES (?, ?, ?, ?, ?)
+            |]
+            (profileId, lcr, contactRef, lcrSuffix, userId)
+
+deleteContact :: MonadUnliftIO m => SQLiteStore -> UserId -> ContactRef -> m ()
+deleteContact st userId contactRef =
+  liftIO . withTransaction st $ \db ->
+    forM_
+      [ [sql|
+          DELETE FROM connections WHERE connection_id IN (
+            SELECT connection_id
+            FROM connections c
+            JOIN contacts cs ON c.contact_id = cs.contact_id
+            WHERE cs.user_id = :user_id AND cs.local_contact_ref = :contact_ref
+          );
+        |],
+        [sql|
+          DELETE FROM contacts
+          WHERE user_id = :user_id AND local_contact_ref = :contact_ref;
+        |]
+      ]
+      $ \q -> DB.executeNamed db q [":user_id" := userId, ":contact_ref" := contactRef]
+
+-- TODO return the last connection that is ready, not any last connection
+-- requires updating connection status
+getContactConnection ::
+  (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> ContactRef -> m Connection
+getContactConnection st userId contactRef =
+  liftIOEither . withTransaction st $ \db ->
+    connection
+      <$> DB.queryNamed
+        db
+        [sql|
+          SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
+            c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.created_at
+          FROM connections c
+          JOIN contacts cs ON c.contact_id == cs.contact_id
+          WHERE c.user_id = :user_id
+            AND cs.user_id = :user_id
+            AND cs.local_contact_ref == :contact_ref
+          ORDER BY c.connection_id DESC
+          LIMIT 1;
+        |]
+        [":user_id" := userId, ":contact_ref" := contactRef]
+  where
+    connection (connRow : _) = Right $ toConnection connRow
+    connection _ = Left $ SEContactNotFound contactRef
+
+getContactConnections :: MonadUnliftIO m => SQLiteStore -> UserId -> ContactRef -> m [Connection]
+getContactConnections st userId contactRef =
+  liftIO . withTransaction st $ \db ->
+    map toConnection
+      <$> DB.queryNamed
+        db
+        [sql|
+          SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
+            c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.created_at
+          FROM connections c
+          JOIN contacts cs ON c.contact_id == cs.contact_id
+          WHERE c.user_id = :user_id
+            AND cs.user_id = :user_id
+            AND cs.local_contact_ref == :contact_ref;
+        |]
+        [":user_id" := userId, ":contact_ref" := contactRef]
+
+toConnection ::
+  (Int64, ConnId, Int, Maybe Int64, ConnStatus, ConnType, Maybe Int64, Maybe Int64, UTCTime) -> Connection
+toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, createdAt) =
+  let entityId = entityId_ connType
+   in Connection {connId, agentConnId, connLevel, viaContact, connStatus, connType, entityId, createdAt}
+  where
+    entityId_ :: ConnType -> Maybe Int64
+    entityId_ ConnContact = contactId
+    entityId_ ConnMember = groupMemberId
+
+getConnectionChatDirection ::
+  (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> ConnId -> m (ChatDirection 'Agent)
+getConnectionChatDirection st userId agentConnId =
+  liftIOEither . withTransaction st $ \db -> do
+    getConnection db >>= \case
+      Left e -> pure $ Left e
+      Right c@Connection {connType, entityId} -> case connType of
+        ConnMember -> pure . Left $ SEInternal "group members not supported yet"
+        ConnContact ->
+          ReceivedDirectMessage <$$> case entityId of
+            Nothing -> pure $ Right NewContact {activeConn = c}
+            Just cId -> getContact db cId c
+  where
+    getConnection db =
+      connection
+        <$> DB.query
+          db
+          [sql|
+            SELECT connection_id, agent_conn_id, conn_level, via_contact,
+              conn_status, conn_type, contact_id, group_member_id, created_at
+            FROM connections
+            WHERE user_id = ? AND agent_conn_id = ?;
+          |]
+          (userId, agentConnId)
+    connection (connRow : _) = Right $ toConnection connRow
+    connection _ = Left $ SEConnectionNotFound agentConnId
+    getContact db contactId c =
+      toContact contactId c
+        <$> DB.query
+          db
+          [sql|
+            SELECT c.local_contact_ref, p.contact_ref, p.display_name
+            FROM contacts c
+            JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id
+            WHERE c.user_id = ? AND c.contact_id = ?
+          |]
+          (userId, contactId)
+    toContact contactId c [(localContactRef, contactRef, displayName)] =
+      let profile = Profile {contactRef, displayName}
+       in Right Contact {contactId, localContactRef, profile, activeConn = c}
+    toContact _ _ _ = Left $ SEInternal "referenced contact not found"
+
+data StoreError
+  = SEDuplicateContactRef
+  | SEContactNotFound ContactRef
+  | SEConnectionNotFound ConnId
+  | SEInternal ByteString
+  deriving (Show, Exception)

src/Simplex/Chat/Terminal.hs

@@ -0,0 +1,154 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.Chat.Terminal where
+
+import Simplex.Chat.Styled
+import Simplex.Chat.Types
+import System.Console.ANSI.Types
+import System.Terminal
+import UnliftIO.STM
+
+data ActiveTo = ActiveNone | ActiveC ContactRef
+  deriving (Eq)
+
+data ChatTerminal = ChatTerminal
+  { activeTo :: TVar ActiveTo,
+    termState :: TVar TerminalState,
+    termSize :: Size,
+    nextMessageRow :: TVar Int,
+    termLock :: TMVar ()
+  }
+
+data TerminalState = TerminalState
+  { inputPrompt :: String,
+    inputString :: String,
+    inputPosition :: Int,
+    previousInput :: String
+  }
+
+newChatTerminal :: IO ChatTerminal
+newChatTerminal = do
+  activeTo <- newTVarIO ActiveNone
+  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 {activeTo, termState, termSize, nextMessageRow, termLock}
+
+newTermState :: TerminalState
+newTermState =
+  TerminalState
+    { inputString = "",
+      inputPosition = 0,
+      inputPrompt = "> ",
+      previousInput = ""
+    }
+
+withTermLock :: MonadTerminal m => ChatTerminal -> m () -> m ()
+withTermLock ChatTerminal {termLock} action = do
+  _ <- atomically $ takeTMVar termLock
+  action
+  atomically $ putTMVar termLock ()
+
+printToTerminal :: ChatTerminal -> [StyledString] -> IO ()
+printToTerminal ct s = withTerminal . runTerminalT . withTermLock ct $ do
+  printMessage ct s
+  updateInput ct
+
+updateInput :: forall m. MonadTerminal m => ChatTerminal -> m ()
+updateInput ChatTerminal {termSize = Size {height, width}, termState, nextMessageRow} = do
+  hideCursor
+  ts <- readTVarIO termState
+  nmr <- readTVarIO nextMessageRow
+  let ih = inputHeight ts
+      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
+    inputHeight :: TerminalState -> Int
+    inputHeight ts = length (inputPrompt ts <> inputString ts) `div` width + 1
+    positionRowColumn :: Int -> Int -> Position
+    positionRowColumn wid pos =
+      let row = pos `div` wid
+          col = pos - row * wid
+       in Position {row, col}
+
+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
+
+-- 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

src/Simplex/Chat/Util.hs

@@ -0,0 +1,10 @@
+module Simplex.Chat.Util where
+
+import Data.ByteString.Char8 (ByteString)
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8With)
+
+safeDecodeUtf8 :: ByteString -> Text
+safeDecodeUtf8 = decodeUtf8With onError
+  where
+    onError _ _ = Just '?'

src/Simplex/Chat/View.hs

@@ -0,0 +1,148 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Chat.View
+  ( printToView,
+    showInvitation,
+    showChatError,
+    showContactDeleted,
+    showContactConnected,
+    showContactDisconnected,
+    showReceivedMessage,
+    showSentMessage,
+    safeDecodeUtf8,
+  )
+where
+
+import Control.Monad.IO.Unlift
+import Control.Monad.Reader
+import Data.ByteString.Char8 (ByteString)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (DiffTime, UTCTime)
+import Data.Time.Format (defaultTimeLocale, formatTime)
+import Data.Time.LocalTime (TimeZone, ZonedTime, getCurrentTimeZone, getZonedTime, localDay, localTimeOfDay, timeOfDayToTime, utcToLocalTime, zonedTimeToLocalTime)
+import Simplex.Chat.Controller
+import Simplex.Chat.Markdown
+import Simplex.Chat.Styled
+import Simplex.Chat.Terminal (printToTerminal)
+import Simplex.Chat.Types
+import Simplex.Chat.Util (safeDecodeUtf8)
+import Simplex.Messaging.Agent.Protocol
+import System.Console.ANSI.Types
+
+type ChatReader m = (MonadUnliftIO m, MonadReader ChatController m)
+
+showInvitation :: ChatReader m => SMPQueueInfo -> m ()
+showInvitation = printToView . invitation
+
+showChatError :: ChatReader m => ChatError -> m ()
+showChatError = printToView . chatError
+
+showContactDeleted :: ChatReader m => ContactRef -> m ()
+showContactDeleted = printToView . contactDeleted
+
+showContactConnected :: ChatReader m => ContactRef -> m ()
+showContactConnected = printToView . contactConnected
+
+showContactDisconnected :: ChatReader m => ContactRef -> m ()
+showContactDisconnected = printToView . contactDisconnected
+
+showReceivedMessage :: ChatReader m => ContactRef -> UTCTime -> Text -> MsgIntegrity -> m ()
+showReceivedMessage c utcTime msg mOk = printToView =<< liftIO (receivedMessage c utcTime msg mOk)
+
+showSentMessage :: ChatReader m => ContactRef -> ByteString -> m ()
+showSentMessage c msg = printToView =<< liftIO (sentMessage c msg)
+
+invitation :: SMPQueueInfo -> [StyledString]
+invitation qInfo =
+  [ "pass this invitation to your contact (via another channel): ",
+    "",
+    (bPlain . serializeSmpQueueInfo) qInfo,
+    "",
+    "and ask them to connect: /c <name_for_you> <invitation_above>"
+  ]
+
+contactDeleted :: ContactRef -> [StyledString]
+contactDeleted c = [ttyContact c <> " is deleted"]
+
+contactConnected :: ContactRef -> [StyledString]
+contactConnected c = [ttyContact c <> " is connected"]
+
+contactDisconnected :: ContactRef -> [StyledString]
+contactDisconnected c = ["disconnected from " <> ttyContact c <> " - restart chat"]
+
+receivedMessage :: ContactRef -> UTCTime -> Text -> MsgIntegrity -> IO [StyledString]
+receivedMessage c utcTime msg mOk = do
+  t <- formatUTCTime <$> getCurrentTimeZone <*> getZonedTime
+  pure $ prependFirst (t <> " " <> ttyFromContact c) (msgPlain msg) ++ showIntegrity mOk
+  where
+    formatUTCTime :: TimeZone -> ZonedTime -> StyledString
+    formatUTCTime localTz currentTime =
+      let localTime = utcToLocalTime localTz utcTime
+          format =
+            if (localDay localTime < localDay (zonedTimeToLocalTime currentTime))
+              && (timeOfDayToTime (localTimeOfDay localTime) > (6 * 60 * 60 :: DiffTime))
+              then "%m-%d" -- if message is from yesterday or before and 6 hours has passed since midnight
+              else "%H:%M"
+       in styleTime $ formatTime defaultTimeLocale format localTime
+    showIntegrity :: MsgIntegrity -> [StyledString]
+    showIntegrity MsgOk = []
+    showIntegrity (MsgError err) = msgError $ case err of
+      MsgSkipped fromId toId ->
+        "skipped message ID " <> show fromId
+          <> if fromId == toId then "" else ".." <> show toId
+      MsgBadId msgId -> "unexpected message ID " <> show msgId
+      MsgBadHash -> "incorrect message hash"
+      MsgDuplicate -> "duplicate message ID"
+    msgError :: String -> [StyledString]
+    msgError s = [styled (Colored Red) s]
+
+sentMessage :: ContactRef -> ByteString -> IO [StyledString]
+sentMessage c msg = do
+  time <- formatTime defaultTimeLocale "%H:%M" <$> getZonedTime
+  pure $ prependFirst (styleTime time <> " " <> ttyToContact c) (msgPlain $ safeDecodeUtf8 msg)
+
+prependFirst :: StyledString -> [StyledString] -> [StyledString]
+prependFirst s [] = [s]
+prependFirst s (s' : ss) = (s <> s') : ss
+
+msgPlain :: Text -> [StyledString]
+msgPlain = map styleMarkdownText . T.lines
+
+chatError :: ChatError -> [StyledString]
+chatError = \case
+  ChatErrorContact e -> case e of
+    CENotFound c -> ["no contact " <> ttyContact c]
+    CEProfile s -> ["invalid profile: " <> plain s]
+  ChatErrorAgent err -> case err of
+    -- CONN e -> case e of
+    --   -- TODO replace with ChatErrorContact errors, these errors should never happen
+    --   NOT_FOUND -> ["no contact " <> ttyContact c]
+    --   DUPLICATE -> ["contact " <> ttyContact c <> " already exists"]
+    --   SIMPLEX -> ["contact " <> ttyContact c <> " did not accept invitation yet"]
+    e -> ["smp agent error: " <> plain (show e)]
+  e -> ["chat error: " <> plain (show e)]
+
+printToView :: (MonadUnliftIO m, MonadReader ChatController m) => [StyledString] -> m ()
+printToView s = asks chatTerminal >>= liftIO . (`printToTerminal` s)
+
+ttyContact :: ContactRef -> StyledString
+ttyContact = styled (Colored Green)
+
+ttyToContact :: ContactRef -> StyledString
+ttyToContact c = styled (Colored Cyan) $ c <> " "
+
+ttyFromContact :: ContactRef -> StyledString
+ttyFromContact c = styled (Colored Yellow) $ c <> "> "
+
+-- ttyGroup :: Group -> StyledString
+-- ttyGroup (Group g) = styled (Colored Blue) $ "#" <> g
+
+-- ttyFromGroup :: Group -> Contact -> StyledString
+-- ttyFromGroup (Group g) (Contact a) = styled (Colored Yellow) $ "#" <> g <> " " <> a <> "> "
+
+styleTime :: String -> StyledString
+styleTime = Styled [SetColor Foreground Vivid Black]