dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-05-25 04:15:31 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: MsgContent for link previews, API to parse markdown (#504)

Browse Source
This commit is contained in:
Evgeny Poberezkin
2022-04-04 19:51:49 +01:00
committed by GitHub
parent 0ecaa59df6
commit 7012005feb
8 changed files with 54 additions and 24 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat.hs
+3 -1
View File
@@ -301,6 +301,7 @@ processChatCommand = \case
withAgent $ \a -> rejectContact a connId invId
pure $ CRContactRequestRejected cReq
APIUpdateProfile profile -> withUser (`updateProfile` profile)
APIParseMarkdown text -> pure . CRApiParsedMarkdown $ parseMaybeMarkdownList text
GetUserSMPServers -> CRUserSMPServers <$> withUser (\user -> withStore (`getSMPServers` user))
SetUserSMPServers smpServers -> withUser $ \user -> withChatLock $ do
withStore $ \st -> overwriteSMPServers st user smpServers
@@ -1662,6 +1663,7 @@ chatCommandP =
<|> "/_accept " *> (APIAcceptContact <$> A.decimal)
<|> "/_reject " *> (APIRejectContact <$> A.decimal)
<|> "/_profile " *> (APIUpdateProfile <$> jsonP)
<|> "/_parse " *> (APIParseMarkdown . safeDecodeUtf8 <$> A.takeByteString)
<|> "/smp_servers default" $> SetUserSMPServers []
<|> "/smp_servers " *> (SetUserSMPServers <$> smpServersP)
<|> "/smp_servers" $> GetUserSMPServers
@@ -1707,7 +1709,7 @@ chatCommandP =
<|> ("/reject @" <|> "/reject " <|> "/rc @" <|> "/rc ") *> (RejectContact <$> displayName)
<|> ("/markdown" <|> "/m") $> ChatHelp HSMarkdown
<|> ("/welcome" <|> "/w") $> Welcome
<|> "/profile_image " *> (UpdateProfileImage . Just . ProfileImage <$> imageP)
<|> "/profile_image " *> (UpdateProfileImage . Just . ImageData <$> imageP)
<|> "/profile_image" $> UpdateProfileImage Nothing
<|> ("/profile " <|> "/p ") *> (uncurry UpdateProfile <$> userNames)
<|> ("/profile" <|> "/p") $> ShowProfile
src/Simplex/Chat/Controller.hs
+4 -1
View File
@@ -25,6 +25,7 @@ import Data.Version (showVersion)
import GHC.Generics (Generic)
import Numeric.Natural
import qualified Paths_simplex_chat as SC
import Simplex.Chat.Markdown (MarkdownList)
import Simplex.Chat.Messages
import Simplex.Chat.Protocol
import Simplex.Chat.Store (StoreError)
@@ -102,6 +103,7 @@ data ChatCommand
| APIAcceptContact Int64
| APIRejectContact Int64
| APIUpdateProfile Profile
| APIParseMarkdown Text
| GetUserSMPServers
| SetUserSMPServers [SMPServer]
| ChatHelp HelpSection
@@ -142,7 +144,7 @@ data ChatCommand
| FileStatus FileTransferId
| ShowProfile
| UpdateProfile ContactName Text
| UpdateProfileImage (Maybe ProfileImage)
| UpdateProfileImage (Maybe ImageData)
| QuitChat
| ShowVersion
deriving (Show)
@@ -153,6 +155,7 @@ data ChatResponse
| CRChatRunning
| CRApiChats {chats :: [AChat]}
| CRApiChat {chat :: AChat}
| CRApiParsedMarkdown {formattedText :: Maybe MarkdownList}
| CRUserSMPServers {smpServers :: [SMPServer]}
| CRNewChatItem {chatItem :: AChatItem}
| CRChatItemStatusUpdated {chatItem :: AChatItem}
src/Simplex/Chat/Protocol.hs
+22 -1
View File
@@ -147,14 +147,16 @@ cmToQuotedMsg = \case
XMsgNew (MCQuote quotedMsg _) -> Just quotedMsg
_ -> Nothing
data MsgContentTag = MCText_ | MCUnknown_ Text
data MsgContentTag = MCText_ | MCLink_ | MCUnknown_ Text
instance StrEncoding MsgContentTag where
strEncode = \case
MCText_ -> "text"
MCLink_ -> "link"
MCUnknown_ t -> encodeUtf8 t
strDecode = \case
"text" -> Right MCText_
"link" -> Right MCLink_
t -> Right . MCUnknown_ $ safeDecodeUtf8 t
strP = strDecode <$?> A.takeTill (== ' ')
@@ -177,19 +179,32 @@ mcContent = \case
MCQuote _ c -> c
MCForward c -> c
data LinkPreview = LinkPreview {uri :: Text, title :: Text, description :: Text, image :: ImageData}
deriving (Eq, Show, Generic)
instance FromJSON LinkPreview where
parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
instance ToJSON LinkPreview where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data MsgContent
= MCText Text
| MCLink {text :: Text, preview :: LinkPreview}
| MCUnknown {tag :: Text, text :: Text, json :: J.Object}
deriving (Eq, Show)
msgContentText :: MsgContent -> Text
msgContentText = \case
MCText t -> t
MCLink {text} -> text
MCUnknown {text} -> text
msgContentTag :: MsgContent -> MsgContentTag
msgContentTag = \case
MCText _ -> MCText_
MCLink {} -> MCLink_
MCUnknown {tag} -> MCUnknown_ tag
parseMsgContainer :: J.Object -> JT.Parser MsgContainer
@@ -204,6 +219,10 @@ instance FromJSON MsgContent where
parseJSON (J.Object v) =
v .: "type" >>= \case
MCText_ -> MCText <$> v .: "text"
MCLink_ -> do
text <- v .: "text"
preview <- v .: "preview"
pure MCLink {text, preview}
MCUnknown_ tag -> do
text <- fromMaybe unknownMsgType <$> v .:? "text"
pure MCUnknown {tag, text, json = v}
@@ -223,9 +242,11 @@ instance ToJSON MsgContent where
toJSON = \case
MCUnknown {json} -> J.Object json
MCText t -> J.object ["type" .= MCText_, "text" .= t]
MCLink {text, preview} -> J.object ["type" .= MCLink_, "text" .= text, "preview" .= preview]
toEncoding = \case
MCUnknown {json} -> JE.value $ J.Object json
MCText t -> J.pairs $ "type" .= MCText_ <> "text" .= t
MCLink {text, preview} -> J.pairs $ "type" .= MCLink_ <> "text" .= text <> "preview" .= preview
instance ToField MsgContent where
toField = toField . safeDecodeUtf8 . LB.toStrict . J.encode
src/Simplex/Chat/Store.hs
+8 -8
View File
@@ -269,7 +269,7 @@ getUsers st =
JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id
|]
toUser :: (UserId, Int64, Bool, ContactName, Text, Maybe ProfileImage) -> User
toUser :: (UserId, Int64, Bool, ContactName, Text, Maybe ImageData) -> User
toUser (userId, userContactId, activeUser, displayName, fullName, image) =
let profile = Profile {displayName, fullName, image}
in User {userId, userContactId, localDisplayName = displayName, profile, activeUser}
@@ -482,7 +482,7 @@ updateContact_ db userId contactId displayName newName updatedAt = do
(newName, updatedAt, userId, contactId)
DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (displayName, userId)
type ContactRow = (Int64, ContactName, Maybe Int64, ContactName, Text, Maybe ProfileImage, UTCTime)
type ContactRow = (Int64, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, UTCTime)
toContact :: ContactRow :. ConnectionRow -> Contact
toContact ((contactId, localDisplayName, viaGroup, displayName, fullName, image, createdAt) :. connRow) =
@@ -758,7 +758,7 @@ getContactRequest_ db userId contactRequestId =
|]
(userId, contactRequestId)
type ContactRequestRow = (Int64, ContactName, AgentInvId, Int64, AgentConnId, Int64, ContactName, Text, Maybe ProfileImage, UTCTime, Maybe XContactId)
type ContactRequestRow = (Int64, ContactName, AgentInvId, Int64, AgentConnId, Int64, ContactName, Text, Maybe ImageData, UTCTime, Maybe XContactId)
toContactRequest :: ContactRequestRow -> UserContactRequest
toContactRequest (contactRequestId, localDisplayName, agentInvitationId, userContactLinkId, agentContactConnId, profileId, displayName, fullName, image, createdAt, xContactId) = do
@@ -1092,7 +1092,7 @@ getConnectionEntity st User {userId, userContactId} agentConnId =
WHERE c.user_id = ? AND c.contact_id = ?
|]
(userId, contactId)
toContact' :: Int64 -> Connection -> [(ContactName, Text, Text, Maybe ProfileImage, Maybe Int64, UTCTime)] -> Either StoreError Contact
toContact' :: Int64 -> Connection -> [(ContactName, Text, Text, Maybe ImageData, Maybe Int64, UTCTime)] -> Either StoreError Contact
toContact' contactId activeConn [(localDisplayName, displayName, fullName, image, viaGroup, createdAt)] =
let profile = Profile {displayName, fullName, image}
in Right $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup, createdAt}
@@ -1286,7 +1286,7 @@ getGroupInfoByName st user gName =
gId <- ExceptT $ getGroupIdByName_ db user gName
ExceptT $ getGroupInfo_ db user gId
type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe ProfileImage, UTCTime) :. GroupMemberRow
type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe ImageData, UTCTime) :. GroupMemberRow
toGroupInfo :: Int64 -> GroupInfoRow -> GroupInfo
toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, image, createdAt) :. userMemberRow) =
@@ -1344,9 +1344,9 @@ getGroupInvitation st user localDisplayName =
findFromContact (IBContact contactId) = find ((== Just contactId) . memberContactId)
findFromContact _ = const Nothing
type GroupMemberRow = (Int64, Int64, MemberId, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Maybe Int64, ContactName, Maybe Int64, ContactName, Text, Maybe ProfileImage)
type GroupMemberRow = (Int64, Int64, MemberId, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Maybe Int64, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData)
type MaybeGroupMemberRow = (Maybe Int64, Maybe Int64, Maybe MemberId, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe Int64, Maybe ContactName, Maybe Int64, Maybe ContactName, Maybe Text, Maybe ProfileImage)
type MaybeGroupMemberRow = (Maybe Int64, Maybe Int64, Maybe MemberId, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe Int64, Maybe ContactName, Maybe Int64, Maybe ContactName, Maybe Text, Maybe ImageData)
toGroupMember :: Int64 -> GroupMemberRow -> GroupMember
toGroupMember userContactId (groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, localDisplayName, memberContactId, displayName, fullName, image) =
@@ -1724,7 +1724,7 @@ getViaGroupContact st User {userId} GroupMember {groupMemberId} =
|]
(userId, groupMemberId)
where
toContact' :: [(Int64, ContactName, Text, Text, Maybe ProfileImage, Maybe Int64, UTCTime) :. ConnectionRow] -> Maybe Contact
toContact' :: [(Int64, ContactName, Text, Text, Maybe ImageData, Maybe Int64, UTCTime) :. ConnectionRow] -> Maybe Contact
toContact' [(contactId, localDisplayName, displayName, fullName, image, viaGroup, createdAt) :. connRow] =
let profile = Profile {displayName, fullName, image}
activeConn = toConnection connRow
src/Simplex/Chat/Types.hs
+10 -10
View File
@@ -171,7 +171,7 @@ groupName' GroupInfo {localDisplayName = g} = g
data Profile = Profile
{ displayName :: ContactName,
fullName :: Text,
image :: Maybe ProfileImage
image :: Maybe ImageData
}
deriving (Eq, Show, Generic, FromJSON)
@@ -182,7 +182,7 @@ instance ToJSON Profile where
data GroupProfile = GroupProfile
{ displayName :: GroupName,
fullName :: Text,
image :: Maybe ProfileImage
image :: Maybe ImageData
}
deriving (Eq, Show, Generic, FromJSON)
@@ -190,19 +190,19 @@ instance ToJSON GroupProfile where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
newtype ProfileImage = ProfileImage Text
newtype ImageData = ImageData Text
deriving (Eq, Show)
instance FromJSON ProfileImage where
parseJSON = fmap ProfileImage . J.parseJSON
instance FromJSON ImageData where
parseJSON = fmap ImageData . J.parseJSON
instance ToJSON ProfileImage where
toJSON (ProfileImage t) = J.toJSON t
toEncoding (ProfileImage t) = J.toEncoding t
instance ToJSON ImageData where
toJSON (ImageData t) = J.toJSON t
toEncoding (ImageData t) = J.toEncoding t
instance ToField ProfileImage where toField (ProfileImage t) = toField t
instance ToField ImageData where toField (ImageData t) = toField t
instance FromField ProfileImage where fromField = fmap ProfileImage . fromField
instance FromField ImageData where fromField = fmap ImageData . fromField
data GroupInvitation = GroupInvitation
{ fromMember :: MemberIdRole,
src/Simplex/Chat/View.hs
+1
View File
@@ -46,6 +46,7 @@ responseToView testView = \case
CRChatRunning -> []
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]
CRApiParsedMarkdown ft -> [plain . bshow $ J.encode ft]
CRUserSMPServers smpServers -> viewSMPServers smpServers testView
CRNewChatItem (AChatItem _ _ chat item) -> viewChatItem chat item
CRChatItemStatusUpdated _ -> []