rfc: handling multiple files/attachments in a message
This commit is contained in:
Evgeny Poberezkin
parent
767522e701
commit
9f0d400fdc
39
docs/rfcs/2024-01-02-multiple-attachments.md
Normal file
39
docs/rfcs/2024-01-02-multiple-attachments.md
Normal file
@ -0,0 +1,39 @@
|
||||
# Sending multiple files with a message
|
||||
|
||||
## Problem
|
||||
|
||||
The immediate problem we need to solve is encrypting local videos, the absense of which creates a lot of confusion and perception that the videos are sent unencrypted.
|
||||
|
||||
The reason videos are not encrypted is because they are usually large files that would be slow to decrypt in order to play, and they are also used to generate previews on the fly. The latter is slow anyway, and causes bad rendering experience.
|
||||
|
||||
Videos on iOS are compressed from 5.4.2, and the solution to keep them encrypted is to keep video preview in a separate file. It can be done either on the receiving side, when the video is first rendered, or on the sending side, in which case we can send the preview as a separate file.
|
||||
|
||||
In general, attaching multiple files to a message could be beneficial for other cases, such as sending hi- and low-res images at the same time, or sending long-form messages with attachments.
|
||||
|
||||
## Solutions
|
||||
|
||||
1. Extend chat protocol to allow multiple attachments in a single protocol message. This PR has types to support it, and database schema already supports multiple files with chat item. Different message types can allow a limited number of files and interpret them according to their indices in the array. This seems an ad hoc approach, as semantics of the additional attachments are not defined in the protocol and should be implied by file positions.
|
||||
|
||||
2. Still allow multiple attachments but add file semantics in the protocol message, alongside FileInvitation object, e.g.:
|
||||
|
||||
```
|
||||
data FileAttachment = FileAttachment
|
||||
{ file :: FileInvitation,
|
||||
fileType :: FileAttachmentType
|
||||
}
|
||||
```
|
||||
|
||||
This format is marginally more complex, but it is more extensible.
|
||||
|
||||
3. Instead of allowing multiple attachments in a message, we could allow up to two files for a single attachment (which is what we need now), that could later be useful for messages with multiple attachments as well. This way FileInvitation will be replaced with:
|
||||
|
||||
```
|
||||
data FileAttachment = FileAttachment
|
||||
{ preview :: Maybe FileInvitation, -- received automatically if "receive images" is enabled
|
||||
file :: FileInvitation, -- received automatically if "receive images" is enabled for images, in the absense of preview
|
||||
}
|
||||
```
|
||||
|
||||
4. Add additional protocol message to send additional attachments separately.
|
||||
|
||||
5. To solve only original problem of videos, we could add an API to save previews on the first render - this seems the worst approach, as it both complicates the logic of the recipient, without allowing other use cases.
|
||||
@ -688,15 +688,15 @@ processChatCommand' vr = \case
|
||||
pure (fileInvitation, ciFile, ft)
|
||||
prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> m (MsgContainer, Maybe (CIQuote 'CTDirect))
|
||||
prepareMsg fInv_ timed_ = case quotedItemId_ of
|
||||
Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing)
|
||||
Nothing -> pure (MCSimple (ExtMsgContent mc (maybeToList fInv_) (ttl' <$> timed_) (justTrue live)), Nothing)
|
||||
Just quotedItemId -> do
|
||||
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
|
||||
withStore $ \db -> getDirectChatItem db user chatId quotedItemId
|
||||
(origQmc, qd, sent) <- quoteData qci
|
||||
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing}
|
||||
qmc = quoteContent mc origQmc file
|
||||
qmc = quoteContent mc origQmc (listToMaybe file)
|
||||
quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText}
|
||||
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem)
|
||||
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc (maybeToList fInv_) (ttl' <$> timed_) (justTrue live)), Just quotedItem)
|
||||
where
|
||||
quoteData :: ChatItem c d -> m (MsgContent, CIQDirection 'CTDirect, Bool)
|
||||
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} = throwChatError CEInvalidQuote
|
||||
@ -1540,7 +1540,7 @@ processChatCommand' vr = \case
|
||||
sendAndCount user ll (s, f) ct =
|
||||
(sendToContact user ct $> (s + 1, f)) `catchChatError` \e -> when (ll <= CLLInfo) (toView $ CRChatError (Just user) e) $> (s, f + 1)
|
||||
sendToContact user ct = do
|
||||
(sndMsg, _) <- sendDirectContactMessage ct (XMsgNew $ MCSimple (extMsgContent mc Nothing))
|
||||
(sndMsg, _) <- sendDirectContactMessage ct (XMsgNew $ MCSimple (extMsgContent mc []))
|
||||
void $ saveSndChatItem user (CDDirectSnd ct) sndMsg (CISndMsgContent mc)
|
||||
SendMessageQuote cName (AMsgDirection msgDir) quotedMsg msg -> withUser $ \user@User {userId} -> do
|
||||
contactId <- withStore $ \db -> getContactIdByName db user cName
|
||||
@ -1906,7 +1906,7 @@ processChatCommand' vr = \case
|
||||
FileStatus fileId -> withUser $ \user -> do
|
||||
ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
||||
case file of
|
||||
Just CIFile {fileProtocol = FPXFTP} ->
|
||||
CIFile {fileProtocol = FPXFTP} : _ ->
|
||||
pure $ CRFileTransferStatusXFTP user ci
|
||||
_ -> do
|
||||
fileStatus <- withStore $ \db -> getFileTransferProgress db user fileId
|
||||
@ -2401,15 +2401,15 @@ processChatCommand' vr = \case
|
||||
|
||||
prepareGroupMsg :: forall m. ChatMonad m => User -> GroupInfo -> MsgContent -> Maybe ChatItemId -> Maybe FileInvitation -> Maybe CITimed -> Bool -> m (MsgContainer, Maybe (CIQuote 'CTGroup))
|
||||
prepareGroupMsg user GroupInfo {groupId, membership} mc quotedItemId_ fInv_ timed_ live = case quotedItemId_ of
|
||||
Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing)
|
||||
Nothing -> pure (MCSimple (ExtMsgContent mc (maybeToList fInv_) (ttl' <$> timed_) (justTrue live)), Nothing)
|
||||
Just quotedItemId -> do
|
||||
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
|
||||
withStore $ \db -> getGroupChatItem db user groupId quotedItemId
|
||||
(origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership
|
||||
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId}
|
||||
qmc = quoteContent mc origQmc file
|
||||
qmc = quoteContent mc origQmc (listToMaybe file)
|
||||
quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText}
|
||||
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem)
|
||||
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc (maybeToList fInv_) (ttl' <$> timed_) (justTrue live)), Just quotedItem)
|
||||
where
|
||||
quoteData :: ChatItem c d -> GroupMember -> m (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
|
||||
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwChatError CEInvalidQuote
|
||||
@ -3211,7 +3211,7 @@ processAgentMsgSndFile _corrId aFileId msg =
|
||||
-- returns msgDeliveryId of the last file description message
|
||||
loopSend :: NonEmpty FileDescr -> m Int64
|
||||
loopSend (fileDescr :| fds) = do
|
||||
(_, msgDeliveryId) <- sendMsg $ XMsgFileDescr {msgId, fileDescr}
|
||||
(_, msgDeliveryId) <- sendMsg $ XMsgFileDescr {msgId, fileId = Nothing, fileDescr}
|
||||
case L.nonEmpty fds of
|
||||
Just fds' -> loopSend fds'
|
||||
Nothing -> pure msgDeliveryId
|
||||
@ -3364,7 +3364,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
updateChatLock "directMessage" event
|
||||
case event of
|
||||
XMsgNew mc -> newContentMessage ct' mc msg msgMeta
|
||||
XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct' sharedMsgId fileDescr msgMeta
|
||||
XMsgFileDescr sharedMsgId _fileId fileDescr -> messageFileDescription ct' sharedMsgId fileDescr msgMeta
|
||||
XMsgUpdate sharedMsgId mContent ttl live -> messageUpdate ct' sharedMsgId mContent msg msgMeta ttl live
|
||||
XMsgDel sharedMsgId _ -> messageDelete ct' sharedMsgId msg msgMeta
|
||||
XMsgReact sharedMsgId _ reaction add -> directMsgReaction ct' sharedMsgId reaction add msg msgMeta
|
||||
@ -3438,7 +3438,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
let (UserContactLink {autoAccept}, groupId_, gLinkMemRole) = ucl
|
||||
forM_ autoAccept $ \(AutoAccept {autoReply = mc_}) ->
|
||||
forM_ mc_ $ \mc -> do
|
||||
(msg, _) <- sendDirectContactMessage ct (XMsgNew $ MCSimple (extMsgContent mc Nothing))
|
||||
(msg, _) <- sendDirectContactMessage ct (XMsgNew $ MCSimple (extMsgContent mc []))
|
||||
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc)
|
||||
toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
|
||||
forM_ groupId_ $ \groupId -> do
|
||||
@ -3649,15 +3649,15 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
descrEvent_
|
||||
| isCompatibleRange (memberChatVRange' m) groupHistoryIncludeWelcomeVRange = do
|
||||
let GroupInfo {groupProfile = GroupProfile {description}} = gInfo
|
||||
fmap (\descr -> XMsgNew $ MCSimple $ extMsgContent (MCText descr) Nothing) description
|
||||
fmap (\descr -> XMsgNew $ MCSimple $ extMsgContent (MCText descr) []) description
|
||||
| otherwise = Nothing
|
||||
itemForwardEvents :: CChatItem 'CTGroup -> m [ChatMsgEvent 'Json]
|
||||
itemForwardEvents cci = case cci of
|
||||
(CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv sender, content = CIRcvMsgContent mc, file}) -> do
|
||||
fInvDescr_ <- join <$> forM file getRcvFileInvDescr
|
||||
fInvDescr_ <- join <$> forM (listToMaybe file) getRcvFileInvDescr
|
||||
processContentItem sender ci mc fInvDescr_
|
||||
(CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent mc, file}) -> do
|
||||
fInvDescr_ <- join <$> forM file getSndFileInvDescr
|
||||
fInvDescr_ <- join <$> forM (listToMaybe file) getSndFileInvDescr
|
||||
processContentItem membership ci mc fInvDescr_
|
||||
_ -> pure []
|
||||
where
|
||||
@ -3705,7 +3705,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of
|
||||
(Just fileDescrText, Just msgId) -> do
|
||||
parts <- splitFileDescr fileDescrText
|
||||
pure . toList $ L.map (XMsgFileDescr msgId) parts
|
||||
pure . toList $ L.map (XMsgFileDescr msgId Nothing) parts
|
||||
_ -> pure []
|
||||
let fileDescrChatMsgs = map (ChatMessage senderVRange Nothing) fileDescrEvents
|
||||
GroupMember {memberId} = sender
|
||||
@ -3762,7 +3762,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
updateChatLock "groupMessage" event
|
||||
case event of
|
||||
XMsgNew mc -> memberCanSend m' $ newGroupContentMessage gInfo m' mc msg brokerTs False
|
||||
XMsgFileDescr sharedMsgId fileDescr -> memberCanSend m' $ groupMessageFileDescription gInfo m' sharedMsgId fileDescr
|
||||
XMsgFileDescr sharedMsgId _fileId fileDescr -> memberCanSend m' $ groupMessageFileDescription gInfo m' sharedMsgId fileDescr
|
||||
XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend m' $ groupMessageUpdate gInfo m' sharedMsgId mContent msg brokerTs ttl live
|
||||
XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo m' sharedMsgId memberId msg brokerTs
|
||||
XMsgReact sharedMsgId (Just memberId) reaction add -> groupMsgReaction gInfo m' sharedMsgId memberId reaction add msg brokerTs
|
||||
@ -4246,7 +4246,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
let ExtMsgContent _ _ itemTTL live_ = mcExtMsgContent mc
|
||||
timed_ = rcvContactCITimed ct itemTTL
|
||||
live = fromMaybe False live_
|
||||
file_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct
|
||||
file_ <- processFileInvitation (listToMaybe fInv_) content $ \db -> createRcvFileTransfer db userId ct
|
||||
newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
|
||||
autoAcceptFile file_
|
||||
where
|
||||
@ -4406,7 +4406,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> m ()
|
||||
newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded
|
||||
| isVoice content && not (groupFeatureAllowed SGFVoice gInfo) = rejected GFVoice
|
||||
| not (isVoice content) && isJust fInv_ && not (groupFeatureAllowed SGFFiles gInfo) = rejected GFFiles
|
||||
| not (isVoice content) && isJust (listToMaybe fInv_) && not (groupFeatureAllowed SGFFiles gInfo) = rejected GFFiles
|
||||
| otherwise = do
|
||||
let timed_ =
|
||||
if forwarded
|
||||
@ -4429,11 +4429,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo ci moderator moderatedAt
|
||||
toView $ CRNewChatItem user $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci'
|
||||
| otherwise = do
|
||||
file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
|
||||
file_ <- processFileInvitation (listToMaybe fInv_) content $ \db -> createRcvGroupFileTransfer db userId m
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent content) (snd <$> file_) timed_ False
|
||||
toView =<< markGroupCIDeleted user gInfo ci createdByMsgId False (Just moderator) moderatedAt
|
||||
createItem timed_ live = do
|
||||
file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
|
||||
file_ <- processFileInvitation (listToMaybe fInv_) content $ \db -> createRcvGroupFileTransfer db userId m
|
||||
newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
|
||||
when (showMessages $ memberSettings m) $ autoAcceptFile file_
|
||||
newChatItem ciContent ciFile_ timed_ live = do
|
||||
@ -4587,7 +4587,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
else messageError "x.file.acpt.inv: fileName is different from expected"
|
||||
|
||||
assertSMPAcceptNotProhibited :: ChatItem c d -> m ()
|
||||
assertSMPAcceptNotProhibited ChatItem {file = Just CIFile {fileId, fileProtocol}, content}
|
||||
assertSMPAcceptNotProhibited ChatItem {file = CIFile {fileId, fileProtocol} : _, content}
|
||||
| fileProtocol == FPXFTP && not (imageOrVoice content) = throwChatError $ CEFallbackToSMPProhibited fileId
|
||||
| otherwise = pure ()
|
||||
where
|
||||
@ -4606,7 +4606,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
liftIO $ deleteSndFileChunks db sft
|
||||
updateDirectCIFileStatus db vr user fileId CIFSSndComplete
|
||||
case file of
|
||||
Just CIFile {fileProtocol = FPXFTP} -> do
|
||||
CIFile {fileProtocol = FPXFTP} : _ -> do
|
||||
ft <- withStore $ \db -> getFileTransferMeta db user fileId
|
||||
toView $ CRSndFileCompleteXFTP user ci ft
|
||||
_ -> toView $ CRSndFileComplete user ci sft
|
||||
@ -5343,7 +5343,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} <- saveGroupFwdRcvMsg user groupId m author body chatMsg
|
||||
case event of
|
||||
XMsgNew mc -> memberCanSend author $ newGroupContentMessage gInfo author mc rcvMsg msgTs True
|
||||
XMsgFileDescr sharedMsgId fileDescr -> memberCanSend author $ groupMessageFileDescription gInfo author sharedMsgId fileDescr
|
||||
XMsgFileDescr sharedMsgId _fileId fileDescr -> memberCanSend author $ groupMessageFileDescription gInfo author sharedMsgId fileDescr
|
||||
XMsgUpdate sharedMsgId mContent ttl live -> memberCanSend author $ groupMessageUpdate gInfo author sharedMsgId mContent rcvMsg msgTs ttl live
|
||||
XMsgDel sharedMsgId memId -> groupMessageDelete gInfo author sharedMsgId memId rcvMsg msgTs
|
||||
XMsgReact sharedMsgId (Just memId) reaction add -> groupMsgReaction gInfo author sharedMsgId memId reaction add rcvMsg msgTs
|
||||
@ -5875,17 +5875,17 @@ mkChatItem cd ciId content file quotedItem sharedMsgId itemTimed live itemTs for
|
||||
let itemText = ciContentToText content
|
||||
itemStatus = ciCreateStatus content
|
||||
meta = mkCIMeta ciId content itemText itemStatus sharedMsgId Nothing False itemTimed (justTrue live) currentTs itemTs forwardedByMember currentTs currentTs
|
||||
pure ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, reactions = [], file}
|
||||
pure ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, reactions = [], file = maybeToList file}
|
||||
|
||||
deleteDirectCI :: (ChatMonad m, MsgDirectionI d) => User -> Contact -> ChatItem 'CTDirect d -> Bool -> Bool -> m ChatResponse
|
||||
deleteDirectCI user ct ci@ChatItem {file} byUser timed = do
|
||||
deleteCIFile user file
|
||||
deleteCIFile user $ listToMaybe file
|
||||
withStoreCtx' (Just "deleteDirectCI, deleteDirectChatItem") $ \db -> deleteDirectChatItem db user ct ci
|
||||
pure $ CRChatItemDeleted user (AChatItem SCTDirect msgDirection (DirectChat ct) ci) Nothing byUser timed
|
||||
|
||||
deleteGroupCI :: (ChatMonad m, MsgDirectionI d) => User -> GroupInfo -> ChatItem 'CTGroup d -> Bool -> Bool -> Maybe GroupMember -> UTCTime -> m ChatResponse
|
||||
deleteGroupCI user gInfo ci@ChatItem {file} byUser timed byGroupMember_ deletedTs = do
|
||||
deleteCIFile user file
|
||||
deleteCIFile user $ listToMaybe file
|
||||
toCi <- withStoreCtx' (Just "deleteGroupCI, deleteGroupChatItem ...") $ \db ->
|
||||
case byGroupMember_ of
|
||||
Nothing -> deleteGroupChatItem db user gInfo ci $> Nothing
|
||||
@ -5902,7 +5902,7 @@ deleteCIFile user file_ =
|
||||
|
||||
markDirectCIDeleted :: (ChatMonad m, MsgDirectionI d) => User -> Contact -> ChatItem 'CTDirect d -> MessageId -> Bool -> UTCTime -> m ChatResponse
|
||||
markDirectCIDeleted user ct ci@ChatItem {file} msgId byUser deletedTs = do
|
||||
cancelCIFile user file
|
||||
cancelCIFile user $ listToMaybe file
|
||||
ci' <- withStore' $ \db -> markDirectChatItemDeleted db user ct ci msgId deletedTs
|
||||
pure $ CRChatItemDeleted user (ctItem ci) (Just $ ctItem ci') byUser False
|
||||
where
|
||||
@ -5910,7 +5910,7 @@ markDirectCIDeleted user ct ci@ChatItem {file} msgId byUser deletedTs = do
|
||||
|
||||
markGroupCIDeleted :: (ChatMonad m, MsgDirectionI d) => User -> GroupInfo -> ChatItem 'CTGroup d -> MessageId -> Bool -> Maybe GroupMember -> UTCTime -> m ChatResponse
|
||||
markGroupCIDeleted user gInfo ci@ChatItem {file} msgId byUser byGroupMember_ deletedTs = do
|
||||
cancelCIFile user file
|
||||
cancelCIFile user $ listToMaybe file
|
||||
ci' <- withStore' $ \db -> markGroupChatItemDeleted db user gInfo ci msgId byGroupMember_ deletedTs
|
||||
pure $ CRChatItemDeleted user (gItem ci) (Just $ gItem ci') byUser False
|
||||
where
|
||||
|
||||
@ -146,7 +146,7 @@ data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem
|
||||
formattedText :: Maybe MarkdownList,
|
||||
quotedItem :: Maybe (CIQuote c),
|
||||
reactions :: [CIReactionCount],
|
||||
file :: Maybe (CIFile d)
|
||||
file :: [CIFile d]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
@ -300,10 +300,11 @@ aChatItemId (AChatItem _ _ _ ci) = chatItemId' ci
|
||||
aChatItemTs :: AChatItem -> UTCTime
|
||||
aChatItemTs (AChatItem _ _ _ ci) = chatItemTs' ci
|
||||
|
||||
-- TODO multiple files
|
||||
updateFileStatus :: forall c d. ChatItem c d -> CIFileStatus d -> ChatItem c d
|
||||
updateFileStatus ci@ChatItem {file} status = case file of
|
||||
Just f -> ci {file = Just (f :: CIFile d) {fileStatus = status}}
|
||||
Nothing -> ci
|
||||
f : _ -> ci {file = [(f :: CIFile d) {fileStatus = status}]}
|
||||
[] -> ci
|
||||
|
||||
-- This type is not saved to DB, so all JSON encodings are platform-specific
|
||||
data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta
|
||||
|
||||
@ -225,7 +225,7 @@ data AChatMessage = forall e. MsgEncodingI e => ACMsg (SMsgEncoding e) (ChatMess
|
||||
|
||||
data ChatMsgEvent (e :: MsgEncoding) where
|
||||
XMsgNew :: MsgContainer -> ChatMsgEvent 'Json
|
||||
XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr} -> ChatMsgEvent 'Json
|
||||
XMsgFileDescr :: {msgId :: SharedMsgId, fileId :: Maybe Int, fileDescr :: FileDescr} -> ChatMsgEvent 'Json
|
||||
XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, ttl :: Maybe Int, live :: Maybe Bool} -> ChatMsgEvent 'Json
|
||||
XMsgDel :: SharedMsgId -> Maybe MemberId -> ChatMsgEvent 'Json
|
||||
XMsgDeleted :: ChatMsgEvent 'Json
|
||||
@ -277,10 +277,10 @@ deriving instance Show AChatMsgEvent
|
||||
|
||||
isForwardedGroupMsg :: ChatMsgEvent e -> Bool
|
||||
isForwardedGroupMsg ev = case ev of
|
||||
XMsgNew mc -> case mcExtMsgContent mc of
|
||||
ExtMsgContent {file = Just FileInvitation {fileInline = Just _}} -> False
|
||||
_ -> True
|
||||
XMsgFileDescr _ _ -> True
|
||||
XMsgNew mc ->
|
||||
let ExtMsgContent {file} = mcExtMsgContent mc
|
||||
in all (\case FileInvitation {fileInline = Just _} -> False; _ -> True) file
|
||||
XMsgFileDescr _ _ _ -> True
|
||||
XMsgUpdate {} -> True
|
||||
XMsgDel _ _ -> True
|
||||
XMsgReact {} -> True
|
||||
@ -488,7 +488,7 @@ msgContentTag = \case
|
||||
MCFile {} -> MCFile_
|
||||
MCUnknown {tag} -> MCUnknown_ tag
|
||||
|
||||
data ExtMsgContent = ExtMsgContent {content :: MsgContent, file :: Maybe FileInvitation, ttl :: Maybe Int, live :: Maybe Bool}
|
||||
data ExtMsgContent = ExtMsgContent {content :: MsgContent, file :: [FileInvitation], ttl :: Maybe Int, live :: Maybe Bool}
|
||||
deriving (Eq, Show)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''QuotedMsg)
|
||||
@ -528,9 +528,9 @@ parseMsgContainer v =
|
||||
<|> (v .: "forward" >>= \f -> (if f then MCForward else MCSimple) <$> mc)
|
||||
<|> MCSimple <$> mc
|
||||
where
|
||||
mc = ExtMsgContent <$> v .: "content" <*> v .:? "file" <*> v .:? "ttl" <*> v .:? "live"
|
||||
mc = ExtMsgContent <$> v .: "content" <*> (maybe [] msgFiles <$> v .:? "file") <*> v .:? "ttl" <*> v .:? "live"
|
||||
|
||||
extMsgContent :: MsgContent -> Maybe FileInvitation -> ExtMsgContent
|
||||
extMsgContent :: MsgContent -> [FileInvitation] -> ExtMsgContent
|
||||
extMsgContent mc file = ExtMsgContent mc file Nothing Nothing
|
||||
|
||||
justTrue :: Bool -> Maybe Bool
|
||||
@ -575,7 +575,19 @@ msgContainerJSON = \case
|
||||
MCSimple mc -> o $ msgContent mc
|
||||
where
|
||||
o = JM.fromList
|
||||
msgContent (ExtMsgContent c file ttl live) = ("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) ["content" .= c]
|
||||
msgContent (ExtMsgContent c file ttl live) = ("file" .=? filesToJSON file) $ ("ttl" .=? ttl) $ ("live" .=? live) ["content" .= c]
|
||||
|
||||
newtype MsgFiles = MsgFiles {msgFiles :: [FileInvitation]}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance FromJSON MsgFiles where
|
||||
parseJSON v = MsgFiles <$> (((: []) <$> parseJSON v) <|> parseJSON v)
|
||||
|
||||
filesToJSON :: [FileInvitation] -> Maybe J.Value
|
||||
filesToJSON = \case
|
||||
[] -> Nothing
|
||||
[f] -> Just $ J.toJSON f
|
||||
fs -> Just $ J.toJSON fs
|
||||
|
||||
instance ToJSON MsgContent where
|
||||
toJSON = \case
|
||||
@ -750,7 +762,7 @@ instance StrEncoding ACMEventTag where
|
||||
toCMEventTag :: ChatMsgEvent e -> CMEventTag e
|
||||
toCMEventTag msg = case msg of
|
||||
XMsgNew _ -> XMsgNew_
|
||||
XMsgFileDescr _ _ -> XMsgFileDescr_
|
||||
XMsgFileDescr _ _ _ -> XMsgFileDescr_
|
||||
XMsgUpdate {} -> XMsgUpdate_
|
||||
XMsgDel {} -> XMsgDel_
|
||||
XMsgDeleted -> XMsgDeleted_
|
||||
@ -849,7 +861,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
|
||||
msg :: CMEventTag 'Json -> Either String (ChatMsgEvent 'Json)
|
||||
msg = \case
|
||||
XMsgNew_ -> XMsgNew <$> JT.parseEither parseMsgContainer params
|
||||
XMsgFileDescr_ -> XMsgFileDescr <$> p "msgId" <*> p "fileDescr"
|
||||
XMsgFileDescr_ -> XMsgFileDescr <$> p "msgId" <*> opt "fileId" <*> p "fileDescr"
|
||||
XMsgUpdate_ -> XMsgUpdate <$> p "msgId" <*> p "content" <*> opt "ttl" <*> opt "live"
|
||||
XMsgDel_ -> XMsgDel <$> p "msgId" <*> opt "memberId"
|
||||
XMsgDeleted_ -> pure XMsgDeleted
|
||||
@ -909,7 +921,7 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @
|
||||
params :: ChatMsgEvent 'Json -> J.Object
|
||||
params = \case
|
||||
XMsgNew container -> msgContainerJSON container
|
||||
XMsgFileDescr msgId' fileDescr -> o ["msgId" .= msgId', "fileDescr" .= fileDescr]
|
||||
XMsgFileDescr msgId' fileId fileDescr -> o $ ("fileId" .=? fileId) ["msgId" .= msgId', "fileDescr" .= fileDescr]
|
||||
XMsgUpdate msgId' content ttl live -> o $ ("ttl" .=? ttl) $ ("live" .=? live) ["msgId" .= msgId', "content" .= content]
|
||||
XMsgDel msgId' memberId -> o $ ("memberId" .=? memberId) ["msgId" .= msgId']
|
||||
XMsgDeleted -> JM.empty
|
||||
|
||||
@ -112,7 +112,7 @@ import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Either (fromRight, rights)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (sortBy)
|
||||
import Data.Maybe (fromMaybe, isJust, mapMaybe)
|
||||
import Data.Maybe (fromMaybe, isJust, mapMaybe, maybeToList)
|
||||
import Data.Ord (Down (..), comparing)
|
||||
import Data.Text (Text)
|
||||
import Data.Time (addUTCTime)
|
||||
@ -1122,7 +1122,7 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
|
||||
_ -> Nothing
|
||||
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTDirect
|
||||
cItem d chatDir ciStatus content file =
|
||||
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow, reactions = [], file}
|
||||
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow, reactions = [], file = maybeToList file}
|
||||
badItem = Left $ SEBadChatItem itemId
|
||||
ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTDirect d
|
||||
ciMeta content status =
|
||||
@ -1173,7 +1173,7 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
|
||||
_ -> Nothing
|
||||
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTGroup
|
||||
cItem d chatDir ciStatus content file =
|
||||
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, reactions = [], file}
|
||||
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, reactions = [], file = maybeToList file}
|
||||
badItem = Left $ SEBadChatItem itemId
|
||||
ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTGroup d
|
||||
ciMeta content status =
|
||||
|
||||
@ -24,7 +24,7 @@ import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
|
||||
import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1)
|
||||
@ -411,7 +411,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
|
||||
Just CIQuote {chatDir = quoteDir, content} ->
|
||||
Just (msgDirectionInt $ quoteMsgDirection quoteDir, msgContentText content)
|
||||
fPath = case file of
|
||||
Just CIFile {fileSource = Just (CryptoFile fp _)} -> Just fp
|
||||
CIFile {fileSource = Just (CryptoFile fp _)} : _ -> Just fp
|
||||
_ -> Nothing
|
||||
testViewItem :: CChatItem c -> Maybe GroupMember -> Text
|
||||
testViewItem (CChatItem _ ci@ChatItem {meta = CIMeta {itemText}}) membership_ =
|
||||
@ -561,12 +561,12 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {forwardedByMember},
|
||||
Just _ -> item <> styled (colored Yellow) (" [>>]" :: String)
|
||||
withSndFile = withFile viewSentFileInvitation
|
||||
withRcvFile = withFile viewReceivedFileInvitation
|
||||
withFile view dir l = maybe l (\f -> l <> view dir f ts tz meta) file
|
||||
withFile view dir l = maybe l (\f -> l <> view dir f ts tz meta) $ listToMaybe file
|
||||
sndMsg = msg viewSentMessage
|
||||
rcvMsg = msg viewReceivedMessage
|
||||
msg view dir quote mc = case (msgContentText mc, file, quote) of
|
||||
("", Just _, []) -> []
|
||||
("", Just CIFile {fileName}, _) -> view dir quote (MCText $ T.pack fileName) ts tz meta
|
||||
("", _ : _, []) -> []
|
||||
("", CIFile {fileName} : _, _) -> view dir quote (MCText $ T.pack fileName) ts tz meta
|
||||
_ -> view dir quote mc ts tz meta
|
||||
showSndItem to = showItem $ sentWithTime_ ts tz [to <> plainContent content] meta
|
||||
showRcvItem from = showItem $ receivedWithTime_ ts tz from [] meta [plainContent content] False
|
||||
@ -1514,9 +1514,9 @@ sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} =
|
||||
[status <> " sending " <> sndFile ft <> " to " <> ttyContact c]
|
||||
|
||||
uploadingFile :: StyledString -> AChatItem -> [StyledString]
|
||||
uploadingFile status (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectSnd}) =
|
||||
uploadingFile status (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = CIFile {fileId, fileName} : _, chatDir = CIDirectSnd}) =
|
||||
[status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyContact c]
|
||||
uploadingFile status (AChatItem _ _ (GroupChat g) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupSnd}) =
|
||||
uploadingFile status (AChatItem _ _ (GroupChat g) ChatItem {file = CIFile {fileId, fileName} : _, chatDir = CIGroupSnd}) =
|
||||
[status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyGroup' g]
|
||||
uploadingFile status _ = [status <> " uploading file"] -- shouldn't happen
|
||||
|
||||
@ -1546,12 +1546,12 @@ humanReadableSize size
|
||||
gB = mB * 1024
|
||||
|
||||
savingFile' :: AChatItem -> [StyledString]
|
||||
savingFile' (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileSource = Just (CryptoFile filePath _)}, chatDir}) =
|
||||
savingFile' (AChatItem _ _ chat ChatItem {file = CIFile {fileId, fileSource = Just (CryptoFile filePath _)} : _, chatDir}) =
|
||||
["saving file " <> sShow fileId <> fileFrom chat chatDir <> " to " <> plain filePath]
|
||||
savingFile' _ = ["saving file"] -- shouldn't happen
|
||||
|
||||
receivingFile_' :: (Maybe RemoteHostId, Maybe User) -> Bool -> String -> AChatItem -> [StyledString]
|
||||
receivingFile_' hu testView status (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileName, fileSource = Just f@(CryptoFile _ cfArgs_)}, chatDir}) =
|
||||
receivingFile_' hu testView status (AChatItem _ _ chat ChatItem {file = CIFile {fileId, fileName, fileSource = Just f@(CryptoFile _ cfArgs_)} : _, chatDir}) =
|
||||
[plain status <> " receiving " <> fileTransferStr fileId fileName <> fileFrom chat chatDir] <> cfArgsStr cfArgs_ <> getRemoteFileStr
|
||||
where
|
||||
cfArgsStr (Just cfArgs) = [plain (cryptoFileArgsStr testView cfArgs) | status == "completed"]
|
||||
@ -1620,7 +1620,7 @@ viewFileTransferStatus (FTRcv ft@RcvFileTransfer {fileId, fileInvitation = FileI
|
||||
RFSCancelled Nothing -> "cancelled"
|
||||
|
||||
viewFileTransferStatusXFTP :: AChatItem -> [StyledString]
|
||||
viewFileTransferStatusXFTP (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, fileName, fileSize, fileStatus, fileSource}}) =
|
||||
viewFileTransferStatusXFTP (AChatItem _ _ _ ChatItem {file = CIFile {fileId, fileName, fileSize, fileStatus, fileSource} : _}) =
|
||||
case fileStatus of
|
||||
CIFSSndStored -> ["sending " <> fstr <> " just started"]
|
||||
CIFSSndTransfer progress total -> ["sending " <> fstr <> " in progress " <> fileProgressXFTP progress total fileSize]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user