dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-03-30 20:45:49 +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

4
src/Simplex/Chat.hs
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

5
src/Simplex/Chat/Controller.hs
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}

23
src/Simplex/Chat/Protocol.hs
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

16
src/Simplex/Chat/Store.hs
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

20
src/Simplex/Chat/Types.hs
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,

1
src/Simplex/Chat/View.hs
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 _ -> []

4
tests/ChatTests.hs
View File

@@ -13,7 +13,7 @@ import qualified Data.ByteString as B
import Data.Char (isDigit)
import qualified Data.Text as T
import Simplex.Chat.Controller (ChatController (..))
import Simplex.Chat.Types (Profile (..), ProfileImage (..), User (..))
import Simplex.Chat.Types (ImageData (..), Profile (..), User (..))
import Simplex.Chat.Util (unlessM)
import System.Directory (doesFileExist)
import Test.Hspec
@@ -22,7 +22,7 @@ aliceProfile :: Profile
aliceProfile = Profile {displayName = "alice", fullName = "Alice", image = Nothing}
bobProfile :: Profile
bobProfile = Profile {displayName = "bob", fullName = "Bob", image = Just (ProfileImage "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABgAAAAYCAYAAADgdz34AAAKHGlDQ1BJQ0MgUHJvZmlsZQAASImFVgdUVNcWve9Nb7QZeu9NehtAem/Sq6gMQ28OQxWxgAQjEFFEREARNFQFg1KjiIhiIQgoYA9IEFBisCAq6OQNJNH4//r/zDpz9ttzz7n73ffWmg0A6QCDxYqD+QCIT0hmezlYywQEBsngngEYCAIy0AC6DGYSy8rDwxUg8Xf9d7wbAxC33tHgzvrP3/9nCISFJzEBgIIRTGey2MkILkawT1oyi4tnEUxjI6IQvMLFkauYqxjQQtewwuoaHy8bBNMBwJMZDHYkAERbhJdJZUYic4hhCNZOCItOQDB3vjkzioFwxLsIXhcRl5IOAImrRzs+fivCk7QRrIL0shAcwNUW+tX8yH/tFfrPXgxG5D84Pi6F+dc9ck+HHJ7g641UMSQlQATQBHEgBaQDGcACbLAVYaIRJhx5Dv+9j77aZ4OsZIFtSEc0iARRIBnpt/9qlvfqpGSQBhjImnCEcUU+NtxnujZy4fbqVEiU/wuXdQyA9S0cDqfzC+e2F4DzyLkSB79wyi0A8KoBcL2GmcJOXePQ3C8MIAJeQAOiQArIAxXuWwMMgSmwBHbAGbgDHxAINgMmojceUZUGMkEWyAX54AA4DMpAJTgJ6sAZ0ALawQVwGVwDt8AQGAUPwQSYBi/AAngHliEIwkEUiAqJQtKQIqQO6UJ0yByyg1whLygQCoEioQQoBcqE9kD5UBFUBlVB9dBPUCd0GboBDUP3oUloDnoNfYRRMBmmwZKwEqwF02Er2AX2gTfBkXAinAHnwPvhUrgaPg23wZfhW/AoPAG/gBdRAEVCCaFkURooOsoG5Y4KQkWg2KidqDxUCaoa1YTqQvWj7qAmUPOoD2gsmoqWQWugTdGOaF80E52I3okuQJeh69Bt6D70HfQkegH9GUPBSGDUMSYYJ0wAJhKThsnFlGBqMK2Yq5hRzDTmHRaLFcIqY42wjthAbAx2O7YAewzbjO3BDmOnsIs4HE4Up44zw7njGLhkXC7uKO407hJuBDeNe48n4aXxunh7fBA+AZ+NL8E34LvxI/gZ/DKBj6BIMCG4E8II2wiFhFOELsJtwjRhmchPVCaaEX2IMcQsYimxiXiV+Ij4hkQiyZGMSZ6kaNJuUinpLOk6aZL0gSxAViPbkIPJKeT95FpyD/k++Q2FQlGiWFKCKMmU/ZR6yhXKE8p7HiqPJo8TTxjPLp5ynjaeEZ6XvAReRV4r3s28GbwlvOd4b/PO8xH4lPhs+Bh8O/nK+Tr5xvkW+an8Ovzu/PH8BfwN/Df4ZwVwAkoCdgJhAjkCJwWuCExRUVR5qg2VSd1DPUW9Sp2mYWnKNCdaDC2fdoY2SFsQFBDUF/QTTBcsF7woOCGEElISchKKEyoUahEaE/ooLClsJRwuvE+4SXhEeElEXMRSJFwkT6RZZFTko6iMqJ1orOhB0XbRx2JoMTUxT7E0seNiV8XmxWnipuJM8TzxFvEHErCEmoSXxHaJkxIDEouSUpIOkizJo5JXJOelhKQspWKkiqW6peakqdLm0tHSxdKXpJ/LCMpYycTJlMr0ySzISsg6yqbIVskOyi7LKcv5ymXLNcs9lifK0+Uj5Ivle+UXFKQV3BQyFRoVHigSFOmKUYpHFPsVl5SUlfyV9iq1K80qiyg7KWcoNyo/UqGoWKgkqlSr3FXFqtJVY1WPqQ6pwWoGalFq5Wq31WF1Q/Vo9WPqw+sw64zXJayrXjeuQdaw0kjVaNSY1BTSdNXM1mzXfKmloBWkdVCrX+uztoF2nPYp7Yc6AjrOOtk6XTqvddV0mbrlunf1KHr2erv0OvRe6avrh+sf179nQDVwM9hr0GvwydDIkG3YZDhnpGAUYlRhNE6n0T3oBfTrxhhja+NdxheMP5gYmiSbtJj8YaphGmvaYDq7Xnl9+PpT66fM5MwYZlVmE+Yy5iHmJ8wnLGQtGBbVFk8t5S3DLGssZ6xUrWKsTlu9tNa2Zlu3Wi/ZmNjssOmxRdk62ObZDtoJ2Pnaldk9sZezj7RvtF9wMHDY7tDjiHF0cTzoOO4k6cR0qndacDZy3uHc50J28XYpc3nqqubKdu1yg92c3Q65PdqguCFhQ7s7cHdyP+T+2EPZI9HjZ0+sp4dnueczLx2vTK9+b6r3Fu8G73c+1j6FPg99VXxTfHv9eP2C/er9lvxt/Yv8JwK0AnYE3AoUC4wO7AjCBfkF1QQtbrTbeHjjdLBBcG7w2CblTembbmwW2xy3+eIW3i2MLedCMCH+IQ0hKwx3RjVjMdQptCJ0gWnDPMJ8EWYZVhw2F24WXhQ+E2EWURQxG2kWeShyLsoiqiRqPtomuiz6VYxjTGXMUqx7bG0sJ84/rjkeHx8S35kgkBCb0LdVamv61mGWOiuXNZFokng4cYHtwq5JgpI2JXUk05A/0oEUlZTvUiZTzVPLU9+n+aWdS+dPT0gf2Ka2bd+2mQz7jB+3o7czt/dmymZmZU7usNpRtRPaGbqzd5f8rpxd07sddtdlEbNis37J1s4uyn67x39PV45kzu6cqe8cvmvM5cll547vNd1b+T36++jvB/fp7Tu673NeWN7NfO38kvyVAmbBzR90fij9gbM/Yv9goWHh8QPYAwkHxg5aHKwr4i/KKJo65HaorVimOK/47eEth2+U6JdUHiEeSTkyUepa2nFU4eiBoytlUWWj5dblzRUSFfsqlo6FHRs5bnm8qVKyMr/y44noE/eqHKraqpWqS05iT6aefHbK71T/j/Qf62vEavJrPtUm1E7UedX11RvV1zdINBQ2wo0pjXOng08PnbE909Gk0VTVLNScfxacTTn7/KeQn8ZaXFp6z9HPNZ1XPF/RSm3Na4PatrUttEe1T3QEdgx3Onf2dpl2tf6s+XPtBdkL5RcFLxZ2E7tzujmXMi4t9rB65i9HXp7q3dL78ErAlbt9nn2DV12uXr9mf+1Kv1X/petm1y/cMLnReZN+s/2W4a22AYOB1l8MfmkdNBxsu210u2PIeKhreP1w94jFyOU7tneu3XW6e2t0w+jwmO/YvfHg8Yl7Yfdm78fdf/Ug9cHyw92PMI/yHvM9Lnki8aT6V9VfmycMJy5O2k4OPPV++nCKOfXit6TfVqZznlGelcxIz9TP6s5emLOfG3q+8fn0C9aL5fnc3/l/r3ip8vL8H5Z/DCwELEy/Yr/ivC54I/qm9q3+295Fj8Un7+LfLS/lvRd9X/eB/qH/o//HmeW0FdxK6SfVT12fXT4/4sRzOCwGm7FqBVBIwhERALyuBYASCAB1CPEPG9f8119+BvrK2fyNwVndL5jhvubRVsMQgCakeCFp04OsQ1LJEgAe5NodqT6WANbT+yf/iqQIPd21PXgaAcDJcjivtwJAQHLFgcNZ9uBwPlUgYhHf1z37f7V9g9e8ITewiP88wfWIYET6HPg21nzjV2fybQVcxfrg2/onng/F50lD/ccAAAA4ZVhJZk1NACoAAAAIAAGHaQAEAAAAAQAAABoAAAAAAAKgAgAEAAAAAQAAABigAwAEAAAAAQAAABgAAAAAwf1XlwAAAaNJREFUSA3FlT1LA0EQQBN/gYUYRTksJZVgEbCR/D+7QMr8ABtttBBCsLGzsLG2sxaxED/ie4d77u0dyaE5HHjczn7MzO7M7nU6/yXz+bwLhzCCjTQO+rZhDH3opuNLdRYN4RHe4RIKJ7R34Ro+4AEGSw2mE1iUwT18gpI74WvkGlccu4XNdH0jnYU7cAUacidn37qR23cOxc4aGU0nYUAn7iSWEHkz46w0ocdQu1X6B/AMQZ5o7KfBqNOfwRH8JB7FajGhnmcpKvQe3MEbvILiDm5gPXaCHnZr4vvFGMoEKudKn8YvQIOOe+YzCPop7dwJ3zRfJ7GDuso4YJGRa0yZgg4tUaNXdGrbuZWKKxzYYEJc2xp9AUUjGt8KC2jvgYadF8+10vJyDnNLXwbdiWUZi0fUK01Eoc+AZhCLZVzK4Vq6sDUdz+0dEcbbTTIOJmAyTVhx/WmvrExbv2jtPhWLKodjCtefZiEeZeVZWWSndgwj6fVf3XON8Qwq15++uoqrfYVrow6dGBpCq79ME291jaB0/Q2CPncyht/99MNO/vr9AqW/CGi8sJqbAAAAAElFTkSuQmCC")}
bobProfile = Profile {displayName = "bob", fullName = "Bob", image = Just (ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABgAAAAYCAYAAADgdz34AAAKHGlDQ1BJQ0MgUHJvZmlsZQAASImFVgdUVNcWve9Nb7QZeu9NehtAem/Sq6gMQ28OQxWxgAQjEFFEREARNFQFg1KjiIhiIQgoYA9IEFBisCAq6OQNJNH4//r/zDpz9ttzz7n73ffWmg0A6QCDxYqD+QCIT0hmezlYywQEBsngngEYCAIy0AC6DGYSy8rDwxUg8Xf9d7wbAxC33tHgzvrP3/9nCISFJzEBgIIRTGey2MkILkawT1oyi4tnEUxjI6IQvMLFkauYqxjQQtewwuoaHy8bBNMBwJMZDHYkAERbhJdJZUYic4hhCNZOCItOQDB3vjkzioFwxLsIXhcRl5IOAImrRzs+fivCk7QRrIL0shAcwNUW+tX8yH/tFfrPXgxG5D84Pi6F+dc9ck+HHJ7g641UMSQlQATQBHEgBaQDGcACbLAVYaIRJhx5Dv+9j77aZ4OsZIFtSEc0iARRIBnpt/9qlvfqpGSQBhjImnCEcUU+NtxnujZy4fbqVEiU/wuXdQyA9S0cDqfzC+e2F4DzyLkSB79wyi0A8KoBcL2GmcJOXePQ3C8MIAJeQAOiQArIAxXuWwMMgSmwBHbAGbgDHxAINgMmojceUZUGMkEWyAX54AA4DMpAJTgJ6sAZ0ALawQVwGVwDt8AQGAUPwQSYBi/AAngHliEIwkEUiAqJQtKQIqQO6UJ0yByyg1whLygQCoEioQQoBcqE9kD5UBFUBlVB9dBPUCd0GboBDUP3oUloDnoNfYRRMBmmwZKwEqwF02Er2AX2gTfBkXAinAHnwPvhUrgaPg23wZfhW/AoPAG/gBdRAEVCCaFkURooOsoG5Y4KQkWg2KidqDxUCaoa1YTqQvWj7qAmUPOoD2gsmoqWQWugTdGOaF80E52I3okuQJeh69Bt6D70HfQkegH9GUPBSGDUMSYYJ0wAJhKThsnFlGBqMK2Yq5hRzDTmHRaLFcIqY42wjthAbAx2O7YAewzbjO3BDmOnsIs4HE4Up44zw7njGLhkXC7uKO407hJuBDeNe48n4aXxunh7fBA+AZ+NL8E34LvxI/gZ/DKBj6BIMCG4E8II2wiFhFOELsJtwjRhmchPVCaaEX2IMcQsYimxiXiV+Ij4hkQiyZGMSZ6kaNJuUinpLOk6aZL0gSxAViPbkIPJKeT95FpyD/k++Q2FQlGiWFKCKMmU/ZR6yhXKE8p7HiqPJo8TTxjPLp5ynjaeEZ6XvAReRV4r3s28GbwlvOd4b/PO8xH4lPhs+Bh8O/nK+Tr5xvkW+an8Ovzu/PH8BfwN/Df4ZwVwAkoCdgJhAjkCJwWuCExRUVR5qg2VSd1DPUW9Sp2mYWnKNCdaDC2fdoY2SFsQFBDUF/QTTBcsF7woOCGEElISchKKEyoUahEaE/ooLClsJRwuvE+4SXhEeElEXMRSJFwkT6RZZFTko6iMqJ1orOhB0XbRx2JoMTUxT7E0seNiV8XmxWnipuJM8TzxFvEHErCEmoSXxHaJkxIDEouSUpIOkizJo5JXJOelhKQspWKkiqW6peakqdLm0tHSxdKXpJ/LCMpYycTJlMr0ySzISsg6yqbIVskOyi7LKcv5ymXLNcs9lifK0+Uj5Ivle+UXFKQV3BQyFRoVHigSFOmKUYpHFPsVl5SUlfyV9iq1K80qiyg7KWcoNyo/UqGoWKgkqlSr3FXFqtJVY1WPqQ6pwWoGalFq5Wq31WF1Q/Vo9WPqw+sw64zXJayrXjeuQdaw0kjVaNSY1BTSdNXM1mzXfKmloBWkdVCrX+uztoF2nPYp7Yc6AjrOOtk6XTqvddV0mbrlunf1KHr2erv0OvRe6avrh+sf179nQDVwM9hr0GvwydDIkG3YZDhnpGAUYlRhNE6n0T3oBfTrxhhja+NdxheMP5gYmiSbtJj8YaphGmvaYDq7Xnl9+PpT66fM5MwYZlVmE+Yy5iHmJ8wnLGQtGBbVFk8t5S3DLGssZ6xUrWKsTlu9tNa2Zlu3Wi/ZmNjssOmxRdk62ObZDtoJ2Pnaldk9sZezj7RvtF9wMHDY7tDjiHF0cTzoOO4k6cR0qndacDZy3uHc50J28XYpc3nqqubKdu1yg92c3Q65PdqguCFhQ7s7cHdyP+T+2EPZI9HjZ0+sp4dnueczLx2vTK9+b6r3Fu8G73c+1j6FPg99VXxTfHv9eP2C/er9lvxt/Yv8JwK0AnYE3AoUC4wO7AjCBfkF1QQtbrTbeHjjdLBBcG7w2CblTembbmwW2xy3+eIW3i2MLedCMCH+IQ0hKwx3RjVjMdQptCJ0gWnDPMJ8EWYZVhw2F24WXhQ+E2EWURQxG2kWeShyLsoiqiRqPtomuiz6VYxjTGXMUqx7bG0sJ84/rjkeHx8S35kgkBCb0LdVamv61mGWOiuXNZFokng4cYHtwq5JgpI2JXUk05A/0oEUlZTvUiZTzVPLU9+n+aWdS+dPT0gf2Ka2bd+2mQz7jB+3o7czt/dmymZmZU7usNpRtRPaGbqzd5f8rpxd07sddtdlEbNis37J1s4uyn67x39PV45kzu6cqe8cvmvM5cll547vNd1b+T36++jvB/fp7Tu673NeWN7NfO38kvyVAmbBzR90fij9gbM/Yv9goWHh8QPYAwkHxg5aHKwr4i/KKJo65HaorVimOK/47eEth2+U6JdUHiEeSTkyUepa2nFU4eiBoytlUWWj5dblzRUSFfsqlo6FHRs5bnm8qVKyMr/y44noE/eqHKraqpWqS05iT6aefHbK71T/j/Qf62vEavJrPtUm1E7UedX11RvV1zdINBQ2wo0pjXOng08PnbE909Gk0VTVLNScfxacTTn7/KeQn8ZaXFp6z9HPNZ1XPF/RSm3Na4PatrUttEe1T3QEdgx3Onf2dpl2tf6s+XPtBdkL5RcFLxZ2E7tzujmXMi4t9rB65i9HXp7q3dL78ErAlbt9nn2DV12uXr9mf+1Kv1X/petm1y/cMLnReZN+s/2W4a22AYOB1l8MfmkdNBxsu210u2PIeKhreP1w94jFyOU7tneu3XW6e2t0w+jwmO/YvfHg8Yl7Yfdm78fdf/Ug9cHyw92PMI/yHvM9Lnki8aT6V9VfmycMJy5O2k4OPPV++nCKOfXit6TfVqZznlGelcxIz9TP6s5emLOfG3q+8fn0C9aL5fnc3/l/r3ip8vL8H5Z/DCwELEy/Yr/ivC54I/qm9q3+295Fj8Un7+LfLS/lvRd9X/eB/qH/o//HmeW0FdxK6SfVT12fXT4/4sRzOCwGm7FqBVBIwhERALyuBYASCAB1CPEPG9f8119+BvrK2fyNwVndL5jhvubRVsMQgCakeCFp04OsQ1LJEgAe5NodqT6WANbT+yf/iqQIPd21PXgaAcDJcjivtwJAQHLFgcNZ9uBwPlUgYhHf1z37f7V9g9e8ITewiP88wfWIYET6HPg21nzjV2fybQVcxfrg2/onng/F50lD/ccAAAA4ZVhJZk1NACoAAAAIAAGHaQAEAAAAAQAAABoAAAAAAAKgAgAEAAAAAQAAABigAwAEAAAAAQAAABgAAAAAwf1XlwAAAaNJREFUSA3FlT1LA0EQQBN/gYUYRTksJZVgEbCR/D+7QMr8ABtttBBCsLGzsLG2sxaxED/ie4d77u0dyaE5HHjczn7MzO7M7nU6/yXz+bwLhzCCjTQO+rZhDH3opuNLdRYN4RHe4RIKJ7R34Ro+4AEGSw2mE1iUwT18gpI74WvkGlccu4XNdH0jnYU7cAUacidn37qR23cOxc4aGU0nYUAn7iSWEHkz46w0ocdQu1X6B/AMQZ5o7KfBqNOfwRH8JB7FajGhnmcpKvQe3MEbvILiDm5gPXaCHnZr4vvFGMoEKudKn8YvQIOOe+YzCPop7dwJ3zRfJ7GDuso4YJGRa0yZgg4tUaNXdGrbuZWKKxzYYEJc2xp9AUUjGt8KC2jvgYadF8+10vJyDnNLXwbdiWUZi0fUK01Eoc+AZhCLZVzK4Vq6sDUdz+0dEcbbTTIOJmAyTVhx/WmvrExbv2jtPhWLKodjCtefZiEeZeVZWWSndgwj6fVf3XON8Qwq15++uoqrfYVrow6dGBpCq79ME291jaB0/Q2CPncyht/99MNO/vr9AqW/CGi8sJqbAAAAAElFTkSuQmCC")}
cathProfile :: Profile
cathProfile = Profile {displayName = "cath", fullName = "Catherine", image = Nothing}

5
tests/ProtocolTests.hs
View File

@@ -82,7 +82,7 @@ s #==# msg = do
s ==# msg
testProfile :: Profile
testProfile = Profile {displayName = "alice", fullName = "Alice", image = Just (ProfileImage "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=")}
testProfile = Profile {displayName = "alice", fullName = "Alice", image = Just (ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=")}
testGroupProfile :: GroupProfile
testGroupProfile = GroupProfile {displayName = "team", fullName = "Team", image = Nothing}
@@ -90,6 +90,9 @@ testGroupProfile = GroupProfile {displayName = "team", fullName = "Team", image
decodeChatMessageTest :: Spec
decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
it "x.msg.new" $ "{\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" #==# XMsgNew (MCSimple $ MCText "hello")
it "x.msg.new" $
"{\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"https://simplex.chat\",\"type\":\"link\",\"preview\":{\"description\":\"SimpleX Chat\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA\",\"title\":\"SimpleX Chat\",\"uri\":\"https://simplex.chat\"}}}}"
#==# XMsgNew (MCSimple $ MCLink "https://simplex.chat" $ LinkPreview {uri = "https://simplex.chat", title = "SimpleX Chat", description = "SimpleX Chat", image = ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA"})
it "x.msg.new" $ "{\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" ##==## (ChatMessage (Just $ SharedMsgId "\1\2\3\4") (XMsgNew . MCSimple $ MCText "hello"))
it "x.msg.new" $
"{\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}}}}"