diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 010cabc3d8..fc163dc3dd 100644 --- a/src/Simplex/Chat.hs +++ b/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 = diff --git a/src/Simplex/Chat/Help.hs b/src/Simplex/Chat/Help.hs index bf17b1b1fa..aa9f7b9a36 100644 --- a/src/Simplex/Chat/Help.hs +++ b/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)" ] diff --git a/src/Simplex/Chat/Markdown.hs b/src/Simplex/Chat/Markdown.hs index 82aa84c631..1e1809d548 100644 --- a/src/Simplex/Chat/Markdown.hs +++ b/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 diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 92b96b699e..40c5fb4af4 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/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, diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 757b639407..5c749dd5f1 100644 --- a/src/Simplex/Chat/Store.hs +++ b/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 diff --git a/src/Simplex/Chat/Styled.hs b/src/Simplex/Chat/Styled.hs index aaed7a4f7f..3f7cf261b6 100644 --- a/src/Simplex/Chat/Styled.hs +++ b/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 diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 1201c54758..474365270b 100644 --- a/src/Simplex/Chat/View.hs +++ b/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 diff --git a/tests/MarkdownTests.hs b/tests/MarkdownTests.hs index e236307b81..43ef1a47c0 100644 --- a/tests/MarkdownTests.hs +++ b/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!"