core: send parsed markdown via API (#349)

src/Simplex/Chat.hs

@@ -37,6 +37,7 @@ import Data.Time.Clock (UTCTime, getCurrentTime)
 import Data.Time.LocalTime (getCurrentTimeZone)
 import Data.Word (Word32)
 import Simplex.Chat.Controller
+import Simplex.Chat.Markdown
 import Simplex.Chat.Messages
 import Simplex.Chat.Options (ChatOpts (..))
 import Simplex.Chat.Protocol
@@ -336,9 +337,9 @@ processChatCommand = \case
     let ciContent = CISndFileInvitation fileId f
     createdAt <- liftIO getCurrentTime
     let ci = mkNewChatItem ciContent 0 createdAt createdAt
-    ciMeta@CIMeta {itemId} <- saveChatItem userId (CDGroupSnd gInfo) ci
+    cItem@ChatItem {meta = CIMeta {itemId}} <- saveChatItem userId (CDGroupSnd gInfo) ci
     withStore $ \st -> updateFileTransferChatItemId st fileId itemId
-    pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) $ ChatItem CIGroupSnd ciMeta ciContent
+    pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) cItem
   ReceiveFile fileId filePath_ -> withUser $ \User {userId} -> do
     ft@RcvFileTransfer {fileInvitation = FileInvitation {fileName, fileConnReq}, fileStatus} <- withStore $ \st -> getRcvFileTransfer st userId fileId
     unless (fileStatus == RFSNew) . throwChatError $ CEFileAlreadyReceiving fileName
@@ -891,7 +892,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
 
     newContentMessage :: Contact -> MsgContent -> MessageId -> MsgMeta -> m ()
     newContentMessage ct@Contact {localDisplayName = c} mc msgId msgMeta = do
-      ci <- saveRcvDirectChatItem userId ct msgId msgMeta (CIRcvMsgContent mc)
+      ci <- saveRcvChatItem userId (CDDirectRcv ct) msgId msgMeta (CIRcvMsgContent mc)
       toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci
       checkIntegrity msgMeta $ toView . CRMsgIntegrityError
       showToast (c <> "> ") $ msgContentText mc
@@ -899,9 +900,8 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
 
     newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContent -> MessageId -> MsgMeta -> m ()
     newGroupContentMessage gInfo m@GroupMember {localDisplayName = c} mc msgId msgMeta = do
-      ci <- saveRcvGroupChatItem userId gInfo m msgId msgMeta (CIRcvMsgContent mc)
-      toView . CRNewChatItem $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci
-      checkIntegrity msgMeta $ toView . CRMsgIntegrityError
+      ci <- saveRcvChatItem userId (CDGroupRcv gInfo m) msgId msgMeta (CIRcvMsgContent mc)
+      groupMsgToView gInfo ci msgMeta
       let g = groupName' gInfo
       showToast ("#" <> g <> " " <> c <> "> ") $ msgContentText mc
       setActive $ ActiveG g
@@ -911,7 +911,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
       -- TODO chunk size has to be sent as part of invitation
       chSize <- asks $ fileChunkSize . config
       ft@RcvFileTransfer {fileId} <- withStore $ \st -> createRcvFileTransfer st userId ct fInv chSize
-      ci <- saveRcvDirectChatItem userId ct msgId msgMeta (CIRcvFileInvitation ft)
+      ci <- saveRcvChatItem userId (CDDirectRcv ct) msgId msgMeta (CIRcvFileInvitation ft)
       withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId' ci
       toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci
       checkIntegrity msgMeta $ toView . CRMsgIntegrityError
@@ -922,14 +922,18 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
     processGroupFileInvitation gInfo m@GroupMember {localDisplayName = c} fInv msgId msgMeta = do
       chSize <- asks $ fileChunkSize . config
       ft@RcvFileTransfer {fileId} <- withStore $ \st -> createRcvGroupFileTransfer st userId m fInv chSize
-      ci <- saveRcvGroupChatItem userId gInfo m msgId msgMeta (CIRcvFileInvitation ft)
+      ci <- saveRcvChatItem userId (CDGroupRcv gInfo m) msgId msgMeta (CIRcvFileInvitation ft)
       withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId' ci
-      toView . CRNewChatItem $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci
-      checkIntegrity msgMeta $ toView . CRMsgIntegrityError
+      groupMsgToView gInfo ci msgMeta
       let g = groupName' gInfo
       showToast ("#" <> g <> " " <> c <> "> ") "wants to send a file"
       setActive $ ActiveG g
 
+    groupMsgToView :: GroupInfo -> ChatItem 'CTGroup 'MDRcv -> MsgMeta -> m ()
+    groupMsgToView gInfo ci msgMeta = do
+      toView . CRNewChatItem $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci
+      checkIntegrity msgMeta $ toView . CRMsgIntegrityError
+
     processGroupInvitation :: Contact -> GroupInvitation -> m ()
     processGroupInvitation ct@Contact {localDisplayName = c} inv@(GroupInvitation (MemberIdRole fromMemId fromRole) (MemberIdRole memId memRole) _ _) = do
       when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
@@ -1267,36 +1271,31 @@ saveRcvMSG Connection {connId} agentMsgMeta msgBody = do
   pure (msgId, chatMsgEvent)
 
 sendDirectChatItem :: ChatMonad m => UserId -> Contact -> ChatMsgEvent -> CIContent 'MDSnd -> m (ChatItem 'CTDirect 'MDSnd)
-sendDirectChatItem userId contact chatMsgEvent ciContent = do
-  msgId <- sendDirectContactMessage contact chatMsgEvent
-  createdAt <- liftIO getCurrentTime
-  ciMeta <- saveChatItem userId (CDDirectSnd contact) $ mkNewChatItem ciContent msgId createdAt createdAt
-  pure $ ChatItem CIDirectSnd ciMeta ciContent
+sendDirectChatItem userId ct chatMsgEvent ciContent = do
+  msgId <- sendDirectContactMessage ct chatMsgEvent
+  saveSndChatItem userId (CDDirectSnd ct) msgId ciContent
 
 sendGroupChatItem :: ChatMonad m => UserId -> Group -> ChatMsgEvent -> CIContent 'MDSnd -> m (ChatItem 'CTGroup 'MDSnd)
 sendGroupChatItem userId (Group g ms) chatMsgEvent ciContent = do
   msgId <- sendGroupMessage ms chatMsgEvent
-  createdAt <- liftIO getCurrentTime
-  ciMeta <- saveChatItem userId (CDGroupSnd g) $ mkNewChatItem ciContent msgId createdAt createdAt
-  pure $ ChatItem CIGroupSnd ciMeta ciContent
+  saveSndChatItem userId (CDGroupSnd g) msgId ciContent
 
-saveRcvDirectChatItem :: ChatMonad m => UserId -> Contact -> MessageId -> MsgMeta -> CIContent 'MDRcv -> m (ChatItem 'CTDirect 'MDRcv)
-saveRcvDirectChatItem userId ct msgId MsgMeta {broker = (_, brokerTs)} ciContent = do
+saveSndChatItem :: ChatMonad m => UserId -> ChatDirection c 'MDSnd -> MessageId -> CIContent 'MDSnd -> m (ChatItem c 'MDSnd)
+saveSndChatItem userId cd msgId ciContent = do
   createdAt <- liftIO getCurrentTime
-  ciMeta <- saveChatItem userId (CDDirectRcv ct) $ mkNewChatItem ciContent msgId brokerTs createdAt
-  pure $ ChatItem CIDirectRcv ciMeta ciContent
+  saveChatItem userId cd $ mkNewChatItem ciContent msgId createdAt createdAt
 
-saveRcvGroupChatItem :: ChatMonad m => UserId -> GroupInfo -> GroupMember -> MessageId -> MsgMeta -> CIContent 'MDRcv -> m (ChatItem 'CTGroup 'MDRcv)
-saveRcvGroupChatItem userId g m msgId MsgMeta {broker = (_, brokerTs)} ciContent = do
+saveRcvChatItem :: ChatMonad m => UserId -> ChatDirection c 'MDRcv -> MessageId -> MsgMeta -> CIContent 'MDRcv -> m (ChatItem c 'MDRcv)
+saveRcvChatItem userId cd msgId MsgMeta {broker = (_, brokerTs)} ciContent = do
   createdAt <- liftIO getCurrentTime
-  ciMeta <- saveChatItem userId (CDGroupRcv g m) $ mkNewChatItem ciContent msgId brokerTs createdAt
-  pure $ ChatItem (CIGroupRcv m) ciMeta ciContent
+  saveChatItem userId cd $ mkNewChatItem ciContent msgId brokerTs createdAt
 
-saveChatItem :: (ChatMonad m, MsgDirectionI d) => UserId -> ChatDirection c d -> NewChatItem d -> m (CIMeta d)
-saveChatItem userId cd ci@NewChatItem {itemTs, itemText, createdAt} = do
+saveChatItem :: (ChatMonad m, MsgDirectionI d) => UserId -> ChatDirection c d -> NewChatItem d -> m (ChatItem c d)
+saveChatItem userId cd ci@NewChatItem {itemContent, itemTs, itemText, createdAt} = do
   tz <- liftIO getCurrentTimeZone
   ciId <- withStore $ \st -> createNewChatItem st userId cd ci
-  pure $ mkCIMeta ciId itemText ciStatusNew tz itemTs createdAt
+  let ciMeta = mkCIMeta ciId itemText ciStatusNew tz itemTs createdAt
+  pure $ ChatItem (toCIDirection cd) ciMeta itemContent $ parseMarkdownList itemText
 
 mkNewChatItem :: forall d. MsgDirectionI d => CIContent d -> MessageId -> UTCTime -> UTCTime -> NewChatItem d
 mkNewChatItem itemContent msgId itemTs createdAt =

src/Simplex/Chat/Help.hs

@@ -20,10 +20,10 @@ import Simplex.Chat.Types (Profile (..), User (..))
 import System.Console.ANSI.Types
 
 highlight :: Text -> Markdown
-highlight = Markdown (Colored Cyan)
+highlight = markdown (colored Cyan)
 
 green :: Text -> Markdown
-green = Markdown (Colored Green)
+green = markdown (colored Green)
 
 indent :: Markdown
 indent = "        "
@@ -150,11 +150,11 @@ markdownInfo =
   map
     styleMarkdown
     [ green "Markdown:",
-      indent <> highlight "*bold*         " <> " - " <> Markdown Bold "bold text",
-      indent <> highlight "_italic_       " <> " - " <> Markdown Italic "italic text" <> " (shown as underlined)",
-      indent <> highlight "+underlined+   " <> " - " <> Markdown Underline "underlined text",
-      indent <> highlight "~strikethrough~" <> " - " <> Markdown StrikeThrough "strikethrough text" <> " (shown as inverse)",
-      indent <> highlight "`code snippet` " <> " - " <> Markdown Snippet "a + b // no *markdown* here",
-      indent <> highlight "!1 text!       " <> " - " <> Markdown (Colored Red) "red text" <> " (1-6: red, green, blue, yellow, cyan, magenta)",
-      indent <> highlight "#secret#       " <> " - " <> Markdown Secret "secret text" <> " (can be copy-pasted)"
+      indent <> highlight "*bold*         " <> " - " <> markdown Bold "bold text",
+      indent <> highlight "_italic_       " <> " - " <> markdown Italic "italic text" <> " (shown as underlined)",
+      indent <> highlight "+underlined+   " <> " - " <> markdown Underline "underlined text",
+      indent <> highlight "~strikethrough~" <> " - " <> markdown StrikeThrough "strikethrough text" <> " (shown as inverse)",
+      indent <> highlight "`code snippet` " <> " - " <> markdown Snippet "a + b // no *markdown* here",
+      indent <> highlight "!1 text!       " <> " - " <> markdown (colored Red) "red text" <> " (1-6: red, green, blue, yellow, cyan, magenta)",
+      indent <> highlight "#secret#       " <> " - " <> markdown Secret "secret text" <> " (can be copy-pasted)"
     ]

src/Simplex/Chat/Markdown.hs

@@ -1,11 +1,15 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Simplex.Chat.Markdown where
 
 import Control.Applicative ((<|>))
+import Data.Aeson (ToJSON)
+import qualified Data.Aeson as J
 import Data.Attoparsec.Text (Parser)
 import qualified Data.Attoparsec.Text as A
+import Data.Bifunctor (second)
 import Data.Either (fromRight)
 import Data.Functor (($>))
 import Data.Map.Strict (Map)
@@ -13,9 +17,11 @@ import qualified Data.Map.Strict as M
 import Data.String
 import Data.Text (Text)
 import qualified Data.Text as T
+import GHC.Generics
+import Simplex.Messaging.Parsers (fstToLower, sumTypeJSON)
 import System.Console.ANSI.Types
 
-data Markdown = Markdown Format Text | Markdown :|: Markdown
+data Markdown = Markdown (Maybe Format) Text | Markdown :|: Markdown
   deriving (Eq, Show)
 
 data Format
@@ -25,9 +31,16 @@ data Format
   | StrikeThrough
   | Snippet
   | Secret
-  | Colored Color
-  | NoFormat
-  deriving (Eq, Show)
+  | Colored FormatColor
+  deriving (Eq, Show, Generic)
+
+colored :: Color -> Format
+colored = Colored . FormatColor
+
+markdown :: Format -> Text -> Markdown
+markdown = Markdown . Just
+
+instance ToJSON Format where toEncoding = J.genericToEncoding $ sumTypeJSON fstToLower
 
 instance Semigroup Markdown where (<>) = (:|:)
 
@@ -35,8 +48,30 @@ instance Monoid Markdown where mempty = unmarked ""
 
 instance IsString Markdown where fromString = unmarked . T.pack
 
+newtype FormatColor = FormatColor Color
+  deriving (Eq, Show)
+
+instance ToJSON FormatColor where
+  toJSON (FormatColor c) = case c of
+    Red -> "red"
+    Green -> "green"
+    Blue -> "blue"
+    Yellow -> "yellow"
+    Cyan -> "cyan"
+    Magenta -> "magenta"
+    Black -> "black"
+    White -> "white"
+
+data FormattedText = FormattedText {format :: Maybe Format, text :: Text}
+  deriving (Eq, Show, Generic)
+
+instance ToJSON FormattedText where
+  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
+
+type MarkdownList = [FormattedText]
+
 unmarked :: Text -> Markdown
-unmarked = Markdown NoFormat
+unmarked = Markdown Nothing
 
 colorMD :: Char
 colorMD = '!'
@@ -53,12 +88,12 @@ formats =
       ('~', StrikeThrough),
       ('`', Snippet),
       (secretMD, Secret),
-      (colorMD, Colored White)
+      (colorMD, colored White)
     ]
 
-colors :: Map Text Color
+colors :: Map Text FormatColor
 colors =
-  M.fromList
+  M.fromList . map (second FormatColor) $
     [ ("red", Red),
       ("green", Green),
       ("blue", Blue),
@@ -79,6 +114,13 @@ colors =
       ("6", Magenta)
     ]
 
+parseMarkdownList :: Text -> MarkdownList
+parseMarkdownList = markdownToList . parseMarkdown
+
+markdownToList :: Markdown -> MarkdownList
+markdownToList (Markdown f s) = [FormattedText f s]
+markdownToList (m1 :|: m2) = markdownToList m1 <> markdownToList m2
+
 parseMarkdown :: Text -> Markdown
 parseMarkdown s = fromRight (unmarked s) $ A.parseOnly (markdownP <* A.endOfInput) s
 
@@ -94,25 +136,25 @@ markdownP = merge <$> A.many' fragmentP
         ' ' -> unmarked . T.cons ' ' <$> A.takeWhile (== ' ')
         c -> case M.lookup c formats of
           Just Secret -> secretP
-          Just (Colored White) -> coloredP
+          Just (Colored (FormatColor 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 c p f s) <|> noFormat (c `T.cons` p <> s)
-    markdown :: Char -> Text -> Format -> Text -> Markdown
-    markdown c p f s
+      (A.char c $> md c p f s) <|> noFormat (c `T.cons` p <> s)
+    md :: Char -> Text -> Format -> Text -> Markdown
+    md c p f s
       | T.null s || T.head s == ' ' || T.last s == ' ' =
         unmarked $ c `T.cons` p <> s `T.snoc` c
-      | otherwise = Markdown f s
+      | otherwise = markdown f s
     secretP :: Parser Markdown
     secretP = secret <$> A.takeWhile (== secretMD) <*> A.takeTill (== secretMD) <*> A.takeWhile (== secretMD)
     secret :: Text -> Text -> Text -> Markdown
     secret b s a
       | T.null a || T.null s || T.head s == ' ' || T.last s == ' ' =
         unmarked $ secretMD `T.cons` ss
-      | otherwise = Markdown Secret $ T.init ss
+      | otherwise = markdown Secret $ T.init ss
       where
         ss = b <> s <> a
     coloredP :: Parser Markdown

src/Simplex/Chat/Messages.hs

@@ -29,6 +29,7 @@ import Data.Typeable (Typeable)
 import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.ToField (ToField (..))
 import GHC.Generics (Generic)
+import Simplex.Chat.Markdown
 import Simplex.Chat.Protocol
 import Simplex.Chat.Types
 import Simplex.Chat.Util (eitherToMaybe, safeDecodeUtf8)
@@ -76,7 +77,8 @@ jsonChatInfo = \case
 data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem
   { chatDir :: CIDirection c d,
     meta :: CIMeta d,
-    content :: CIContent d
+    content :: CIContent d,
+    formattedText :: [FormattedText]
   }
   deriving (Show, Generic)
 
@@ -134,6 +136,13 @@ data ChatDirection (c :: ChatType) (d :: MsgDirection) where
   CDGroupSnd :: GroupInfo -> ChatDirection 'CTGroup 'MDSnd
   CDGroupRcv :: GroupInfo -> GroupMember -> ChatDirection 'CTGroup 'MDRcv
 
+toCIDirection :: ChatDirection c d -> CIDirection c d
+toCIDirection = \case
+  CDDirectSnd _ -> CIDirectSnd
+  CDDirectRcv _ -> CIDirectRcv
+  CDGroupSnd _ -> CIGroupSnd
+  CDGroupRcv _ m -> CIGroupRcv m
+
 data NewChatItem d = NewChatItem
   { createdByMsgId :: Maybe MessageId,
     itemSent :: SMsgDirection d,

src/Simplex/Chat/Store.hs

@@ -147,11 +147,11 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock (UTCTime (..), getCurrentTime)
 import Data.Time.LocalTime (TimeZone, getCurrentTimeZone)
-import Data.Type.Equality
 import Database.SQLite.Simple (NamedParam (..), Only (..), Query (..), SQLError, (:.) (..))
 import qualified Database.SQLite.Simple as DB
 import Database.SQLite.Simple.QQ (sql)
 import GHC.Generics (Generic)
+import Simplex.Chat.Markdown
 import Simplex.Chat.Messages
 import Simplex.Chat.Migrations.M20220101_initial
 import Simplex.Chat.Migrations.M20220122_v1_1
@@ -2184,13 +2184,14 @@ getChatPreviews st user =
     pure $ sortOn (Down . ts) (directChats <> groupChats <> cReqChats)
   where
     ts :: AChat -> UTCTime
-    ts (AChat _ (Chat _ (ci : _) _)) = chatItemTs ci
-    ts (AChat _ (Chat (DirectChat Contact {createdAt}) [] _)) = createdAt
-    ts (AChat _ (Chat (GroupChat GroupInfo {createdAt}) [] _)) = createdAt
-    ts (AChat _ (Chat (ContactRequest UserContactRequest {createdAt}) [] _)) = createdAt
+    ts (AChat _ Chat {chatItems = ci : _}) = chatItemTs ci
+    ts (AChat _ Chat {chatInfo}) = case chatInfo of
+      DirectChat Contact {createdAt} -> createdAt
+      GroupChat GroupInfo {createdAt} -> createdAt
+      ContactRequest UserContactRequest {createdAt} -> createdAt
 
 chatItemTs :: CChatItem d -> UTCTime
-chatItemTs (CChatItem _ (ChatItem _ CIMeta {itemTs} _)) = itemTs
+chatItemTs (CChatItem _ ChatItem {meta = CIMeta {itemTs}}) = itemTs
 
 getDirectChatPreviews_ :: DB.Connection -> User -> IO [AChat]
 getDirectChatPreviews_ db User {userId} = do
@@ -2703,14 +2704,12 @@ type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe ACIContent, Maybe
 toDirectChatItem :: TimeZone -> ChatItemRow -> Either StoreError (CChatItem 'CTDirect)
 toDirectChatItem tz (itemId, itemTs, itemContent, itemText, itemStatus, createdAt) =
   case (itemContent, itemStatus) of
-    (ACIContent d@SMDSnd ciContent, ACIStatus d'@SMDSnd ciStatus) -> case testEquality d d' of
-      Just Refl -> Right $ CChatItem d (ChatItem CIDirectSnd (ciMeta ciStatus) ciContent)
-      _ -> badItem
-    (ACIContent d@SMDRcv ciContent, ACIStatus d'@SMDRcv ciStatus) -> case testEquality d d' of
-      Just Refl -> Right $ CChatItem d (ChatItem CIDirectRcv (ciMeta ciStatus) ciContent)
-      _ -> badItem
+    (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus) -> Right $ cItem SMDSnd CIDirectSnd ciStatus ciContent
+    (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus) -> Right $ cItem SMDRcv CIDirectRcv ciStatus ciContent
     _ -> badItem
   where
+    cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection c d -> CIStatus d -> CIContent d -> CChatItem c
+    cItem d cid ciStatus ciContent = CChatItem d (ChatItem cid (ciMeta ciStatus) ciContent $ parseMarkdownList itemText)
     badItem = Left $ SEBadChatItem itemId
     ciMeta :: CIStatus d -> CIMeta d
     ciMeta status = mkCIMeta itemId itemText status tz itemTs createdAt
@@ -2728,14 +2727,12 @@ toGroupChatItem :: TimeZone -> Int64 -> GroupChatItemRow -> Either StoreError (C
 toGroupChatItem tz userContactId ((itemId, itemTs, itemContent, itemText, itemStatus, createdAt) :. memberRow_) = do
   let member_ = toMaybeGroupMember userContactId memberRow_
   case (itemContent, itemStatus, member_) of
-    (ACIContent d@SMDSnd ciContent, ACIStatus d'@SMDSnd ciStatus, Nothing) -> case testEquality d d' of
-      Just Refl -> Right $ CChatItem d (ChatItem CIGroupSnd (ciMeta ciStatus) ciContent)
-      _ -> badItem
-    (ACIContent d@SMDRcv ciContent, ACIStatus d'@SMDRcv ciStatus, Just member) -> case testEquality d d' of
-      Just Refl -> Right $ CChatItem d (ChatItem (CIGroupRcv member) (ciMeta ciStatus) ciContent)
-      _ -> badItem
+    (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, Nothing) -> Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent
+    (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member) -> Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent
     _ -> badItem
   where
+    cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection c d -> CIStatus d -> CIContent d -> CChatItem c
+    cItem d cid ciStatus ciContent = CChatItem d (ChatItem cid (ciMeta ciStatus) ciContent $ parseMarkdownList itemText)
     badItem = Left $ SEBadChatItem itemId
     ciMeta :: CIStatus d -> CIMeta d
     ciMeta status = mkCIMeta itemId itemText status tz itemTs createdAt

src/Simplex/Chat/Styled.hs

@@ -5,7 +5,7 @@ module Simplex.Chat.Styled
   ( StyledString (..),
     StyledFormat (..),
     styleMarkdown,
-    styleMarkdownText,
+    styleMarkdownList,
     unStyle,
     sLength,
     sShow,
@@ -29,14 +29,20 @@ instance Monoid StyledString where mempty = plain ""
 
 instance IsString StyledString where fromString = plain
 
-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
+styleMarkdown (Markdown f s) = styleFormat f s
+
+styleMarkdownList :: MarkdownList -> StyledString
+styleMarkdownList [] = plain ""
+styleMarkdownList [FormattedText f s] = styleFormat f s
+styleMarkdownList (FormattedText f s : ts) = styleFormat f s <> styleMarkdownList ts
+
+styleFormat :: Maybe Format -> Text -> StyledString
+styleFormat (Just Snippet) s = '`' `wrap` styled Snippet s
+styleFormat (Just Secret) s = '#' `wrap` styled Secret s
+styleFormat (Just f) s = styled f s
+styleFormat Nothing s = plain s
 
 wrap :: Char -> StyledString -> StyledString
 wrap c s = plain [c] <> s <> plain [c]
@@ -66,10 +72,9 @@ sgr = \case
   Italic -> [SetUnderlining SingleUnderline, SetItalicized True]
   Underline -> [SetUnderlining SingleUnderline]
   StrikeThrough -> [SetSwapForegroundBackground True]
-  Colored c -> [SetColor Foreground Vivid c]
+  Colored (FormatColor c) -> [SetColor Foreground Vivid c]
   Secret -> [SetColor Foreground Dull Black, SetColor Background Dull Black]
   Snippet -> []
-  NoFormat -> []
 
 unStyle :: StyledString -> String
 unStyle (Styled _ s) = s

src/Simplex/Chat/View.hs

@@ -7,6 +7,7 @@
 
 module Simplex.Chat.View where
 
+import qualified Data.Aeson as J
 import Data.Function (on)
 import Data.Int (Int64)
 import Data.List (groupBy, intersperse, sortOn)
@@ -27,6 +28,7 @@ import Simplex.Chat.Types
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Encoding.String
 import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Util (bshow)
 import System.Console.ANSI.Types
 
 serializeChatResponse :: ChatResponse -> String
@@ -36,8 +38,8 @@ responseToView :: Bool -> ChatResponse -> [StyledString]
 responseToView testView = \case
   CRActiveUser User {profile} -> viewUserProfile profile
   CRChatStarted -> ["chat started"]
-  CRApiChats chats -> if testView then testViewChats chats else [sShow chats]
-  CRApiChat chat -> if testView then testViewChat chat else [sShow chat]
+  CRApiChats chats -> if testView then testViewChats chats else [plain . bshow $ J.encode chats]
+  CRApiChat chat -> if testView then testViewChat chat else [plain . bshow $ J.encode chat]
   CRNewChatItem (AChatItem _ _ chat item) -> viewChatItem chat item
   CRChatItemUpdated _ -> []
   CRMsgIntegrityError mErr -> viewMsgIntegrityError mErr
@@ -140,7 +142,7 @@ responseToView testView = \case
         toChatView (CChatItem dir ChatItem {meta}) = (msgDirectionInt $ toMsgDirection dir, itemText meta)
 
 viewChatItem :: ChatInfo c -> ChatItem c d -> [StyledString]
-viewChatItem chat (ChatItem cd meta content) = case (chat, cd) of
+viewChatItem chat (ChatItem cd meta content _) = case (chat, cd) of
   (DirectChat c, CIDirectSnd) -> case content of
     CISndMsgContent mc -> viewSentMessage to mc meta
     CISndFileInvitation fId fPath -> viewSentFileInvitation to fId fPath meta
@@ -176,7 +178,7 @@ viewMsgIntegrityError err = msgError $ case err of
   MsgDuplicate -> "duplicate message ID"
   where
     msgError :: String -> [StyledString]
-    msgError s = [styled (Colored Red) s]
+    msgError s = [styled (colored Red) s]
 
 viewInvalidConnReq :: [StyledString]
 viewInvalidConnReq =
@@ -369,7 +371,7 @@ prependFirst s [] = [s]
 prependFirst s (s' : ss) = (s <> s') : ss
 
 msgPlain :: Text -> [StyledString]
-msgPlain = map styleMarkdownText . T.lines
+msgPlain = map (styleMarkdownList . parseMarkdownList) . T.lines
 
 viewRcvFileSndCancelled :: RcvFileTransfer -> [StyledString]
 viewRcvFileSndCancelled ft@RcvFileTransfer {senderDisplayName = c} =
@@ -515,7 +517,7 @@ viewChatError = \case
     fileNotFound fileId = ["file " <> sShow fileId <> " not found"]
 
 ttyContact :: ContactName -> StyledString
-ttyContact = styled (Colored Green)
+ttyContact = styled (colored Green)
 
 ttyContact' :: Contact -> StyledString
 ttyContact' Contact {localDisplayName = c} = ttyContact c
@@ -535,13 +537,13 @@ ttyFullName :: ContactName -> Text -> StyledString
 ttyFullName c fullName = ttyContact c <> optFullName c fullName
 
 ttyToContact :: ContactName -> StyledString
-ttyToContact c = styled (Colored Cyan) $ "@" <> c <> " "
+ttyToContact c = styled (colored Cyan) $ "@" <> c <> " "
 
 ttyFromContact :: ContactName -> StyledString
-ttyFromContact c = styled (Colored Yellow) $ c <> "> "
+ttyFromContact c = styled (colored Yellow) $ c <> "> "
 
 ttyGroup :: GroupName -> StyledString
-ttyGroup g = styled (Colored Blue) $ "#" <> g
+ttyGroup g = styled (colored Blue) $ "#" <> g
 
 ttyGroup' :: GroupInfo -> StyledString
 ttyGroup' = ttyGroup . groupName'
@@ -556,10 +558,10 @@ ttyFullGroup GroupInfo {localDisplayName = g, groupProfile = GroupProfile {fullN
   ttyGroup g <> optFullName g fullName
 
 ttyFromGroup :: GroupInfo -> ContactName -> StyledString
-ttyFromGroup GroupInfo {localDisplayName = g} c = styled (Colored Yellow) $ "#" <> g <> " " <> c <> "> "
+ttyFromGroup GroupInfo {localDisplayName = g} c = styled (colored Yellow) $ "#" <> g <> " " <> c <> "> "
 
 ttyToGroup :: GroupInfo -> StyledString
-ttyToGroup GroupInfo {localDisplayName = g} = styled (Colored Cyan) $ "#" <> g <> " "
+ttyToGroup GroupInfo {localDisplayName = g} = styled (colored Cyan) $ "#" <> g <> " "
 
 ttyFilePath :: FilePath -> StyledString
 ttyFilePath = plain
@@ -570,7 +572,7 @@ optFullName localDisplayName fullName
   | otherwise = plain (" (" <> fullName <> ")")
 
 highlight :: StyledFormat a => a -> StyledString
-highlight = styled (Colored Cyan)
+highlight = styled (colored Cyan)
 
 highlight' :: String -> StyledString
 highlight' = highlight

tests/MarkdownTests.hs

@@ -18,19 +18,19 @@ textFormat :: Spec
 textFormat = describe "text format (bold)" do
   it "correct markdown" do
     parseMarkdown "this is *bold formatted* text"
-      `shouldBe` "this is " <> Markdown Bold "bold formatted" <> " " <> "text"
+      `shouldBe` "this is " <> markdown Bold "bold formatted" <> " " <> "text"
     parseMarkdown "*bold formatted* text"
-      `shouldBe` Markdown Bold "bold formatted" <> " " <> "text"
+      `shouldBe` markdown Bold "bold formatted" <> " " <> "text"
     parseMarkdown "this is *bold*"
-      `shouldBe` "this is " <> Markdown Bold "bold"
+      `shouldBe` "this is " <> markdown Bold "bold"
     parseMarkdown " *bold* text"
-      `shouldBe` " " <> Markdown Bold "bold" <> " " <> "text"
+      `shouldBe` " " <> markdown Bold "bold" <> " " <> "text"
     parseMarkdown "   *bold* text"
-      `shouldBe` "   " <> Markdown Bold "bold" <> " " <> "text"
+      `shouldBe` "   " <> markdown Bold "bold" <> " " <> "text"
     parseMarkdown "this is *bold* "
-      `shouldBe` "this is " <> Markdown Bold "bold" <> " "
+      `shouldBe` "this is " <> markdown Bold "bold" <> " "
     parseMarkdown "this is *bold*   "
-      `shouldBe` "this is " <> Markdown Bold "bold" <> "   "
+      `shouldBe` "this is " <> markdown Bold "bold" <> "   "
   it "ignored as markdown" do
     parseMarkdown "this is * unformatted * text"
       `shouldBe` "this is " <> "* unformatted *" <> " " <> "text"
@@ -46,31 +46,31 @@ textFormat = describe "text format (bold)" do
       `shouldBe` "this is " <> "*unformatted text"
   it "ignored internal markdown" do
     parseMarkdown "this is *long _bold_ (not italic)* text"
-      `shouldBe` "this is " <> Markdown Bold "long _bold_ (not italic)" <> " " <> "text"
+      `shouldBe` "this is " <> markdown Bold "long _bold_ (not italic)" <> " " <> "text"
     parseMarkdown "snippet: `this is *bold text*`"
-      `shouldBe` "snippet: " <> Markdown Snippet "this is *bold text*"
+      `shouldBe` "snippet: " <> markdown Snippet "this is *bold text*"
 
 secretText :: Spec
 secretText = describe "secret text" do
   it "correct markdown" do
     parseMarkdown "this is #black_secret# text"
-      `shouldBe` "this is " <> Markdown Secret "black_secret" <> " " <> "text"
+      `shouldBe` "this is " <> markdown Secret "black_secret" <> " " <> "text"
     parseMarkdown "##black_secret### text"
-      `shouldBe` Markdown Secret "#black_secret##" <> " " <> "text"
+      `shouldBe` markdown Secret "#black_secret##" <> " " <> "text"
     parseMarkdown "this is #black secret# text"
-      `shouldBe` "this is " <> Markdown Secret "black secret" <> " " <> "text"
+      `shouldBe` "this is " <> markdown Secret "black secret" <> " " <> "text"
     parseMarkdown "##black secret### text"
-      `shouldBe` Markdown Secret "#black secret##" <> " " <> "text"
+      `shouldBe` markdown Secret "#black secret##" <> " " <> "text"
     parseMarkdown "this is #secret#"
-      `shouldBe` "this is " <> Markdown Secret "secret"
+      `shouldBe` "this is " <> markdown Secret "secret"
     parseMarkdown " #secret# text"
-      `shouldBe` " " <> Markdown Secret "secret" <> " " <> "text"
+      `shouldBe` " " <> markdown Secret "secret" <> " " <> "text"
     parseMarkdown "   #secret# text"
-      `shouldBe` "   " <> Markdown Secret "secret" <> " " <> "text"
+      `shouldBe` "   " <> markdown Secret "secret" <> " " <> "text"
     parseMarkdown "this is #secret# "
-      `shouldBe` "this is " <> Markdown Secret "secret" <> " "
+      `shouldBe` "this is " <> markdown Secret "secret" <> " "
     parseMarkdown "this is #secret#   "
-      `shouldBe` "this is " <> Markdown Secret "secret" <> "   "
+      `shouldBe` "this is " <> markdown Secret "secret" <> "   "
   it "ignored as markdown" do
     parseMarkdown "this is # unformatted # text"
       `shouldBe` "this is " <> "# unformatted #" <> " " <> "text"
@@ -86,10 +86,10 @@ secretText = describe "secret text" do
       `shouldBe` "this is " <> "#unformatted text"
   it "ignored internal markdown" do
     parseMarkdown "snippet: `this is #secret_text#`"
-      `shouldBe` "snippet: " <> Markdown Snippet "this is #secret_text#"
+      `shouldBe` "snippet: " <> markdown Snippet "this is #secret_text#"
 
 red :: Text -> Markdown
-red = Markdown (Colored Red)
+red = markdown (colored Red)
 
 textColor :: Spec
 textColor = describe "text color (red)" do
@@ -125,4 +125,4 @@ textColor = describe "text color (red)" do
     parseMarkdown "this is !1 long *red* (not bold)! text"
       `shouldBe` "this is " <> red "long *red* (not bold)" <> " " <> "text"
     parseMarkdown "snippet: `this is !1 red text!`"
-      `shouldBe` "snippet: " <> Markdown Snippet "this is !1 red text!"
+      `shouldBe` "snippet: " <> markdown Snippet "this is !1 red text!"