multiple events in ChatMessage and supporting types
This commit is contained in:
spaced4ndy
parent
420d8537cb
commit
9b239b26ba
@ -3307,7 +3307,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
MSG msgMeta _msgFlags msgBody -> do
|
||||
cmdId <- createAckCmd conn
|
||||
withAckMessage agentConnId cmdId msgMeta $ do
|
||||
(conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveDirectRcvMSG conn msgMeta cmdId msgBody
|
||||
(conn', msg@RcvMessage {chatMsgEvents}) <- saveDirectRcvMSG conn msgMeta cmdId msgBody
|
||||
case chatMsgEvents of
|
||||
[ACME _ event] -> do
|
||||
let ct' = ct {activeConn = Just conn'} :: Contact
|
||||
assertDirectAllowed user MDRcv ct' $ toCMEventTag event
|
||||
updateChatLock "directMessage" event
|
||||
@ -3336,6 +3338,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
_ -> messageError $ "unsupported message: " <> T.pack (show event)
|
||||
let Contact {chatSettings = ChatSettings {sendRcpts}} = ct'
|
||||
pure $ fromMaybe (sendRcptsContacts user) sendRcpts && hasDeliveryReceipt (toCMEventTag event)
|
||||
_ -> messageError "processDirectMessage: unsupported batched events" $> False
|
||||
RCVD msgMeta msgRcpt ->
|
||||
withAckMessage' agentConnId conn msgMeta $
|
||||
directMsgReceived ct conn msgMeta msgRcpt
|
||||
@ -3344,12 +3347,12 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
conn' <- updatePeerChatVRange conn chatVRange
|
||||
case chatMsgEvent of
|
||||
-- confirming direct connection with a member
|
||||
XGrpMemInfo _memId _memProfile -> do
|
||||
[XGrpMemInfo _memId _memProfile] -> do
|
||||
-- TODO check member ID
|
||||
-- TODO update member profile
|
||||
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
allowAgentConnectionAsync user conn' confId XOk
|
||||
XInfo profile -> do
|
||||
[XInfo profile] -> do
|
||||
ct' <- processContactProfileUpdate ct profile False `catchChatError` const (pure ct)
|
||||
-- [incognito] send incognito profile
|
||||
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId
|
||||
@ -3361,13 +3364,13 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
|
||||
_conn' <- updatePeerChatVRange conn chatVRange
|
||||
case chatMsgEvent of
|
||||
XGrpMemInfo _memId _memProfile -> do
|
||||
[XGrpMemInfo _memId _memProfile] -> do
|
||||
-- TODO check member ID
|
||||
-- TODO update member profile
|
||||
pure ()
|
||||
XInfo profile ->
|
||||
[XInfo profile] ->
|
||||
void $ processContactProfileUpdate ct profile False
|
||||
XOk -> pure ()
|
||||
[XOk] -> pure ()
|
||||
_ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok"
|
||||
CON ->
|
||||
withStore' (\db -> getViaGroupMember db user ct) >>= \case
|
||||
@ -3500,7 +3503,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
case memberCategory m of
|
||||
GCInviteeMember ->
|
||||
case chatMsgEvent of
|
||||
XGrpAcpt memId
|
||||
[XGrpAcpt memId]
|
||||
| sameMemberId memId m -> do
|
||||
withStore $ \db -> liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
|
||||
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
@ -3509,7 +3512,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
_ -> messageError "CONF from invited member must have x.grp.acpt"
|
||||
_ ->
|
||||
case chatMsgEvent of
|
||||
XGrpMemInfo memId _memProfile
|
||||
[XGrpMemInfo memId _memProfile]
|
||||
| sameMemberId memId m -> do
|
||||
-- TODO update member profile
|
||||
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
@ -3520,13 +3523,13 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
|
||||
_conn' <- updatePeerChatVRange conn chatVRange
|
||||
case chatMsgEvent of
|
||||
XGrpMemInfo memId _memProfile
|
||||
[XGrpMemInfo memId _memProfile]
|
||||
| sameMemberId memId m -> do
|
||||
-- TODO update member profile
|
||||
pure ()
|
||||
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
|
||||
XInfo _ -> pure () -- sent when connecting via group link
|
||||
XOk -> pure ()
|
||||
[XInfo _] -> pure () -- sent when connecting via group link
|
||||
[XOk] -> pure ()
|
||||
_ -> messageError "INFO from member must have x.grp.mem.info, x.info or x.ok"
|
||||
pure ()
|
||||
CON -> do
|
||||
@ -3639,6 +3642,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
when checkForEvent $ checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta
|
||||
where
|
||||
checkForEvent = case chatMsgEvent of
|
||||
[cme] -> case cme of
|
||||
XMsgNew _ -> True
|
||||
XFileCancel _ -> True
|
||||
XFileAcptInv {} -> True
|
||||
@ -3650,9 +3654,12 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
XGrpInfo _ -> True
|
||||
XGrpDirectInv {} -> True
|
||||
_ -> False
|
||||
_ -> False
|
||||
processEvent :: MsgEncodingI e => CommandId -> ChatMessage e -> m Bool
|
||||
processEvent cmdId chatMsg = do
|
||||
(m', conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m conn msgMeta cmdId msgBody chatMsg
|
||||
(m', conn', msg@RcvMessage {chatMsgEvents}) <- saveGroupRcvMsg user groupId m conn msgMeta cmdId msgBody chatMsg
|
||||
case chatMsgEvents of
|
||||
[ACME _ event] -> do
|
||||
updateChatLock "groupMessage" event
|
||||
case event of
|
||||
XMsgNew mc -> memberCanSend m' $ newGroupContentMessage gInfo m' mc msg brokerTs
|
||||
@ -3684,6 +3691,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
BFileChunk sharedMsgId chunk -> bFileChunkGroup gInfo sharedMsgId chunk msgMeta
|
||||
_ -> messageError $ "unsupported message: " <> T.pack (show event)
|
||||
checkSendRcpt event
|
||||
_ ->
|
||||
-- TODO [batch send] process events in loop
|
||||
messageError "processGroupMessage: unsupported batched events" $> False
|
||||
checkSendRcpt :: ChatMsgEvent e -> m Bool
|
||||
checkSendRcpt event = do
|
||||
currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo
|
||||
@ -3796,7 +3806,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
conn' <- updatePeerChatVRange conn chatVRange
|
||||
case chatMsgEvent of
|
||||
-- TODO save XFileAcpt message
|
||||
XFileAcpt name
|
||||
[XFileAcpt name]
|
||||
| name == fileName -> do
|
||||
withStore' $ \db -> updateSndFileStatus db ft FSAccepted
|
||||
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
@ -3864,7 +3874,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
|
||||
conn' <- updatePeerChatVRange conn chatVRange
|
||||
case chatMsgEvent of
|
||||
XOk -> allowAgentConnectionAsync user conn' confId XOk -- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
[XOk] -> allowAgentConnectionAsync user conn' confId XOk -- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
_ -> pure ()
|
||||
CON -> startReceivingFile user fileId
|
||||
MSG meta _ msgBody -> do
|
||||
@ -3924,8 +3934,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
REQ invId _ connInfo -> do
|
||||
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
|
||||
case chatMsgEvent of
|
||||
XContact p xContactId_ -> profileContactRequest invId chatVRange p xContactId_
|
||||
XInfo p -> profileContactRequest invId chatVRange p Nothing
|
||||
[XContact p xContactId_] -> profileContactRequest invId chatVRange p xContactId_
|
||||
[XInfo p] -> profileContactRequest invId chatVRange p Nothing
|
||||
-- TODO show/log error, other events in contact request
|
||||
_ -> pure ()
|
||||
MERR _ err -> do
|
||||
@ -4958,11 +4968,11 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage activeConn connInfo
|
||||
conn' <- updatePeerChatVRange activeConn chatVRange
|
||||
case chatMsgEvent of
|
||||
XInfo p -> do
|
||||
[XInfo p] -> do
|
||||
ct <- withStore $ \db -> createDirectContact db user conn' p
|
||||
toView $ CRContactConnecting user ct
|
||||
pure conn'
|
||||
XGrpLinkInv glInv -> do
|
||||
[XGrpLinkInv glInv] -> do
|
||||
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db user conn' glInv
|
||||
toView $ CRGroupLinkConnecting user gInfo host
|
||||
pure conn'
|
||||
@ -5229,8 +5239,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
processForwardedMsg :: GroupMember -> ChatMessage 'Json -> m ()
|
||||
processForwardedMsg author chatMsg = do
|
||||
let body = LB.toStrict $ J.encode msg
|
||||
rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} <- saveGroupFwdRcvMsg user groupId m author body chatMsg
|
||||
case event of
|
||||
rcvMsg@RcvMessage {chatMsgEvents} <- saveGroupFwdRcvMsg user groupId m author body chatMsg
|
||||
case chatMsgEvents of
|
||||
[ACME _ event] -> case event of
|
||||
XMsgNew mc -> memberCanSend author $ newGroupContentMessage gInfo author mc rcvMsg msgTs
|
||||
XMsgFileDescr sharedMsgId fileDescr -> memberCanSend author $ groupMessageFileDescription gInfo author sharedMsgId fileDescr
|
||||
XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend author $ groupMessageUpdate gInfo author sharedMsgId mContent rcvMsg msgTs ttl live
|
||||
@ -5245,6 +5256,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
XGrpDel -> xGrpDel gInfo author rcvMsg msgTs
|
||||
XGrpInfo p' -> xGrpInfo gInfo author p' rcvMsg msgTs
|
||||
_ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event)
|
||||
_ -> messageError "x.grp.msg.forward: unsupported batched events"
|
||||
|
||||
directMsgReceived :: Contact -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> m ()
|
||||
directMsgReceived ct conn@Connection {connId} msgMeta msgRcpts = do
|
||||
@ -5532,12 +5544,12 @@ sendDirectMessage conn chatMsgEvent connOrGroupId = do
|
||||
(msg,) <$> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId
|
||||
|
||||
createSndMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> ConnOrGroupId -> m SndMessage
|
||||
createSndMessage chatMsgEvent connOrGroupId = do
|
||||
createSndMessage cme connOrGroupId = do
|
||||
gVar <- asks idsDrg
|
||||
ChatConfig {chatVRange} <- asks config
|
||||
withStore $ \db -> createNewSndMessage db gVar connOrGroupId $ \sharedMsgId ->
|
||||
let msgBody = strEncode ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent}
|
||||
in NewMessage {chatMsgEvent, msgBody}
|
||||
let msgBody = strEncode ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent = [cme]}
|
||||
in NewMessage {chatMsgEvents = [cme], msgBody}
|
||||
|
||||
sendBatchedDirectMessages :: (MsgEncodingI e, ChatMonad m) => Connection -> [ChatMsgEvent e] -> ConnOrGroupId -> m (SndMessage, Int64)
|
||||
sendBatchedDirectMessages conn events connOrGroupId = do
|
||||
@ -5558,17 +5570,16 @@ createBatchedSndMessage events connOrGroupId = do
|
||||
-- - ChatMessage encoding should support list of ChatMsgEvents
|
||||
-- - * return list of SndMessages? it's not necessary for current use cases
|
||||
withStore $ \db -> createNewSndMessage db gVar connOrGroupId $ \sharedMsgId ->
|
||||
let chatMsgEvent = XOk -- dummy
|
||||
msgBody = strEncode ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent}
|
||||
in NewMessage {chatMsgEvent, msgBody}
|
||||
let msgBody = strEncode ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent = events}
|
||||
in NewMessage {chatMsgEvents = events, msgBody}
|
||||
|
||||
directMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> m ByteString
|
||||
directMessage chatMsgEvent = do
|
||||
directMessage cme = do
|
||||
ChatConfig {chatVRange} <- asks config
|
||||
pure $ strEncode ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent}
|
||||
pure $ strEncode ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent = [cme]}
|
||||
|
||||
deliverMessage :: ChatMonad m => Connection -> CMEventTag e -> MsgBody -> MessageId -> m Int64
|
||||
deliverMessage conn@Connection {connId} cmEventTag msgBody msgId = do
|
||||
deliverMessage conn cmEventTag msgBody msgId = do
|
||||
let msgFlags = MsgFlags {notification = hasNotification cmEventTag}
|
||||
deliverMessage' conn msgFlags msgBody msgId
|
||||
|
||||
@ -5655,7 +5666,7 @@ saveDirectRcvMSG conn@Connection {connId} agentMsgMeta agentAckCmdId msgBody = d
|
||||
ACMsg _ ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} <- parseAChatMessage conn agentMsgMeta msgBody
|
||||
conn' <- updatePeerChatVRange conn chatVRange
|
||||
let agentMsgId = fst $ recipient agentMsgMeta
|
||||
newMsg = NewMessage {chatMsgEvent, msgBody}
|
||||
newMsg = NewMessage {chatMsgEvents = chatMsgEvent, msgBody}
|
||||
rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId}
|
||||
msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing
|
||||
pure (conn', msg)
|
||||
@ -5664,7 +5675,7 @@ saveGroupRcvMsg :: (MsgEncodingI e, ChatMonad m) => User -> GroupId -> GroupMemb
|
||||
saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta agentAckCmdId msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do
|
||||
(am', conn') <- updateMemberChatVRange authorMember conn chatVRange
|
||||
let agentMsgId = fst $ recipient agentMsgMeta
|
||||
newMsg = NewMessage {chatMsgEvent, msgBody}
|
||||
newMsg = NewMessage {chatMsgEvents = chatMsgEvent, msgBody}
|
||||
rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId}
|
||||
amId = Just am'.groupMemberId
|
||||
msg <-
|
||||
@ -5680,7 +5691,7 @@ saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta
|
||||
|
||||
saveGroupFwdRcvMsg :: (MsgEncodingI e, ChatMonad m) => User -> GroupId -> GroupMember -> GroupMember -> MsgBody -> ChatMessage e -> m RcvMessage
|
||||
saveGroupFwdRcvMsg user groupId forwardingMember refAuthorMember msgBody ChatMessage {msgId = sharedMsgId_, chatMsgEvent} = do
|
||||
let newMsg = NewMessage {chatMsgEvent, msgBody}
|
||||
let newMsg = NewMessage {chatMsgEvents = chatMsgEvent, msgBody}
|
||||
fwdMemberId = Just $ groupMemberId' forwardingMember
|
||||
refAuthorId = Just $ groupMemberId' refAuthorMember
|
||||
withStore (\db -> createNewRcvMessage db (GroupId groupId) newMsg sharedMsgId_ refAuthorId fwdMemberId)
|
||||
@ -5714,10 +5725,10 @@ saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content =
|
||||
saveRcvChatItem' :: ChatMonad m => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> CIContent 'MDRcv -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> m (ChatItem c 'MDRcv)
|
||||
saveRcvChatItem' user cd msg@RcvMessage {forwardedByMember} sharedMsgId_ brokerTs content ciFile itemTimed live = do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
(ciId, quotedItem) <- withStore' $ \db -> do
|
||||
when (ciRequiresAttention content) $ updateChatTs db user cd createdAt
|
||||
(ciId, quotedItem) <- withStore $ \db -> do
|
||||
when (ciRequiresAttention content) $ liftIO $ updateChatTs db user cd createdAt
|
||||
(ciId, quotedItem) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live brokerTs createdAt
|
||||
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
|
||||
forM_ ciFile $ \CIFile {fileId} -> liftIO $ updateFileTransferChatItemId db fileId ciId createdAt
|
||||
pure (ciId, quotedItem)
|
||||
liftIO $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ itemTimed live brokerTs forwardedByMember createdAt
|
||||
|
||||
|
||||
@ -767,7 +767,7 @@ checkChatType x = case testEquality (chatTypeI @c) (chatTypeI @c') of
|
||||
Nothing -> Left "bad chat type"
|
||||
|
||||
data NewMessage e = NewMessage
|
||||
{ chatMsgEvent :: ChatMsgEvent e,
|
||||
{ chatMsgEvents :: [ChatMsgEvent e],
|
||||
msgBody :: MsgBody
|
||||
}
|
||||
deriving (Show)
|
||||
@ -780,7 +780,7 @@ data SndMessage = SndMessage
|
||||
|
||||
data RcvMessage = RcvMessage
|
||||
{ msgId :: MessageId,
|
||||
chatMsgEvent :: AChatMsgEvent,
|
||||
chatMsgEvents :: [AChatMsgEvent],
|
||||
sharedMsgId_ :: Maybe SharedMsgId,
|
||||
msgBody :: MsgBody,
|
||||
authorMember :: Maybe GroupMemberId,
|
||||
|
||||
@ -133,6 +133,14 @@ data AppMessageJson = AppMessageJson
|
||||
params :: J.Object
|
||||
}
|
||||
|
||||
-- TODO [batch send] AppBatchMessageJson?
|
||||
-- data AppMessageJson = AppMessageJson
|
||||
-- { v :: Maybe ChatVersionRange,
|
||||
-- msgId :: Maybe SharedMsgId,
|
||||
-- event :: Text,
|
||||
-- params :: J.Object
|
||||
-- }
|
||||
|
||||
data AppMessageBinary = AppMessageBinary
|
||||
{ msgId :: Maybe SharedMsgId,
|
||||
tag :: Char,
|
||||
@ -207,7 +215,7 @@ $(JQ.deriveJSON defaultJSON ''LinkPreview)
|
||||
data ChatMessage e = ChatMessage
|
||||
{ chatVRange :: VersionRange,
|
||||
msgId :: Maybe SharedMsgId,
|
||||
chatMsgEvent :: ChatMsgEvent e
|
||||
chatMsgEvent :: [ChatMsgEvent e]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@ -285,8 +293,10 @@ isForwardedGroupMsg ev = case ev of
|
||||
_ -> False
|
||||
|
||||
forwardedGroupMsg :: forall e. MsgEncodingI e => ChatMessage e -> Maybe (ChatMessage 'Json)
|
||||
forwardedGroupMsg msg@ChatMessage {chatMsgEvent} = case encoding @e of
|
||||
SJson | isForwardedGroupMsg chatMsgEvent -> Just msg
|
||||
forwardedGroupMsg msg@ChatMessage {chatMsgEvent} = case chatMsgEvent of
|
||||
[cme] -> case encoding @e of
|
||||
SJson | isForwardedGroupMsg cme -> Just msg
|
||||
_ -> Nothing
|
||||
_ -> Nothing
|
||||
|
||||
data MsgReaction = MREmoji {emoji :: MREmojiChar} | MRUnknown {tag :: Text, json :: J.Object}
|
||||
@ -791,8 +801,8 @@ hasDeliveryReceipt = \case
|
||||
appBinaryToCM :: AppMessageBinary -> Either String (ChatMessage 'Binary)
|
||||
appBinaryToCM AppMessageBinary {msgId, tag, body} = do
|
||||
eventTag <- strDecode $ B.singleton tag
|
||||
chatMsgEvent <- parseAll (msg eventTag) body
|
||||
pure ChatMessage {chatVRange = chatInitialVRange, msgId, chatMsgEvent}
|
||||
cme <- parseAll (msg eventTag) body
|
||||
pure ChatMessage {chatVRange = chatInitialVRange, msgId, chatMsgEvent = [cme]}
|
||||
where
|
||||
msg :: CMEventTag 'Binary -> A.Parser (ChatMsgEvent 'Binary)
|
||||
msg = \case
|
||||
@ -801,8 +811,8 @@ appBinaryToCM AppMessageBinary {msgId, tag, body} = do
|
||||
appJsonToCM :: AppMessageJson -> Either String (ChatMessage 'Json)
|
||||
appJsonToCM AppMessageJson {v, msgId, event, params} = do
|
||||
eventTag <- strDecode $ encodeUtf8 event
|
||||
chatMsgEvent <- msg eventTag
|
||||
pure ChatMessage {chatVRange = maybe chatInitialVRange fromChatVRange v, msgId, chatMsgEvent}
|
||||
cme <- msg eventTag
|
||||
pure ChatMessage {chatVRange = maybe chatInitialVRange fromChatVRange v, msgId, chatMsgEvent = [cme]}
|
||||
where
|
||||
p :: FromJSON a => J.Key -> Either String a
|
||||
p key = JT.parseEither (.: key) params
|
||||
@ -855,14 +865,18 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
|
||||
(.=?) :: ToJSON v => JT.Key -> Maybe v -> [(J.Key, J.Value)] -> [(J.Key, J.Value)]
|
||||
key .=? value = maybe id ((:) . (key .=)) value
|
||||
|
||||
-- TODO [batch send]
|
||||
chatToAppMessage :: forall e. MsgEncodingI e => ChatMessage e -> AppMessage e
|
||||
chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @e of
|
||||
chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case chatMsgEvent of
|
||||
[cme] -> case encoding @e of
|
||||
SBinary ->
|
||||
let (binaryMsgId, body) = toBody chatMsgEvent
|
||||
in AMBinary AppMessageBinary {msgId = binaryMsgId, tag = B.head $ strEncode tag, body}
|
||||
SJson -> AMJson AppMessageJson {v = Just $ ChatVersionRange chatVRange, msgId, event = textEncode tag, params = params chatMsgEvent}
|
||||
let (binaryMsgId, body) = toBody cme
|
||||
in AMBinary AppMessageBinary {msgId = binaryMsgId, tag = B.head $ strEncode $ toCMEventTag cme, body}
|
||||
SJson -> AMJson AppMessageJson {v = Just $ ChatVersionRange chatVRange, msgId, event = textEncode $ toCMEventTag cme, params = params cme}
|
||||
_ ->
|
||||
-- encode list of events
|
||||
error "bad ChatMessage"
|
||||
where
|
||||
tag = toCMEventTag chatMsgEvent
|
||||
o :: [(J.Key, J.Value)] -> J.Object
|
||||
o = JM.fromList
|
||||
toBody :: ChatMsgEvent 'Binary -> (Maybe SharedMsgId, ByteString)
|
||||
|
||||
@ -160,7 +160,8 @@ deleteGroupCIs db User {userId} GroupInfo {groupId} = do
|
||||
createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage e) -> ExceptT StoreError IO SndMessage
|
||||
createNewSndMessage db gVar connOrGroupId mkMessage =
|
||||
createWithRandomId gVar $ \sharedMsgId -> do
|
||||
let NewMessage {chatMsgEvent, msgBody} = mkMessage $ SharedMsgId sharedMsgId
|
||||
let NewMessage {chatMsgEvents, msgBody} = mkMessage $ SharedMsgId sharedMsgId
|
||||
tag = eventsTag chatMsgEvents
|
||||
createdAt <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
@ -170,10 +171,15 @@ createNewSndMessage db gVar connOrGroupId mkMessage =
|
||||
shared_msg_id, shared_msg_id_user, created_at, updated_at
|
||||
) VALUES (?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
(MDSnd, toCMEventTag chatMsgEvent, msgBody, connId_, groupId_, sharedMsgId, Just True, createdAt, createdAt)
|
||||
(MDSnd, tag, msgBody, connId_, groupId_, sharedMsgId, Just True, createdAt, createdAt)
|
||||
msgId <- insertedRowId db
|
||||
pure SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody}
|
||||
where
|
||||
eventsTag :: [ChatMsgEvent e] -> CMEventTag e
|
||||
eventsTag events = case events of
|
||||
[chatMsgEvent] -> toCMEventTag chatMsgEvent
|
||||
(chatMsgEvent : _) -> toCMEventTag chatMsgEvent
|
||||
[] -> error "createNewSndMessage: empty chatMsgEvents"
|
||||
(connId_, groupId_) = case connOrGroupId of
|
||||
ConnectionId connId -> (Just connId, Nothing)
|
||||
GroupId groupId -> (Nothing, Just groupId)
|
||||
@ -199,7 +205,7 @@ createNewMessageAndRcvMsgDelivery db connOrGroupId newMessage sharedMsgId_ RcvMs
|
||||
pure msg
|
||||
|
||||
createNewRcvMessage :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage
|
||||
createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember =
|
||||
createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvents, msgBody} sharedMsgId_ authorMember forwardedByMember =
|
||||
case connOrGroupId of
|
||||
ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing
|
||||
GroupId groupId -> case sharedMsgId_ of
|
||||
@ -222,6 +228,7 @@ createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMs
|
||||
|]
|
||||
(groupId, sharedMsgId)
|
||||
insertRcvMsg connId_ groupId_ = do
|
||||
let tag = eventsTag chatMsgEvents
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
@ -230,9 +237,14 @@ createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMs
|
||||
(msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id, author_group_member_id, forwarded_by_group_member_id)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
(MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_, authorMember, forwardedByMember)
|
||||
(MDRcv, tag, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_, authorMember, forwardedByMember)
|
||||
msgId <- insertedRowId db
|
||||
pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember}
|
||||
pure RcvMessage {msgId, chatMsgEvents = map (ACME (encoding @e)) chatMsgEvents, sharedMsgId_, msgBody, authorMember, forwardedByMember}
|
||||
eventsTag :: [ChatMsgEvent e] -> CMEventTag e
|
||||
eventsTag events = case events of
|
||||
[chatMsgEvent] -> toCMEventTag chatMsgEvent
|
||||
(chatMsgEvent : _) -> toCMEventTag chatMsgEvent
|
||||
[] -> error "createNewRcvMessage: empty chatMsgEvents"
|
||||
|
||||
createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO ()
|
||||
createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do
|
||||
@ -365,13 +377,13 @@ createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciCon
|
||||
CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId)
|
||||
CIQGroupRcv Nothing -> (Just False, Nothing)
|
||||
|
||||
createNewRcvChatItem :: DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c))
|
||||
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forwardedByMember} sharedMsgId_ ciContent timed live itemTs createdAt = do
|
||||
createNewRcvChatItem :: DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> ExceptT StoreError IO (ChatItemId, Maybe (CIQuote c))
|
||||
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvents = [cme], forwardedByMember} sharedMsgId_ ciContent timed live itemTs createdAt = liftIO $ do
|
||||
ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow timed live itemTs forwardedByMember createdAt
|
||||
quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg
|
||||
pure (ciId, quotedItem)
|
||||
where
|
||||
quotedMsg = cmToQuotedMsg chatMsgEvent
|
||||
quotedMsg = cmToQuotedMsg cme
|
||||
quoteRow :: NewQuoteRow
|
||||
quoteRow = case quotedMsg of
|
||||
Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing)
|
||||
@ -380,6 +392,7 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forw
|
||||
CDDirectRcv _ -> (Just $ not sent, Nothing)
|
||||
CDGroupRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ ->
|
||||
(Just $ Just userMemberId == memberId, memberId)
|
||||
createNewRcvChatItem _ _ _ RcvMessage {chatMsgEvents = _} _ _ _ _ _ _ = throwError SECantCreateBatchedEventsChatItem
|
||||
|
||||
createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId
|
||||
createNewChatItemNoMsg db user chatDirection ciContent itemTs =
|
||||
|
||||
@ -93,6 +93,7 @@ data StoreError
|
||||
| SEChatItemSharedMsgIdNotFound {sharedMsgId :: SharedMsgId}
|
||||
| SEChatItemNotFoundByFileId {fileId :: FileTransferId}
|
||||
| SEChatItemNotFoundByGroupId {groupId :: GroupId}
|
||||
| SECantCreateBatchedEventsChatItem
|
||||
| SEProfileNotFound {profileId :: Int64}
|
||||
| SEDuplicateGroupLink {groupInfo :: GroupInfo}
|
||||
| SEGroupLinkNotFound {groupInfo :: GroupInfo}
|
||||
|
||||
@ -76,10 +76,10 @@ s ##==## msg = do
|
||||
s ==## msg
|
||||
|
||||
(==#) :: MsgEncodingI e => ByteString -> ChatMsgEvent e -> Expectation
|
||||
s ==# msg = s ==## ChatMessage chatInitialVRange Nothing msg
|
||||
s ==# msg = s ==## ChatMessage chatInitialVRange Nothing [msg]
|
||||
|
||||
(#==) :: MsgEncodingI e => ByteString -> ChatMsgEvent e -> Expectation
|
||||
s #== msg = s ##== ChatMessage chatInitialVRange Nothing msg
|
||||
s #== msg = s ##== ChatMessage chatInitialVRange Nothing [msg]
|
||||
|
||||
(#==#) :: MsgEncodingI e => ByteString -> ChatMsgEvent e -> Expectation
|
||||
s #==# msg = do
|
||||
@ -120,37 +120,37 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
|
||||
#==# XMsgNew (MCSimple (extMsgContent (MCImage "here's an image" $ ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=") Nothing))
|
||||
it "x.msg.new chat message" $
|
||||
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
|
||||
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing)))
|
||||
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") [XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing))]
|
||||
it "x.msg.new chat message with chat version range" $
|
||||
"{\"v\":\"1-5\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
|
||||
##==## ChatMessage supportedChatVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing)))
|
||||
##==## ChatMessage supportedChatVRange (Just $ SharedMsgId "\1\2\3\4") [XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing))]
|
||||
it "x.msg.new quote" $
|
||||
"{\"v\":\"1\",\"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\"}}}}"
|
||||
##==## ChatMessage
|
||||
chatInitialVRange
|
||||
(Just $ SharedMsgId "\1\2\3\4")
|
||||
(XMsgNew (MCQuote quotedMsg (extMsgContent (MCText "hello to you too") Nothing)))
|
||||
[XMsgNew (MCQuote quotedMsg (extMsgContent (MCText "hello to you too") Nothing))]
|
||||
it "x.msg.new quote - timed message TTL" $
|
||||
"{\"v\":\"1\",\"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\"}},\"ttl\":3600}}"
|
||||
##==## ChatMessage
|
||||
chatInitialVRange
|
||||
(Just $ SharedMsgId "\1\2\3\4")
|
||||
(XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing (Just 3600) Nothing)))
|
||||
[XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing (Just 3600) Nothing))]
|
||||
it "x.msg.new quote - live message" $
|
||||
"{\"v\":\"1\",\"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\"}},\"live\":true}}"
|
||||
##==## ChatMessage
|
||||
chatInitialVRange
|
||||
(Just $ SharedMsgId "\1\2\3\4")
|
||||
(XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing Nothing (Just True))))
|
||||
[XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing Nothing (Just True)))]
|
||||
it "x.msg.new forward" $
|
||||
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true}}"
|
||||
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") Nothing))
|
||||
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") [XMsgNew $ MCForward (extMsgContent (MCText "hello") Nothing)]
|
||||
it "x.msg.new forward - timed message TTL" $
|
||||
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"ttl\":3600}}"
|
||||
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing))
|
||||
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") [XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing)]
|
||||
it "x.msg.new forward - live message" $
|
||||
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"live\":true}}"
|
||||
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing Nothing (Just True)))
|
||||
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") [XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing Nothing (Just True))]
|
||||
it "x.msg.new simple text with file" $
|
||||
"{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}"
|
||||
#==# XMsgNew (MCSimple (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing})))
|
||||
@ -162,7 +162,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
|
||||
##==## ChatMessage
|
||||
chatInitialVRange
|
||||
(Just $ SharedMsgId "\1\2\3\4")
|
||||
( XMsgNew
|
||||
[ XMsgNew
|
||||
( MCQuote
|
||||
quotedMsg
|
||||
( extMsgContent
|
||||
@ -170,10 +170,10 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
|
||||
(Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing})
|
||||
)
|
||||
)
|
||||
)
|
||||
]
|
||||
it "x.msg.new forward with file" $
|
||||
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}"
|
||||
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing})))
|
||||
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") [XMsgNew $ MCForward (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing}))]
|
||||
it "x.msg.update" $
|
||||
"{\"v\":\"1\",\"event\":\"x.msg.update\",\"params\":{\"msgId\":\"AQIDBA==\", \"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
|
||||
#==# XMsgUpdate (SharedMsgId "\1\2\3\4") (MCText "hello") Nothing Nothing
|
||||
|
||||
Loading…
Reference in New Issue
Block a user