mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-07-12 13:59:03 +00:00
core, ui: message signing (#7115)
This commit is contained in:
spaced4ndy
@@ -86,14 +86,14 @@ sendComposedMessages cc sendRef = sendComposedMessages_ cc sendRef . L.map (Noth
|
||||
sendComposedMessages_ :: ChatController -> SendRef -> NonEmpty (Maybe ChatItemId, MsgContent) -> IO ()
|
||||
sendComposedMessages_ cc sendRef qmcs = do
|
||||
let cms = L.map (\(qiId, mc) -> ComposedMessage {fileSource = Nothing, quotedItemId = qiId, msgContent = mc, mentions = M.empty}) qmcs
|
||||
sendChatCmd cc (APISendMessages sendRef False Nothing cms) >>= \case
|
||||
sendChatCmd cc (APISendMessages sendRef False Nothing False cms) >>= \case
|
||||
Right (CRNewChatItems {}) -> printLog cc CLLInfo $ "sent " <> show (length cms) <> " messages to " <> show sendRef
|
||||
r -> putStrLn $ "unexpected send message response: " <> show r
|
||||
|
||||
sendComposedMessageFile :: ChatController -> SendRef -> Maybe ChatItemId -> MsgContent -> CryptoFile -> IO ()
|
||||
sendComposedMessageFile cc sendRef qiId mc file = do
|
||||
let cm = ComposedMessage {fileSource = Just file, quotedItemId = qiId, msgContent = mc, mentions = M.empty}
|
||||
sendChatCmd cc (APISendMessages sendRef False Nothing (cm :| [])) >>= \case
|
||||
sendChatCmd cc (APISendMessages sendRef False Nothing False (cm :| [])) >>= \case
|
||||
Right (CRNewChatItems {}) -> printLog cc CLLInfo $ "sent file message to " <> show sendRef
|
||||
r -> putStrLn $ "unexpected send message response: " <> show r
|
||||
|
||||
|
||||
@@ -379,7 +379,7 @@ data ChatCommand
|
||||
| APIGetChatContentTypes ChatRef
|
||||
| APIGetChatItems {chatPagination :: ChatPagination, search :: Maybe Text}
|
||||
| APIGetChatItemInfo {chatRef :: ChatRef, chatItemId :: ChatItemId}
|
||||
| APISendMessages {sendRef :: SendRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessages :: NonEmpty ComposedMessage}
|
||||
| APISendMessages {sendRef :: SendRef, liveMessage :: Bool, ttl :: Maybe Int, signMessages :: Bool, composedMessages :: NonEmpty ComposedMessage}
|
||||
| APICreateChatTag ChatTagData
|
||||
| APISetChatTags ChatRef (Maybe (NonEmpty ChatTagId))
|
||||
| APIDeleteChatTag ChatTagId
|
||||
|
||||
@@ -653,7 +653,7 @@ processChatCommand cxt nm = \case
|
||||
-- TODO [knocking] getAChatItem doesn't differentiate how to read based on scope - it should, instead of using group filter
|
||||
Just <$> withFastStore (\db -> getAChatItem db cxt user (ChatRef CTGroup gId Nothing) fwdItemId)
|
||||
_ -> pure Nothing
|
||||
APISendMessages sendRef live itemTTL cms -> withUser $ \user -> mapM_ assertAllowedContent' cms >> case sendRef of
|
||||
APISendMessages sendRef live itemTTL sign cms -> withUser $ \user -> mapM_ assertAllowedContent' cms >> case sendRef of
|
||||
SRDirect chatId -> do
|
||||
mapM_ assertNoMentions cms
|
||||
withContactLock "sendMessage" chatId $
|
||||
@@ -666,7 +666,7 @@ processChatCommand cxt nm = \case
|
||||
(gInfo, cmrs) <- withFastStore $ \db -> do
|
||||
g <- getGroupInfo db cxt user chatId
|
||||
(g,) <$> mapM (composedMessageReqMentions db user g) cms
|
||||
sendGroupContentMessages user gInfo gsScope asGroup live itemTTL cmrs
|
||||
sendGroupContentMessages user gInfo gsScope asGroup live itemTTL sign cmrs
|
||||
APICreateChatTag (ChatTagData emoji text) -> withUser $ \user -> withFastStore' $ \db -> do
|
||||
_ <- createChatTag db user emoji text
|
||||
CRChatTags user <$> getUserChatTags db user
|
||||
@@ -697,7 +697,7 @@ processChatCommand cxt nm = \case
|
||||
gInfo <- withFastStore $ \db -> getGroupInfo db cxt user gId
|
||||
let mc = MCReport reportText reportReason
|
||||
cm = ComposedMessage {fileSource = Nothing, quotedItemId = Just reportedItemId, msgContent = mc, mentions = M.empty}
|
||||
sendGroupContentMessages user gInfo (Just $ GCSMemberSupport Nothing) False False Nothing [composedMessageReq cm]
|
||||
sendGroupContentMessages user gInfo (Just $ GCSMemberSupport Nothing) False False Nothing False [composedMessageReq cm]
|
||||
ReportMessage {groupName, contactName_, reportReason, reportedMessage} -> withUser $ \user -> do
|
||||
gId <- withFastStore $ \db -> getGroupIdByName db user groupName
|
||||
reportedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user gId contactName_ reportedMessage
|
||||
@@ -738,7 +738,7 @@ processChatCommand cxt nm = \case
|
||||
-- TODO [knocking] check chat item scope?
|
||||
cci <- withFastStore $ \db -> getGroupCIWithReactions db user gInfo itemId
|
||||
case cci of
|
||||
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable, showGroupAsSender}, content = ciContent} -> do
|
||||
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable, showGroupAsSender, msgVerified}, content = ciContent} -> do
|
||||
case (ciContent, itemSharedMsgId, editable) of
|
||||
(CISndMsgContent oldMC, Just itemSharedMId, True) -> do
|
||||
chatScopeInfo <- mapM (getChatScopeInfo cxt user) scope
|
||||
@@ -750,7 +750,8 @@ processChatCommand cxt nm = \case
|
||||
let msgScope = toMsgScope gInfo <$> chatScopeInfo
|
||||
mentions' = M.map (\CIMention {memberId} -> MsgMention {memberId}) ciMentions
|
||||
event = XMsgUpdate itemSharedMId mc mentions' (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive) msgScope (Just showGroupAsSender)
|
||||
SndMessage {msgId} <- sendGroupMessage user gInfo scope recipients event
|
||||
reuseSign = case msgVerified of MVSigned _ -> True; _ -> False
|
||||
SndMessage {msgId} <- sendGroupMessage user gInfo scope recipients reuseSign event
|
||||
ci' <- withFastStore' $ \db -> do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
when changed $
|
||||
@@ -809,16 +810,14 @@ processChatCommand cxt nm = \case
|
||||
recipients <- getGroupRecipients cxt user gInfo chatScopeInfo groupKnockingVersion
|
||||
assertDeletable items
|
||||
assertUserGroupRole gInfo GRObserver -- can still delete messages sent earlier
|
||||
let msgIds = itemsMsgIds items
|
||||
events = L.nonEmpty $ map (\msgId -> XMsgDel msgId Nothing (toMsgScope gInfo <$> chatScopeInfo) False) msgIds
|
||||
mapM_ (sendGroupMessages user gInfo Nothing False recipients) events
|
||||
let signedEvents = L.nonEmpty $ mapMaybe (delEventSigned gInfo chatScopeInfo False) items
|
||||
mapM_ (sendGroupSignedMessages user gInfo Nothing False recipients) signedEvents
|
||||
delGroupChatItems user gInfo chatScopeInfo items False
|
||||
CIDMHistory -> do
|
||||
unless (publicGroupEditor gInfo (membership gInfo)) $ throwChatError CEInvalidChatItemDelete
|
||||
recipients <- getGroupRecipients cxt user gInfo chatScopeInfo groupKnockingVersion
|
||||
let msgIds = itemsMsgIds items
|
||||
events = L.nonEmpty $ map (\msgId -> XMsgDel msgId Nothing (toMsgScope gInfo <$> chatScopeInfo) True) msgIds
|
||||
mapM_ (sendGroupMessages user gInfo Nothing False recipients) events
|
||||
let signedEvents = L.nonEmpty $ mapMaybe (delEventSigned gInfo chatScopeInfo True) items
|
||||
mapM_ (sendGroupSignedMessages user gInfo Nothing False recipients) signedEvents
|
||||
delGroupChatItems user gInfo chatScopeInfo items False
|
||||
pure $ CRChatItemsDeleted user deletions True False
|
||||
CTLocal -> do
|
||||
@@ -840,6 +839,15 @@ processChatCommand cxt nm = \case
|
||||
SMDRcv -> False
|
||||
itemsMsgIds :: [CChatItem c] -> [SharedMsgId]
|
||||
itemsMsgIds = mapMaybe (\(CChatItem _ ChatItem {meta = CIMeta {itemSharedMsgId}}) -> itemSharedMsgId)
|
||||
-- history delete always signs (attributable owner action); self-delete signs iff the target was held signed (deniability)
|
||||
delEventSigned :: GroupInfo -> Maybe GroupChatScopeInfo -> Bool -> CChatItem 'CTGroup -> Maybe (Maybe MsgSigning, ChatMsgEvent 'Json)
|
||||
delEventSigned gInfo chatScopeInfo onlyHistory (CChatItem _ ChatItem {meta = CIMeta {itemSharedMsgId, msgVerified}}) =
|
||||
delEvent <$> itemSharedMsgId
|
||||
where
|
||||
delEvent msgId =
|
||||
let evt = XMsgDel msgId Nothing (toMsgScope gInfo <$> chatScopeInfo) onlyHistory
|
||||
in (groupMsgSigning (onlyHistory || itemSigned) gInfo evt, evt)
|
||||
itemSigned = case msgVerified of MVSigned _ -> True; _ -> False
|
||||
APIDeleteMemberChatItem gId itemIds -> withUser $ \user -> withGroupLock "deleteChatItem" gId $ do
|
||||
(gInfo, items) <- getCommandGroupChatItems user gId itemIds
|
||||
-- TODO [knocking] check scope is Nothing for all items? (prohibit moderation in support chats?)
|
||||
@@ -907,7 +915,7 @@ processChatCommand cxt nm = \case
|
||||
let itemMemberId = memberId' <$> chatItemMember g ci
|
||||
rs <- withFastStore' $ \db -> getGroupReactions db g membership itemMemberId itemSharedMId True
|
||||
checkReactionAllowed rs
|
||||
SndMessage {msgId} <- sendGroupMessage user g scope recipients (XMsgReact itemSharedMId itemMemberId (toMsgScope g <$> chatScopeInfo) reaction add)
|
||||
SndMessage {msgId} <- sendGroupMessage user g scope recipients False (XMsgReact itemSharedMId itemMemberId (toMsgScope g <$> chatScopeInfo) reaction add)
|
||||
createdAt <- liftIO getCurrentTime
|
||||
reactions <- withFastStore' $ \db -> do
|
||||
setGroupReaction db g membership itemMemberId itemSharedMId True reaction add msgId createdAt
|
||||
@@ -993,7 +1001,7 @@ processChatCommand cxt nm = \case
|
||||
Just cmrs' ->
|
||||
withGroupLock "forwardChatItem, to group" toChatId $ do
|
||||
gInfo <- withFastStore $ \db -> getGroupInfo db cxt user toChatId
|
||||
sendGroupContentMessages user gInfo toScope sendAsGroup False itemTTL cmrs'
|
||||
sendGroupContentMessages user gInfo toScope sendAsGroup False itemTTL False cmrs'
|
||||
Nothing -> pure $ CRNewChatItems user []
|
||||
CTLocal -> do
|
||||
cmrs <- prepareForward user
|
||||
@@ -2429,7 +2437,7 @@ processChatCommand cxt nm = \case
|
||||
_ -> throwCmdError "unsupported share target"
|
||||
processChatCommand cxt nm (APIShareChatMsgContent (ChatRef CTGroup groupId Nothing) sendRef) >>= \case
|
||||
CRChatMsgContent _ mc ->
|
||||
processChatCommand cxt nm $ APISendMessages sendRef False Nothing [composedMessage Nothing mc]
|
||||
processChatCommand cxt nm $ APISendMessages sendRef False Nothing False [composedMessage Nothing mc]
|
||||
r -> pure r
|
||||
SendMessage sendName msg -> withUser $ \user -> do
|
||||
let mc = MCText msg
|
||||
@@ -2438,7 +2446,7 @@ processChatCommand cxt nm = \case
|
||||
withFastStore' (\db -> runExceptT $ getContactIdByName db user name) >>= \case
|
||||
Right ctId -> do
|
||||
let sendRef = SRDirect ctId
|
||||
processChatCommand cxt nm $ APISendMessages sendRef False Nothing [composedMessage Nothing mc]
|
||||
processChatCommand cxt nm $ APISendMessages sendRef False Nothing False [composedMessage Nothing mc]
|
||||
Left _ ->
|
||||
withFastStore' (\db -> runExceptT $ getActiveMembersByName db cxt user name) >>= \case
|
||||
Right [(gInfo, member)] -> do
|
||||
@@ -2458,7 +2466,7 @@ processChatCommand cxt nm = \case
|
||||
GCSMemberSupport <$> mapM (getGroupMemberIdByName db user gId) mName_
|
||||
(gInfo, cScope_,) <$> liftIO (getMessageMentions db user gId msg)
|
||||
let sendRef = SRGroup (groupId' gInfo) cScope_ (sendAsGroup' gInfo cScope_)
|
||||
processChatCommand cxt nm $ APISendMessages sendRef False Nothing [ComposedMessage Nothing Nothing mc mentions]
|
||||
processChatCommand cxt nm $ APISendMessages sendRef False Nothing False [ComposedMessage Nothing Nothing mc mentions]
|
||||
SNLocal -> do
|
||||
folderId <- withFastStore (`getUserNoteFolderId` user)
|
||||
processChatCommand cxt nm $ APICreateChatItems folderId [composedMessage Nothing mc]
|
||||
@@ -2478,7 +2486,7 @@ processChatCommand cxt nm = \case
|
||||
cr -> pure cr
|
||||
Just ctId -> do
|
||||
let sendRef = SRDirect ctId
|
||||
processChatCommand cxt nm $ APISendMessages sendRef False Nothing [composedMessage Nothing mc]
|
||||
processChatCommand cxt nm $ APISendMessages sendRef False Nothing False [composedMessage Nothing mc]
|
||||
AcceptMemberContact cName -> withUser $ \user -> do
|
||||
contactId <- withFastStore $ \db -> getContactIdByName db user cName
|
||||
processChatCommand cxt nm $ APIAcceptMemberContact contactId
|
||||
@@ -2486,7 +2494,7 @@ processChatCommand cxt nm = \case
|
||||
(chatRef, mentions) <- getChatRefAndMentions user chatName msg
|
||||
withSendRef user chatRef $ \sendRef -> do
|
||||
let mc = MCText msg
|
||||
processChatCommand cxt nm $ APISendMessages sendRef True Nothing [ComposedMessage Nothing Nothing mc mentions]
|
||||
processChatCommand cxt nm $ APISendMessages sendRef True Nothing False [ComposedMessage Nothing Nothing mc mentions]
|
||||
SendMessageBroadcast mc -> withUser $ \user -> do
|
||||
contacts <- withFastStore' $ \db -> getUserContacts db cxt user
|
||||
withChatLock "sendMessageBroadcast" $ do
|
||||
@@ -2531,7 +2539,7 @@ processChatCommand cxt nm = \case
|
||||
contactId <- withFastStore $ \db -> getContactIdByName db user cName
|
||||
quotedItemId <- withFastStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg
|
||||
let mc = MCText msg
|
||||
processChatCommand cxt nm $ APISendMessages (SRDirect contactId) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc M.empty]
|
||||
processChatCommand cxt nm $ APISendMessages (SRDirect contactId) False Nothing False [ComposedMessage Nothing (Just quotedItemId) mc M.empty]
|
||||
DeleteMessage chatName deletedMsg -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg
|
||||
@@ -2756,7 +2764,7 @@ processChatCommand cxt nm = \case
|
||||
modMs <- withFastStore' $ \db -> getGroupModerators db cxt user gInfo
|
||||
let rcpModMs' = filter memberCurrent modMs
|
||||
msg = XGrpLinkAcpt GAAccepted role (memberId' m)
|
||||
void $ sendGroupMessage user gInfo scope ([m] <> rcpModMs') msg
|
||||
void $ sendGroupMessage user gInfo scope ([m] <> rcpModMs') False msg
|
||||
when (maxVersion (memberChatVRange m) < groupKnockingVersion) $
|
||||
forM_ (memberConn m) $ \mConn -> do
|
||||
let msg2 = XMsgNew $ mcSimple (MCText acceptedToGroupMessage)
|
||||
@@ -2858,7 +2866,7 @@ processChatCommand cxt nm = \case
|
||||
let mKey m = if isJust rosterVer then MemberKey <$> memberPubKey m else Nothing
|
||||
events = L.map (\m@GroupMember {memberId} -> XGrpMemRole memberId newRole (mKey m) rosterVer) memsToChange'
|
||||
recipients = filter memberCurrent members
|
||||
(msgs_, _gsr) <- sendGroupMessages user gInfo Nothing False recipients events
|
||||
(msgs_, _gsr) <- sendGroupMessages user gInfo Nothing False recipients False events
|
||||
let signed = any (either (const False) (isJust . signedMsg_)) msgs_
|
||||
itemsData = zipWith (fmap . sndItemData) memsToChange (L.toList msgs_)
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing False
|
||||
@@ -2906,7 +2914,7 @@ processChatCommand cxt nm = \case
|
||||
let mrs = if blockFlag then MRSBlocked else MRSUnrestricted
|
||||
events = L.map (\GroupMember {memberId} -> XGrpMemRestrict memberId MemberRestrictions {restriction = mrs}) blockMems'
|
||||
recipients = filter memberCurrent remainingMems
|
||||
(msgs_, _gsr) <- sendGroupMessages_ user gInfo recipients events
|
||||
(msgs_, _gsr) <- sendGroupMessages_ user gInfo recipients False events
|
||||
let msgSigned = any (either (const False) (isJust . signedMsg_)) msgs_
|
||||
itemsData = zipWith (fmap . sndItemData) blockMems (L.toList msgs_)
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing False
|
||||
@@ -2999,7 +3007,7 @@ processChatCommand cxt nm = \case
|
||||
Just memsToDelete' -> do
|
||||
let chatScope = toChatScope <$> chatScopeInfo
|
||||
events = L.map (\GroupMember {memberId} -> XGrpMemDel memberId withMessages rosterVer) memsToDelete'
|
||||
(msgs_, _gsr) <- sendGroupMessages user gInfo chatScope False recipients events
|
||||
(msgs_, _gsr) <- sendGroupMessages user gInfo chatScope False recipients False events
|
||||
let signed = any (either (const False) (isJust . signedMsg_)) msgs_
|
||||
itemsData_ = zipWith (fmap . sndItemData) memsToDelete (L.toList msgs_)
|
||||
skipUnwantedItem = \case
|
||||
@@ -3060,7 +3068,7 @@ processChatCommand cxt nm = \case
|
||||
-- Relay leaving channel: create delivery job for cursor-based sending and async connection cleanup.
|
||||
leaveChannelRelay gInfo = do
|
||||
msg@SndMessage {msgBody, signedMsg_} <-
|
||||
liftEither . runIdentity =<< lift (createSndMessages $ Identity (GroupId groupId, groupMsgSigning gInfo XGrpLeave, XGrpLeave))
|
||||
liftEither . runIdentity =<< lift (createSndMessages $ Identity (GroupId groupId, groupMsgSigning False gInfo XGrpLeave, XGrpLeave))
|
||||
let body = encodeBatchElement signedMsg_ msgBody
|
||||
withFastStore' $ \db -> do
|
||||
deleteGroupDeliveryTasks db gInfo
|
||||
@@ -3286,7 +3294,7 @@ processChatCommand cxt nm = \case
|
||||
qiId <- getGroupChatItemIdByText db user gId cName quotedMsg
|
||||
(gInfo, qiId,) <$> liftIO (getMessageMentions db user gId msg)
|
||||
let mc = MCText msg
|
||||
processChatCommand cxt nm $ APISendMessages (SRGroup (groupId' gInfo) Nothing (sendAsGroup' gInfo Nothing)) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc mentions]
|
||||
processChatCommand cxt nm $ APISendMessages (SRGroup (groupId' gInfo) Nothing (sendAsGroup' gInfo Nothing)) False Nothing False [ComposedMessage Nothing (Just quotedItemId) mc mentions]
|
||||
ClearNoteFolder -> withUser $ \user -> do
|
||||
folderId <- withFastStore (`getUserNoteFolderId` user)
|
||||
processChatCommand cxt nm $ APIClearChat (ChatRef CTLocal folderId Nothing)
|
||||
@@ -3327,7 +3335,7 @@ processChatCommand cxt nm = \case
|
||||
chatRef <- getChatRef user chatName
|
||||
case chatRef of
|
||||
ChatRef CTLocal folderId _ -> processChatCommand cxt nm $ APICreateChatItems folderId [composedMessage (Just f) (MCFile "")]
|
||||
_ -> withSendRef user chatRef $ \sendRef -> processChatCommand cxt nm $ APISendMessages sendRef False Nothing [composedMessage (Just f) (MCFile "")]
|
||||
_ -> withSendRef user chatRef $ \sendRef -> processChatCommand cxt nm $ APISendMessages sendRef False Nothing False [composedMessage (Just f) (MCFile "")]
|
||||
SendImage chatName f@(CryptoFile fPath _) -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
withSendRef user chatRef $ \sendRef -> do
|
||||
@@ -3336,7 +3344,7 @@ processChatCommand cxt nm = \case
|
||||
fileSize <- getFileSize filePath
|
||||
unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath}
|
||||
-- TODO include file description for preview
|
||||
processChatCommand cxt nm $ APISendMessages sendRef False Nothing [composedMessage (Just f) (MCImage "" fixedImagePreview)]
|
||||
processChatCommand cxt nm $ APISendMessages sendRef False Nothing False [composedMessage (Just f) (MCImage "" fixedImagePreview)]
|
||||
ForwardFile chatName fileId -> forwardFile chatName fileId SendFile
|
||||
ForwardImage chatName fileId -> forwardFile chatName fileId SendImage
|
||||
SendFileDescription _chatName _f -> throwCmdError "TODO"
|
||||
@@ -3375,7 +3383,7 @@ processChatCommand cxt nm = \case
|
||||
(gInfo, sharedMsgId) <- withFastStore $ \db -> (,) <$> getGroupInfo db cxt user groupId <*> getSharedMsgIdByFileId db userId fileId
|
||||
chatScopeInfo <- mapM (getChatScopeInfo cxt user) scope
|
||||
recipients <- getGroupRecipients cxt user gInfo chatScopeInfo groupKnockingVersion
|
||||
void . sendGroupMessage user gInfo scope recipients $ XFileCancel sharedMsgId
|
||||
void . sendGroupMessage user gInfo scope recipients False $ XFileCancel sharedMsgId
|
||||
pure $ CRSndFileCancelled user (Just aci) ftm fts
|
||||
(Just _, _) -> throwChatError $ CEFileInternal "invalid chat ref for file transfer"
|
||||
where
|
||||
@@ -3432,10 +3440,10 @@ processChatCommand cxt nm = \case
|
||||
let prefs' = setPreference f allowed_ $ Just userPreferences
|
||||
updateContactPrefs user ct prefs'
|
||||
SetGroupFeature (AGFNR f) gName enabled ->
|
||||
updateGroupProfileByName gName $ \p ->
|
||||
updateGroupProfileByName_ (Just $ toGroupFeature f) gName $ \p ->
|
||||
p {groupPreferences = Just . setGroupPreference f enabled $ groupPreferences p}
|
||||
SetGroupFeatureRole (AGFR f) gName enabled role ->
|
||||
updateGroupProfileByName gName $ \p ->
|
||||
updateGroupProfileByName_ (Just $ toGroupFeature f) gName $ \p ->
|
||||
p {groupPreferences = Just . setGroupPreferenceRole f enabled role $ groupPreferences p}
|
||||
SetGroupMemberAdmissionReview gName reviewAdmissionApplication ->
|
||||
updateGroupProfileByName gName $ \p@GroupProfile {memberAdmission} ->
|
||||
@@ -3921,14 +3929,14 @@ processChatCommand cxt nm = \case
|
||||
withStore $ \db -> getGroupMemberByMemberId db cxt user gInfo' businessId
|
||||
let p'' = p' {displayName, fullName, shortDescr, image} :: GroupProfile
|
||||
recipients = filter memberCurrentOrPending oldMs
|
||||
void $ sendGroupMessage user gInfo' Nothing recipients (XGrpInfo p'')
|
||||
void $ sendGroupMessage user gInfo' Nothing recipients False (XGrpInfo p'')
|
||||
let ps' = fromMaybe defaultBusinessGroupPrefs $ groupPreferences p'
|
||||
recipients = filter memberCurrentOrPending newMs
|
||||
sendGroupMessage user gInfo' Nothing recipients $ XGrpPrefs ps'
|
||||
sendGroupMessage user gInfo' Nothing recipients False $ XGrpPrefs ps'
|
||||
Nothing -> do
|
||||
void $ setGroupLinkData' nm user gInfo'
|
||||
recipients <- getRecipients
|
||||
sendGroupMessage user gInfo' Nothing recipients (XGrpInfo p')
|
||||
sendGroupMessage user gInfo' Nothing recipients False (XGrpInfo p')
|
||||
where
|
||||
getRecipients
|
||||
| useRelays' gInfo' = withFastStore' $ \db -> getGroupRelayMembers db cxt user gInfo'
|
||||
@@ -3957,8 +3965,9 @@ processChatCommand cxt nm = \case
|
||||
assertDeletable gInfo items
|
||||
assertUserGroupRole gInfo GRModerator
|
||||
let msgMemIds = itemsMsgMemIds gInfo items
|
||||
events = L.nonEmpty $ map (\(msgId, memId) -> XMsgDel msgId memId (toMsgScope gInfo <$> chatScopeInfo) False) msgMemIds
|
||||
mapM_ (sendGroupMessages_ user gInfo ms) events
|
||||
-- moderation deletes always sign (attributable; avoids the catch-up-moderator divergence)
|
||||
signedEvents = L.nonEmpty $ map (\(msgId, memId) -> let evt = XMsgDel msgId memId (toMsgScope gInfo <$> chatScopeInfo) False in (groupMsgSigning True gInfo evt, evt)) msgMemIds
|
||||
mapM_ (sendGroupSignedMessages_ gInfo ms) signedEvents
|
||||
delGroupChatItems user gInfo chatScopeInfo items True
|
||||
where
|
||||
assertDeletable :: GroupInfo -> [CChatItem 'CTGroup] -> CM ()
|
||||
@@ -3992,9 +4001,16 @@ processChatCommand cxt nm = \case
|
||||
then deleteGroupCIs user gInfo chatScopeInfo items m deletedTs
|
||||
else markGroupCIsDeleted user gInfo chatScopeInfo items m deletedTs
|
||||
updateGroupProfileByName :: GroupName -> (GroupProfile -> GroupProfile) -> CM ChatResponse
|
||||
updateGroupProfileByName gName update = withUser $ \user -> do
|
||||
updateGroupProfileByName = updateGroupProfileByName_ Nothing
|
||||
updateGroupProfileByName_ :: Maybe GroupFeature -> GroupName -> (GroupProfile -> GroupProfile) -> CM ChatResponse
|
||||
updateGroupProfileByName_ feature_ gName update = withUser $ \user -> do
|
||||
gInfo@GroupInfo {groupProfile = p} <- withStore $ \db ->
|
||||
getGroupIdByName db user gName >>= getGroupInfo db cxt user
|
||||
forM_ feature_ $ \feature -> do
|
||||
let channel = useRelays' gInfo
|
||||
applicable = if channel then groupFeatureInChannel feature else groupFeatureInRegularGroup feature
|
||||
unless applicable $
|
||||
throwCmdError $ T.unpack (groupFeatureNameText feature) <> " is not available in " <> (if channel then "channels" else "groups")
|
||||
runUpdateGroupProfile user gInfo $ update p
|
||||
withCurrentCall :: ContactId -> (User -> Contact -> Call -> CM (Maybe Call)) -> CM ChatResponse
|
||||
withCurrentCall ctId action = do
|
||||
@@ -4592,17 +4608,17 @@ processChatCommand cxt nm = \case
|
||||
quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True)
|
||||
quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False)
|
||||
quoteData _ = throwError SEInvalidQuote
|
||||
sendGroupContentMessages :: User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
|
||||
sendGroupContentMessages user gInfo scope showGroupAsSender live itemTTL cmrs = do
|
||||
sendGroupContentMessages :: User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> Bool -> Maybe Int -> Bool -> NonEmpty ComposedMessageReq -> CM ChatResponse
|
||||
sendGroupContentMessages user gInfo scope showGroupAsSender live itemTTL sign cmrs = do
|
||||
assertMultiSendable live cmrs
|
||||
chatScopeInfo <- mapM (getChatScopeInfo cxt user) scope
|
||||
recipients <- getGroupRecipients cxt user gInfo chatScopeInfo modsCompatVersion
|
||||
sendGroupContentMessages_ user gInfo scope showGroupAsSender chatScopeInfo recipients live itemTTL cmrs
|
||||
sendGroupContentMessages_ user gInfo scope showGroupAsSender chatScopeInfo recipients live itemTTL sign cmrs
|
||||
where
|
||||
hasReport = any (\(ComposedMessage {msgContent}, _, _, _) -> isReport msgContent) cmrs
|
||||
modsCompatVersion = if hasReport then contentReportsVersion else groupKnockingVersion
|
||||
sendGroupContentMessages_ :: User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> Maybe GroupChatScopeInfo -> [GroupMember] -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
|
||||
sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} scope showGroupAsSender chatScopeInfo recipients live itemTTL cmrs = do
|
||||
sendGroupContentMessages_ :: User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> Maybe GroupChatScopeInfo -> [GroupMember] -> Bool -> Maybe Int -> Bool -> NonEmpty ComposedMessageReq -> CM ChatResponse
|
||||
sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} scope showGroupAsSender chatScopeInfo recipients live itemTTL sign cmrs = do
|
||||
forM_ allowedRole $ assertUserGroupRole gInfo
|
||||
assertGroupContentAllowed
|
||||
processComposedMessages
|
||||
@@ -4631,7 +4647,7 @@ processChatCommand cxt nm = \case
|
||||
(fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers (length recipients)
|
||||
timed_ <- sndGroupCITimed live gInfo itemTTL
|
||||
(chatMsgEvents, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_
|
||||
(msgs_, gsr) <- sendGroupMessages user gInfo Nothing showGroupAsSender recipients chatMsgEvents
|
||||
(msgs_, gsr) <- sendGroupMessages user gInfo Nothing showGroupAsSender recipients sign chatMsgEvents
|
||||
let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList ciFiles_) (L.toList quotedItems_) (L.toList msgs_)
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo chatScopeInfo) showGroupAsSender itemsData timed_ live
|
||||
when (length cis_ /= length cmrs) $ logError "sendGroupContentMessages: cmrs and cis_ length mismatch"
|
||||
@@ -4650,7 +4666,11 @@ processChatCommand cxt nm = \case
|
||||
let User {profile = LocalProfile {localBadge}} = user
|
||||
fileSize <- checkSndFile (if incognitoMembership gInfo then Nothing else localBadge) file
|
||||
(fInv, ciFile) <- xftpSndFileTransfer user file fileSize n $ CGGroup gInfo recipients
|
||||
pure (Just fInv, Just ciFile)
|
||||
fInv' <-
|
||||
if sign && useRelays' gInfo
|
||||
then (\d -> (fInv :: FileInvitation) {fileDigest = Just d}) <$> cryptoFileDigest file
|
||||
else pure fInv
|
||||
pure (Just fInv', Just ciFile)
|
||||
Nothing -> pure (Nothing, Nothing)
|
||||
prepareMsgs :: NonEmpty (ComposedMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup)))
|
||||
prepareMsgs cmsFileInvs timed_ = withFastStore $ \db ->
|
||||
@@ -5301,7 +5321,7 @@ chatCommandP =
|
||||
"/_get content types " *> (APIGetChatContentTypes <$> chatRefP),
|
||||
"/_get items " *> (APIGetChatItems <$> chatPaginationP <*> optional (" search=" *> textP)),
|
||||
"/_get item info " *> (APIGetChatItemInfo <$> chatRefP <* A.space <*> A.decimal),
|
||||
"/_send " *> (APISendMessages <$> sendRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)),
|
||||
"/_send " *> (APISendMessages <$> sendRefP <*> liveMessageP <*> sendMessageTTLP <*> signMessagesP <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)),
|
||||
"/_create tag " *> (APICreateChatTag <$> jsonP),
|
||||
"/_tags " *> (APISetChatTags <$> chatRefP <*> optional _strP),
|
||||
"/_delete tag " *> (APIDeleteChatTag <$> A.decimal),
|
||||
@@ -5587,6 +5607,7 @@ chatCommandP =
|
||||
"/set disappear @" *> (SetContactTimedMessages <$> displayNameP <*> optional (A.space *> timedMessagesEnabledP)),
|
||||
"/set disappear " *> (SetUserTimedMessages <$> (("yes" $> True) <|> ("no" $> False))),
|
||||
"/set reports #" *> (SetGroupFeature (AGFNR SGFReports) <$> displayNameP <*> _strP),
|
||||
"/set signatures #" *> (SetGroupFeature (AGFNR SGFSignMessages) <$> displayNameP <*> _strP),
|
||||
"/set support #" *> (SetGroupFeature (AGFNR SGFSupport) <$> displayNameP <*> (A.space *> strP)),
|
||||
"/set links #" *> (SetGroupFeatureRole (AGFR SGFSimplexLinks) <$> displayNameP <*> _strP <*> optional memberRole),
|
||||
"/set admission review #" *> (SetGroupMemberAdmissionReview <$> displayNameP <*> (A.space *> memberCriteriaP)),
|
||||
@@ -5679,6 +5700,7 @@ chatCommandP =
|
||||
pure [composedMessage Nothing text]
|
||||
updatedMessagesTextP = (`UpdatedMessage` []) <$> mcTextP
|
||||
liveMessageP = " live=" *> onOffP <|> pure False
|
||||
signMessagesP = " sign=" *> onOffP <|> pure False
|
||||
sendMessageTTLP = " ttl=" *> ((Just <$> A.decimal) <|> ("default" $> Nothing)) <|> pure Nothing
|
||||
receiptSettings = do
|
||||
enable <- onOffP
|
||||
|
||||
@@ -397,6 +397,12 @@ xftpSndFileTransfer_ user file@(CryptoFile filePath cfArgs) fileSize n contactOr
|
||||
ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP}
|
||||
pure (fInv, ciFile, ft)
|
||||
|
||||
cryptoFileDigest :: CryptoFile -> CM FD.FileDigest
|
||||
cryptoFileDigest (CryptoFile filePath cfArgs) = do
|
||||
fsPath <- lift $ toFSFilePath filePath
|
||||
r <- liftIO $ runExceptT $ CF.readFile (CryptoFile fsPath cfArgs)
|
||||
either (throwChatError . CEInternalError . show) (pure . FD.FileDigest . LC.sha512Hash) r
|
||||
|
||||
xftpSndFileRedirect :: User -> FileTransferId -> ValidFileDescription 'FRecipient -> CM FileTransferMeta
|
||||
xftpSndFileRedirect user ftId vfd = do
|
||||
let fileName = "redirect.yaml"
|
||||
@@ -2148,16 +2154,19 @@ createSndMessages idsEvents = do
|
||||
encodeMessage sharedMsgId =
|
||||
encodeChatMessage maxEncodedMsgLength ChatMessage {chatVRange = vr, msgId = Just sharedMsgId, chatMsgEvent = evnt}
|
||||
|
||||
groupMsgSigning :: GroupInfo -> ChatMsgEvent e -> Maybe MsgSigning
|
||||
groupMsgSigning gInfo@GroupInfo {membership = GroupMember {memberId}, groupKeys = Just GroupKeys {publicGroupId, memberPrivKey}} evt
|
||||
| useRelays' gInfo && requiresSignature (toCMEventTag evt) =
|
||||
groupMsgSigning :: Bool -> GroupInfo -> ChatMsgEvent e -> Maybe MsgSigning
|
||||
groupMsgSigning sign gInfo@GroupInfo {membership = GroupMember {memberId}, groupKeys = Just GroupKeys {publicGroupId, memberPrivKey}} evt
|
||||
| useRelays' gInfo && shouldSign =
|
||||
Just $ MsgSigning CBGroup (smpEncode (publicGroupId, memberId)) KRMember memberPrivKey
|
||||
groupMsgSigning _ _ = Nothing
|
||||
where
|
||||
tag = toCMEventTag evt
|
||||
shouldSign = requiresSignature tag || (sign && signableContent tag)
|
||||
groupMsgSigning _ _ _ = Nothing
|
||||
|
||||
sendGroupMemberMessages :: forall e. MsgEncodingI e => User -> GroupInfo -> Connection -> NonEmpty (ChatMsgEvent e) -> CM ()
|
||||
sendGroupMemberMessages user gInfo@GroupInfo {groupId} conn events = do
|
||||
when (connDisabled conn) $ throwChatError (CEConnectionDisabled conn)
|
||||
let idsEvts = L.map (\evt -> (GroupId groupId, groupMsgSigning gInfo evt, evt)) events
|
||||
let idsEvts = L.map (\evt -> (GroupId groupId, groupMsgSigning False gInfo evt, evt)) events
|
||||
mode = if useRelays' gInfo then BMBinary else BMJson
|
||||
(errs, msgs) <- lift $ partitionEithers . L.toList <$> createSndMessages idsEvts
|
||||
unless (null errs) $ toView $ CEvtChatErrors errs
|
||||
@@ -2293,15 +2302,15 @@ deliverMessagesB msgReqs = do
|
||||
where
|
||||
updatePQ = updateConnPQSndEnabled db connId pqSndEnabled'
|
||||
|
||||
sendGroupMessage :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage
|
||||
sendGroupMessage user gInfo gcScope members chatMsgEvent = do
|
||||
sendGroupMessages user gInfo gcScope False members (chatMsgEvent :| []) >>= \case
|
||||
sendGroupMessage :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> [GroupMember] -> Bool -> ChatMsgEvent e -> CM SndMessage
|
||||
sendGroupMessage user gInfo gcScope members sign chatMsgEvent = do
|
||||
sendGroupMessages user gInfo gcScope False members sign (chatMsgEvent :| []) >>= \case
|
||||
((Right msg) :| [], _) -> pure msg
|
||||
_ -> throwChatError $ CEInternalError "sendGroupMessage: expected 1 message"
|
||||
|
||||
sendGroupMessage' :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage
|
||||
sendGroupMessage' user gInfo members chatMsgEvent =
|
||||
sendGroupMessages_ user gInfo members (chatMsgEvent :| []) >>= \case
|
||||
sendGroupMessages_ user gInfo members False (chatMsgEvent :| []) >>= \case
|
||||
((Right msg) :| [], _) -> pure msg
|
||||
_ -> throwChatError $ CEInternalError "sendGroupMessage': expected 1 message"
|
||||
|
||||
@@ -2382,12 +2391,22 @@ sendRelayCapIfNeeded user gInfo = do
|
||||
void $ sendGroupMessage' user gInfo capableOwners (XGrpRelayCap RelayCapabilities {webDomain = currentWebDomain})
|
||||
withStore' $ \db -> updateRelaySentWebDomain db gInfo currentWebDomain
|
||||
|
||||
sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
|
||||
sendGroupMessages user gInfo scope asGroup members events = do
|
||||
sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> Bool -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
|
||||
sendGroupMessages user gInfo scope asGroup members sign events = do
|
||||
sendGroupProfileUpdate user gInfo scope asGroup members
|
||||
sendGroupMessages_ user gInfo members sign events
|
||||
|
||||
-- per-item signer variant of sendGroupMessages (used for per-item delete signing); preserves the profile-update prelude
|
||||
sendGroupSignedMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> NonEmpty (Maybe MsgSigning, ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
|
||||
sendGroupSignedMessages user gInfo scope asGroup members signedEvents = do
|
||||
sendGroupProfileUpdate user gInfo scope asGroup members
|
||||
sendGroupSignedMessages_ gInfo members signedEvents
|
||||
|
||||
sendGroupProfileUpdate :: User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> CM ()
|
||||
sendGroupProfileUpdate user gInfo scope asGroup members =
|
||||
-- TODO [knocking] send current profile to pending member after approval?
|
||||
when shouldSendProfileUpdate $
|
||||
sendProfileUpdate `catchAllErrors` eToView
|
||||
sendGroupMessages_ user gInfo members events
|
||||
where
|
||||
User {profile = p, userMemberProfileUpdatedAt} = user
|
||||
GroupInfo {userMemberProfileSentAt} = gInfo
|
||||
@@ -2414,9 +2433,12 @@ data GroupSndResult = GroupSndResult
|
||||
forwarded :: [GroupMember]
|
||||
}
|
||||
|
||||
sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
|
||||
sendGroupMessages_ _user gInfo@GroupInfo {groupId} recipientMembers events = do
|
||||
let idsEvts = L.map (\evt -> (GroupId groupId, groupMsgSigning gInfo evt, evt)) events
|
||||
sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> Bool -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
|
||||
sendGroupMessages_ _user gInfo recipientMembers sign events =
|
||||
sendGroupSignedMessages_ gInfo recipientMembers $ L.map (\evt -> (groupMsgSigning sign gInfo evt, evt)) events
|
||||
|
||||
sendGroupSignedMessages_ :: MsgEncodingI e => GroupInfo -> [GroupMember] -> NonEmpty (Maybe MsgSigning, ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
|
||||
sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents = do
|
||||
sndMsgs_ <- lift $ createSndMessages idsEvts
|
||||
recipientMembers' <- liftIO $ shuffleMembers recipientMembers
|
||||
let msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events}
|
||||
@@ -2437,6 +2459,8 @@ sendGroupMessages_ _user gInfo@GroupInfo {groupId} recipientMembers events = do
|
||||
pending = zipWith3 (\mId pReq r -> (mId, fmap snd pReq, r)) pendingMemIds pendingReqs stored
|
||||
pure (sndMsgs_, GroupSndResult {sentTo, pending, forwarded})
|
||||
where
|
||||
events = L.map snd signedEvents
|
||||
idsEvts = L.map (\(signing, evt) -> (GroupId groupId, signing, evt)) signedEvents
|
||||
shuffleMembers :: [GroupMember] -> IO [GroupMember]
|
||||
shuffleMembers ms = do
|
||||
let (adminMs, otherMs) = partition isAdmin ms
|
||||
@@ -2691,7 +2715,7 @@ saveSndChatItems user cd showGroupAsSender itemsData itemTimed live = do
|
||||
let hasLink_ = ciContentHasLink content (snd itemTexts)
|
||||
ciId <- createNewSndChatItem db user cd showGroupAsSender msg content quotedItem itemForwarded itemTimed live hasLink_ createdAt
|
||||
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
|
||||
let ci = mkChatItem_ cd showGroupAsSender ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live False hasLink_ createdAt Nothing (MSSVerified <$ signedMsg_) createdAt
|
||||
let ci = mkChatItem_ cd showGroupAsSender ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live False hasLink_ createdAt Nothing (toMsgVerified False (MSSVerified <$ signedMsg_)) createdAt
|
||||
Right <$> case cd of
|
||||
CDGroupSnd g _scope | not (null itemMentions) -> createGroupCIMentions db g ci itemMentions
|
||||
_ -> pure ci
|
||||
@@ -2722,7 +2746,7 @@ saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, msgSigned, forwardedByMem
|
||||
hasLink_ = ciContentHasLink content ft_
|
||||
(ciId, quotedItem, itemForwarded) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live userMention hasLink_ brokerTs createdAt
|
||||
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
|
||||
let ci = mkChatItem_ cd showAsGroup ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention hasLink_ brokerTs forwardedByMember msgSigned createdAt
|
||||
let ci = mkChatItem_ cd showAsGroup ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention hasLink_ brokerTs forwardedByMember (toMsgVerified (signMessagesRequired cd) msgSigned) createdAt
|
||||
ci' <- case toChatInfo cd of
|
||||
GroupChat g _ | not (null mentions') -> createGroupCIMentions db g ci mentions'
|
||||
_ -> pure ci
|
||||
@@ -2746,16 +2770,16 @@ saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, msgSigned, forwardedByMem
|
||||
_ -> Nothing
|
||||
|
||||
-- TODO [mentions] optimize by avoiding unnecessary parsing
|
||||
mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> Maybe MsgSigStatus -> UTCTime -> ChatItem c d
|
||||
mkChatItem cd showGroupAsSender ciId content file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember msgSigned currentTs =
|
||||
mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> MsgVerified -> UTCTime -> ChatItem c d
|
||||
mkChatItem cd showGroupAsSender ciId content file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember msgVerified currentTs =
|
||||
let ts@(_, ft_) = ciContentTexts content
|
||||
hasLink_ = ciContentHasLink content ft_
|
||||
in mkChatItem_ cd showGroupAsSender ciId content ts file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember msgSigned currentTs
|
||||
in mkChatItem_ cd showGroupAsSender ciId content ts file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember msgVerified currentTs
|
||||
|
||||
mkChatItem_ :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> (Text, Maybe MarkdownList) -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> Maybe MsgSigStatus -> UTCTime -> ChatItem c d
|
||||
mkChatItem_ cd showGroupAsSender ciId content (itemText, formattedText) file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember msgSigned currentTs =
|
||||
mkChatItem_ :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> (Text, Maybe MarkdownList) -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> MsgVerified -> UTCTime -> ChatItem c d
|
||||
mkChatItem_ cd showGroupAsSender ciId content (itemText, formattedText) file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember msgVerified currentTs =
|
||||
let itemStatus = ciCreateStatus content
|
||||
meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender msgSigned currentTs currentTs
|
||||
meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender msgVerified currentTs currentTs
|
||||
in ChatItem {chatDir = toCIDirection cd, meta, content, mentions = M.empty, formattedText, quotedItem, reactions = [], file}
|
||||
|
||||
ciContentHasLink :: CIContent d -> Maybe MarkdownList -> Bool
|
||||
@@ -2974,7 +2998,7 @@ createContactsFeatureItems user cts chatDir ciFeature ciOffer getPref = do
|
||||
cup' = getContactUserPreference f cups'
|
||||
|
||||
groupFeatures :: GroupInfo -> [AGroupFeature]
|
||||
groupFeatures g = if useRelays' g then channelGroupFeatures else allGroupFeatures
|
||||
groupFeatures g = if useRelays' g then channelGroupFeatures else regularGroupFeatures
|
||||
|
||||
createGroupFeatureChangedItems :: MsgDirectionI d => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent d) -> GroupInfo -> GroupInfo -> CM ()
|
||||
createGroupFeatureChangedItems user cd ciContent GroupInfo {fullGroupPreferences = gps} g'@GroupInfo {fullGroupPreferences = gps'} =
|
||||
@@ -3042,8 +3066,9 @@ createChatItems user itemTs_ dirsCIContents = do
|
||||
where
|
||||
createACI (content, sharedMsgId, msgSigned) = do
|
||||
let hasLink_ = ciContentHasLink content Nothing
|
||||
ciId <- createNewChatItemNoMsg db user cd showGroupAsSender content sharedMsgId hasLink_ msgSigned itemTs createdAt
|
||||
let ci = mkChatItem cd showGroupAsSender ciId content Nothing Nothing Nothing Nothing Nothing False False itemTs Nothing msgSigned createdAt
|
||||
msgVerified = toMsgVerified False msgSigned
|
||||
ciId <- createNewChatItemNoMsg db user cd showGroupAsSender content sharedMsgId hasLink_ msgVerified itemTs createdAt
|
||||
let ci = mkChatItem cd showGroupAsSender ciId content Nothing Nothing Nothing Nothing Nothing False False itemTs Nothing msgVerified createdAt
|
||||
pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci
|
||||
|
||||
-- rcvMem_ Nothing means message from channel - treated same as message from moderator,
|
||||
@@ -3076,9 +3101,9 @@ createLocalChatItems user cd itemsData createdAt = do
|
||||
createItem :: DB.Connection -> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList)) -> IO (ChatItem 'CTLocal 'MDSnd)
|
||||
createItem db (content, ciFile, itemForwarded, ts@(_, ft_)) = do
|
||||
let hasLink_ = ciContentHasLink content ft_
|
||||
ciId <- createNewChatItem_ db user cd False Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False False hasLink_ createdAt Nothing Nothing createdAt
|
||||
ciId <- createNewChatItem_ db user cd False Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False False hasLink_ createdAt Nothing MVUnsigned createdAt
|
||||
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
|
||||
pure $ mkChatItem_ cd False ciId content ts ciFile Nothing Nothing itemForwarded Nothing False False hasLink_ createdAt Nothing Nothing createdAt
|
||||
pure $ mkChatItem_ cd False ciId content ts ciFile Nothing Nothing itemForwarded Nothing False False hasLink_ createdAt Nothing MVUnsigned createdAt
|
||||
|
||||
withUser' :: (User -> CM ChatResponse) -> CM ChatResponse
|
||||
withUser' action =
|
||||
|
||||
@@ -349,13 +349,24 @@ processAgentMsgRcvFile _corrId aFileId msg = do
|
||||
Just targetPath -> do
|
||||
fsTargetPath <- lift $ toFSFilePath targetPath
|
||||
renameFile xftpPath fsTargetPath
|
||||
ci_ <- withStore $ \db -> do
|
||||
liftIO $ do
|
||||
updateRcvFileStatus db fileId FSComplete
|
||||
updateCIFileStatus db user fileId CIFSRcvComplete
|
||||
lookupChatItemByFileId db cxt user fileId
|
||||
agentXFTPDeleteRcvFile aFileId fileId
|
||||
toView $ maybe (CEvtRcvStandaloneFileComplete user fsTargetPath ft) (CEvtRcvFileComplete user) ci_
|
||||
badDigest <- case ft of
|
||||
RcvFileTransfer {fileInvitation = FileInvitation {fileDigest = Just d}, cryptoArgs} ->
|
||||
(/= d) <$> cryptoFileDigest (CryptoFile fsTargetPath cryptoArgs)
|
||||
_ -> pure False
|
||||
if badDigest
|
||||
then do
|
||||
aci_ <- resetRcvCIFileStatus user fileId (CIFSRcvError $ FileErrOther "file digest")
|
||||
forM_ aci_ cleanupACIFile
|
||||
agentXFTPDeleteRcvFile aFileId fileId
|
||||
forM_ aci_ $ \aci -> toView $ CEvtChatItemUpdated user aci
|
||||
else do
|
||||
ci_ <- withStore $ \db -> do
|
||||
liftIO $ do
|
||||
updateRcvFileStatus db fileId FSComplete
|
||||
updateCIFileStatus db user fileId CIFSRcvComplete
|
||||
lookupChatItemByFileId db cxt user fileId
|
||||
agentXFTPDeleteRcvFile aFileId fileId
|
||||
toView $ maybe (CEvtRcvStandaloneFileComplete user fsTargetPath ft) (CEvtRcvFileComplete user) ci_
|
||||
RFWARN e -> do
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateCIFileStatus db user fileId (CIFSRcvWarning $ agentFileError e)
|
||||
@@ -1422,7 +1433,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
allRelayMembers
|
||||
events = XGrpRelayNew <$> newlyActive
|
||||
unless (null recipients) $
|
||||
void $ sendGroupMessages user gInfo Nothing False recipients events
|
||||
void $ sendGroupMessages user gInfo Nothing False recipients False events
|
||||
where
|
||||
updateRelay :: DB.Connection -> GroupRelay -> ([GroupRelay], Bool, [ShortLinkContact]) -> IO ([GroupRelay], Bool, [ShortLinkContact])
|
||||
updateRelay db relay@GroupRelay {relayLink, relayStatus} (acc, changed, newlyActiveLinks) =
|
||||
@@ -2145,21 +2156,25 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
createContentItem gInfo Nothing Nothing
|
||||
-- no delivery task - message already forwarded by relay
|
||||
pure Nothing
|
||||
Just m@GroupMember {memberId} -> do
|
||||
(gInfo', m', scopeInfo) <- mkGetMessageChatScope cxt user gInfo m content msgScope_
|
||||
if blockedByAdmin m'
|
||||
then createBlockedByAdmin gInfo' (Just m') scopeInfo $> Nothing
|
||||
else case prohibitedGroupContent gInfo' m' scopeInfo content ft_ fInv_ False of
|
||||
Just f -> rejected gInfo' (Just m') scopeInfo f $> Nothing
|
||||
Nothing ->
|
||||
withStore' (\db -> getCIModeration db cxt user gInfo' memberId sharedMsgId_) >>= \case
|
||||
Just ciModeration -> do
|
||||
applyModeration gInfo' m' scopeInfo ciModeration
|
||||
withStore' $ \db -> deleteCIModeration db gInfo' memberId sharedMsgId_
|
||||
pure Nothing
|
||||
Nothing -> do
|
||||
createContentItem gInfo' (Just m') scopeInfo
|
||||
pure $ Just $ infoToDeliveryContext gInfo' scopeInfo sentAsGroup
|
||||
Just m@GroupMember {memberId}
|
||||
-- only an owner may post as the channel; a non-owner's signed asGroup post (e.g. relay-injected) must not render as the channel
|
||||
| sentAsGroup && memberRole' m < GROwner ->
|
||||
messageError "x.msg.new: member is not allowed to send as group" $> Nothing
|
||||
| otherwise -> do
|
||||
(gInfo', m', scopeInfo) <- mkGetMessageChatScope cxt user gInfo m content msgScope_
|
||||
if blockedByAdmin m'
|
||||
then createBlockedByAdmin gInfo' (Just m') scopeInfo $> Nothing
|
||||
else case prohibitedGroupContent gInfo' m' scopeInfo content ft_ fInv_ False of
|
||||
Just f -> rejected gInfo' (Just m') scopeInfo f $> Nothing
|
||||
Nothing ->
|
||||
withStore' (\db -> getCIModeration db cxt user gInfo' memberId sharedMsgId_) >>= \case
|
||||
Just ciModeration -> do
|
||||
applyModeration gInfo' m' scopeInfo ciModeration
|
||||
withStore' $ \db -> deleteCIModeration db gInfo' memberId sharedMsgId_
|
||||
pure Nothing
|
||||
Nothing -> do
|
||||
createContentItem gInfo' (Just m') scopeInfo
|
||||
pure $ Just $ infoToDeliveryContext gInfo' scopeInfo sentAsGroup
|
||||
where
|
||||
rejected gInfo' m' scopeInfo f = newChatItem gInfo' m' scopeInfo (ciContentNoParse $ CIRcvGroupFeatureRejected f) Nothing Nothing False
|
||||
timed_ gInfo' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo' itemTTL
|
||||
@@ -2223,7 +2238,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
groupMsgToView cInfo ci' {reactions}
|
||||
|
||||
groupMessageUpdate :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MsgMention -> Maybe MsgScope -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> Maybe Bool -> CM (Maybe DeliveryTaskContext)
|
||||
groupMessageUpdate gInfo@GroupInfo {groupId} m_ sharedMsgId mc mentions msgScope_ msg@RcvMessage {msgId} brokerTs ttl_ live_ asGroup_
|
||||
groupMessageUpdate gInfo@GroupInfo {groupId} m_ sharedMsgId mc mentions msgScope_ msg@RcvMessage {msgId, msgSigned} brokerTs ttl_ live_ asGroup_
|
||||
| Just m <- m_, prohibitedSimplexLinks gInfo m mc ft_ =
|
||||
messageWarning ("x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks) $> Nothing
|
||||
| otherwise = do
|
||||
@@ -2275,15 +2290,24 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
Nothing -> getGroupChatItemBySharedMsgId db user gInfo Nothing sharedMsgId
|
||||
(cci,) <$> getGroupChatScopeInfoForItem db cxt user gInfo (cChatItemId cci)
|
||||
case cci of
|
||||
CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC}
|
||||
| isSender m' -> updateCI False ci scopeInfo oldMC itemLive (Just $ memberId' m')
|
||||
CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', meta = CIMeta {itemLive, msgVerified = itemVerified}, content = CIRcvMsgContent oldMC}
|
||||
| isSender m' -> requireVerifiedEdit (CDGroupRcv gInfo scopeInfo m') itemVerified $ updateCI False ci scopeInfo oldMC itemLive (Just $ memberId' m')
|
||||
| otherwise -> messageError "x.msg.update: group member attempted to update a message of another member" $> Nothing
|
||||
CChatItem SMDRcv ci@ChatItem {chatDir = CIChannelRcv, meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC}
|
||||
| maybe True (\m -> memberRole' m == GROwner) m_ -> updateCI True ci scopeInfo oldMC itemLive Nothing
|
||||
CChatItem SMDRcv ci@ChatItem {chatDir = CIChannelRcv, meta = CIMeta {itemLive, msgVerified = itemVerified}, content = CIRcvMsgContent oldMC}
|
||||
| maybe True (\m -> memberRole' m == GROwner) m_ -> requireVerifiedEdit (CDChannelRcv gInfo scopeInfo) itemVerified $ updateCI True ci scopeInfo oldMC itemLive Nothing
|
||||
| otherwise -> messageError "x.msg.update: member attempted to update channel message" $> Nothing
|
||||
_ -> messageError "x.msg.update: invalid message update" $> Nothing
|
||||
where
|
||||
isSender m' = maybe False (\m -> sameMemberId (memberId' m) m') m_
|
||||
-- a verified item requires a verified edit (fail-closed): unsigned is a forgery (bad-signature item); signed-but-no-key is unverifiable (drop with a log)
|
||||
requireVerifiedEdit :: ChatDirection 'CTGroup 'MDRcv -> MsgVerified -> CM (Maybe DeliveryTaskContext) -> CM (Maybe DeliveryTaskContext)
|
||||
requireVerifiedEdit cd itemVerified action
|
||||
| itemVerified == MVSigned MSSVerified =
|
||||
case msgSigned of
|
||||
Just MSSVerified -> action
|
||||
Just MSSSignedNoKey -> logWarn "x.msg.update: unverified update of a signed item (no key to verify), dropped" $> Nothing
|
||||
Nothing -> createInternalChatItem user cd (CIRcvGroupEvent RGEMsgBadSignature) (Just brokerTs) $> Nothing
|
||||
| otherwise = action
|
||||
updateCI :: ShowGroupAsSender -> ChatItem 'CTGroup 'MDRcv -> Maybe GroupChatScopeInfo -> MsgContent -> Maybe Bool -> Maybe MemberId -> CM (Maybe DeliveryTaskContext)
|
||||
updateCI showGroupAsSender ci scopeInfo oldMC itemLive memberId = do
|
||||
let changed = mc /= oldMC
|
||||
@@ -2307,7 +2331,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
groupMessageDelete :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> Maybe MemberId -> Maybe MsgScope -> Bool -> RcvMessage -> UTCTime -> CM (Maybe DeliveryTaskContext)
|
||||
groupMessageDelete gInfo@GroupInfo {membership} m_ sharedMsgId sndMemberId_ scope_ onlyHistory rcvMsg brokerTs =
|
||||
findItem >>= \case
|
||||
Right cci@(CChatItem _ ci@ChatItem {chatDir}) -> case (chatDir, m_) of
|
||||
Right cci@(CChatItem _ ci@ChatItem {chatDir}) -> requireVerifiedDelete cci $ case (chatDir, m_) of
|
||||
(CIGroupRcv mem, Just m@GroupMember {memberId}) ->
|
||||
let msgMemberId = fromMaybe memberId sndMemberId_
|
||||
isAuthor = sameMemberId memberId mem
|
||||
@@ -2340,6 +2364,9 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
| senderRole < GRModerator -> do
|
||||
messageError $ "x.msg.del: message not found, message of another member with insufficient member permissions, " <> tshow e
|
||||
pure Nothing
|
||||
-- a forged unsigned moderation would pre-censor a not-yet-received post via CIModeration; require verified (relay moderation always signs)
|
||||
| useRelays' gInfo && msgSigned /= Just MSSVerified ->
|
||||
messageError ("x.msg.del: unverified moderation of message not yet received, " <> tshow e) $> Nothing
|
||||
| otherwise -> case scope_ of
|
||||
Just (MSMember scopeMemberId) ->
|
||||
withStore $ \db -> do
|
||||
@@ -2353,7 +2380,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
messageError ("x.msg.del: channel message not found, " <> tshow e) $> Nothing
|
||||
where
|
||||
isOwner = maybe True (\m -> memberRole' m == GROwner) m_
|
||||
RcvMessage {msgId} = rcvMsg
|
||||
RcvMessage {msgId, msgSigned} = rcvMsg
|
||||
findItem = do
|
||||
let tryMemberLookup mId =
|
||||
withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user gInfo mId sharedMsgId)
|
||||
@@ -2383,6 +2410,23 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
| senderRole < GRModerator || senderRole < memberRole =
|
||||
messageError "x.msg.del: message of another member with insufficient member permissions" $> Nothing
|
||||
| otherwise = a
|
||||
-- a verified item requires a verified delete (fail-closed): unsigned is a forgery (bad-signature item); signed-but-no-key is unverifiable (drop with a log)
|
||||
requireVerifiedDelete :: CChatItem 'CTGroup -> CM (Maybe DeliveryTaskContext) -> CM (Maybe DeliveryTaskContext)
|
||||
requireVerifiedDelete cci@(CChatItem _ ChatItem {chatDir, meta = CIMeta {msgVerified = itemVerified}}) action
|
||||
| itemVerified == MVSigned MSSVerified =
|
||||
case msgSigned of
|
||||
Just MSSVerified -> action
|
||||
Just MSSSignedNoKey -> logWarn "x.msg.del: unverified delete of a signed item (no key to verify), dropped" $> Nothing
|
||||
Nothing -> do
|
||||
scopeInfo <- withStore $ \db -> getGroupChatScopeInfoForItem db cxt user gInfo (cChatItemId cci)
|
||||
let cd :: ChatDirection 'CTGroup 'MDRcv
|
||||
cd = case chatDir of
|
||||
CIGroupRcv mem -> CDGroupRcv gInfo scopeInfo mem
|
||||
CIChannelRcv -> CDChannelRcv gInfo scopeInfo
|
||||
CIGroupSnd -> CDGroupRcv gInfo scopeInfo membership
|
||||
createInternalChatItem user cd (CIRcvGroupEvent RGEMsgBadSignature) (Just brokerTs)
|
||||
pure Nothing
|
||||
| otherwise = action
|
||||
delete :: CChatItem 'CTGroup -> Bool -> Maybe GroupMember -> CM (Maybe DeliveryTaskContext)
|
||||
delete cci asGroup byGroupMember = do
|
||||
scopeInfo <- withStore $ \db -> getGroupChatScopeInfoForItem db cxt user gInfo (cChatItemId cci)
|
||||
|
||||
@@ -417,6 +417,12 @@ toChatInfo = \case
|
||||
CDLocalSnd l -> LocalChat l
|
||||
CDLocalRcv l -> LocalChat l
|
||||
|
||||
signMessagesRequired :: ChatDirection c d -> Bool
|
||||
signMessagesRequired = \case
|
||||
CDChannelRcv g _ -> groupFeatureAllowed SGFSignMessages g
|
||||
CDGroupRcv g _ _ -> groupFeatureAllowed SGFSignMessages g
|
||||
_ -> False
|
||||
|
||||
contactChatDeleted :: ChatDirection c d -> Bool
|
||||
contactChatDeleted = \case
|
||||
CDDirectSnd Contact {chatDeleted} -> chatDeleted
|
||||
@@ -517,7 +523,7 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta
|
||||
editable :: Bool,
|
||||
forwardedByMember :: Maybe GroupMemberId,
|
||||
showGroupAsSender :: ShowGroupAsSender,
|
||||
msgSigned :: Maybe MsgSigStatus,
|
||||
msgVerified :: MsgVerified,
|
||||
createdAt :: UTCTime,
|
||||
updatedAt :: UTCTime
|
||||
}
|
||||
@@ -525,12 +531,12 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta
|
||||
|
||||
type ShowGroupAsSender = Bool
|
||||
|
||||
mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe Bool -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> Bool -> Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> Bool -> Maybe MsgSigStatus -> UTCTime -> UTCTime -> CIMeta c d
|
||||
mkCIMeta itemId itemContent itemText itemStatus sentViaProxy itemSharedMsgId itemForwarded itemDeleted itemEdited itemTimed itemLive userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender msgSigned createdAt updatedAt =
|
||||
mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe Bool -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> Bool -> Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> Bool -> MsgVerified -> UTCTime -> UTCTime -> CIMeta c d
|
||||
mkCIMeta itemId itemContent itemText itemStatus sentViaProxy itemSharedMsgId itemForwarded itemDeleted itemEdited itemTimed itemLive userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender msgVerified createdAt updatedAt =
|
||||
let deletable = deletable' itemContent itemDeleted itemTs nominalDay currentTs
|
||||
editable = deletable && isNothing itemForwarded
|
||||
hasLink = BoolDef hasLink_
|
||||
in CIMeta {itemId, itemTs, itemText, itemStatus, sentViaProxy, itemSharedMsgId, itemForwarded, itemDeleted, itemEdited, itemTimed, itemLive, userMention, hasLink, deletable, editable, forwardedByMember, showGroupAsSender, msgSigned, createdAt, updatedAt}
|
||||
in CIMeta {itemId, itemTs, itemText, itemStatus, sentViaProxy, itemSharedMsgId, itemForwarded, itemDeleted, itemEdited, itemTimed, itemLive, userMention, hasLink, deletable, editable, forwardedByMember, showGroupAsSender, msgVerified, createdAt, updatedAt}
|
||||
|
||||
deletable' :: forall c d. ChatTypeI c => CIContent d -> Maybe (CIDeleted c) -> UTCTime -> NominalDiffTime -> UTCTime -> Bool
|
||||
deletable' itemContent itemDeleted itemTs allowedInterval currentTs =
|
||||
@@ -561,7 +567,7 @@ dummyMeta itemId ts itemText =
|
||||
editable = False,
|
||||
forwardedByMember = Nothing,
|
||||
showGroupAsSender = False,
|
||||
msgSigned = Nothing,
|
||||
msgVerified = MVUnsigned,
|
||||
createdAt = ts,
|
||||
updatedAt = ts
|
||||
}
|
||||
|
||||
@@ -1350,6 +1350,14 @@ requiresSignature = \case
|
||||
XInfo_ -> True
|
||||
_ -> False
|
||||
|
||||
-- | Content events a member may sign (XMsgNew opt-in; XMsgUpdate/XMsgDel when the target was signed).
|
||||
signableContent :: CMEventTag e -> Bool
|
||||
signableContent = \case
|
||||
XMsgNew_ -> True
|
||||
XMsgUpdate_ -> True
|
||||
XMsgDel_ -> True
|
||||
_ -> False
|
||||
|
||||
-- TODO [relays] can be tightened — sender keys are now disseminated via
|
||||
-- TODO prepended XGrpMemNew before forwarded XInfo/XGrpLeave reach the recipient.
|
||||
-- Allow signed but unverified XGrpLeave/XInfo between subscribers when sender's key is unknown.
|
||||
|
||||
@@ -33,6 +33,7 @@ import qualified Data.Aeson as J
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Int (Int64)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (UTCTime, getCurrentTime)
|
||||
@@ -155,7 +156,7 @@ getMsgDeliveryTask_ db taskId =
|
||||
toTask ((Only taskId') :. jobScopeRow :. (senderGMId, senderMemberId, senderMemberName, brokerTs, Binary msgBody, chatBinding_, sigs_, BI showGroupAsSender)) =
|
||||
case (toJobScope_ jobScopeRow, J.eitherDecodeStrict' msgBody) of
|
||||
(Just jobScope, Right chatMsg) ->
|
||||
let fwdSender = if showGroupAsSender then FwdChannel else FwdMember senderMemberId senderMemberName
|
||||
let fwdSender = if showGroupAsSender && isNothing chatBinding_ then FwdChannel else FwdMember senderMemberId senderMemberName
|
||||
-- Re-parsed from msg_body: validates stored content against current code.
|
||||
-- Signed: original bytes preserved (re-encoding would invalidate signature).
|
||||
-- Unsigned: re-encoded from parsed ChatMessage on forward (sanitizes content).
|
||||
|
||||
@@ -96,6 +96,7 @@ import Simplex.Chat.Messages.CIContent
|
||||
import Simplex.Chat.Store.Messages
|
||||
import Simplex.Chat.Store.Profiles
|
||||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.FileTransfer.Description (FileDigest)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol (AgentMsgId, UserId)
|
||||
import Simplex.Messaging.Agent.Store.AgentStore (firstRow, firstRow', maybeFirstRow)
|
||||
@@ -447,7 +448,7 @@ createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@File
|
||||
pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, fileType = FTNormal, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing, cryptoArgs = Nothing}
|
||||
|
||||
createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> Maybe GroupMember -> FileType -> Maybe SharedMsgId -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer
|
||||
createRcvGroupFileTransfer db userId GroupInfo {groupId, localDisplayName = gName} m_ fileType sharedMsgId_ f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
|
||||
createRcvGroupFileTransfer db userId GroupInfo {groupId, localDisplayName = gName} m_ fileType sharedMsgId_ f@FileInvitation {fileName, fileSize, fileDigest, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
|
||||
let rfdId = (\RcvFileDescr {fileDescrId} -> fileDescrId) <$> rfd_
|
||||
@@ -459,8 +460,8 @@ createRcvGroupFileTransfer db userId GroupInfo {groupId, localDisplayName = gNam
|
||||
fileId <- liftIO $ do
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_type, shared_msg_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)"
|
||||
(userId, groupId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, fileType, sharedMsgId_, currentTs, currentTs)
|
||||
"INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_type, shared_msg_id, created_at, updated_at, file_digest) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)"
|
||||
((userId, groupId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, fileType, sharedMsgId_, currentTs, currentTs) :. Only fileDigest)
|
||||
insertedRowId db
|
||||
liftIO $
|
||||
DB.execute
|
||||
@@ -632,7 +633,7 @@ getRcvFileTransfer_ db userId fileId = do
|
||||
SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name,
|
||||
f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name,
|
||||
f.file_path, f.file_crypto_key, f.file_crypto_nonce, r.file_inline, r.rcv_file_inline,
|
||||
r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name, f.file_type
|
||||
r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name, f.file_type, f.file_digest
|
||||
FROM rcv_files r
|
||||
JOIN files f USING (file_id)
|
||||
LEFT JOIN contacts cs ON cs.contact_id = f.contact_id
|
||||
@@ -646,9 +647,9 @@ getRcvFileTransfer_ db userId fileId = do
|
||||
where
|
||||
rcvFileTransfer ::
|
||||
Maybe RcvFileDescr ->
|
||||
(FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe BoolInt) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, BoolInt, BoolInt) :. (Maybe ContactName, FileType) ->
|
||||
(FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe BoolInt) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, BoolInt, BoolInt) :. (Maybe ContactName, FileType, Maybe FileDigest) ->
|
||||
ExceptT StoreError IO RcvFileTransfer
|
||||
rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileKey, fileNonce, fileInline, rcvFileInline, agentRcvFileId, BI agentRcvFileDeleted, BI userApprovedRelays) :. (groupName_, fileType)) =
|
||||
rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileKey, fileNonce, fileInline, rcvFileInline, agentRcvFileId, BI agentRcvFileDeleted, BI userApprovedRelays) :. (groupName_, fileType, fileDigest_)) =
|
||||
case contactName_ <|> memberName_ <|> groupName_ <|> standaloneName_ of
|
||||
Nothing -> throwError $ SERcvFileInvalid fileId
|
||||
Just name ->
|
||||
@@ -663,7 +664,7 @@ getRcvFileTransfer_ db userId fileId = do
|
||||
(Just _, Just _) -> Just "" -- filePath marks files that are accepted from contact or, in this case, set by createRcvDirectFileTransfer
|
||||
_ -> Nothing
|
||||
ft senderDisplayName fileStatus =
|
||||
let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing}
|
||||
let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = fileDigest_, fileConnReq, fileInline, fileDescr = Nothing}
|
||||
cryptoArgs = CFArgs <$> fileKey <*> fileNonce
|
||||
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId, agentRcvFileDeleted, userApprovedRelays}) <$> rfd_
|
||||
in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, fileType, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId, cryptoArgs}
|
||||
|
||||
@@ -545,7 +545,7 @@ setSupportChatMemberAttention db cxt user g m memberAttention = do
|
||||
|
||||
createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> ShowGroupAsSender -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> UTCTime -> IO ChatItemId
|
||||
createNewSndChatItem db user chatDirection showGroupAsSender SndMessage {msgId, sharedMsgId, signedMsg_} ciContent quotedItem itemForwarded timed live hasLink createdAt =
|
||||
createNewChatItem_ db user chatDirection showGroupAsSender createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False hasLink createdAt Nothing (MSSVerified <$ signedMsg_) createdAt
|
||||
createNewChatItem_ db user chatDirection showGroupAsSender createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False hasLink createdAt Nothing (toMsgVerified False (MSSVerified <$ signedMsg_)) createdAt
|
||||
where
|
||||
createdByMsgId = if msgId == 0 then Nothing else Just msgId
|
||||
quoteRow :: NewQuoteRow
|
||||
@@ -562,7 +562,7 @@ createNewSndChatItem db user chatDirection showGroupAsSender SndMessage {msgId,
|
||||
createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c), Maybe CIForwardedFrom)
|
||||
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, msgSigned, forwardedByMember} sharedMsgId_ ciContent timed live userMention hasLink itemTs createdAt = do
|
||||
let showAsGroup = case chatDirection of CDChannelRcv {} -> True; _ -> False
|
||||
ciId <- createNewChatItem_ db user chatDirection showAsGroup (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember msgSigned createdAt
|
||||
ciId <- createNewChatItem_ db user chatDirection showAsGroup (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember (toMsgVerified (signMessagesRequired chatDirection) msgSigned) createdAt
|
||||
quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg
|
||||
pure (ciId, quotedItem, itemForwarded)
|
||||
where
|
||||
@@ -581,15 +581,15 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, msgS
|
||||
CDChannelRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ ->
|
||||
(Just $ Just userMemberId == memberId, memberId)
|
||||
|
||||
createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> Bool -> Maybe MsgSigStatus -> UTCTime -> UTCTime -> IO ChatItemId
|
||||
createNewChatItemNoMsg db user chatDirection showGroupAsSender ciContent sharedMsgId_ hasLink msgSigned itemTs =
|
||||
createNewChatItem_ db user chatDirection showGroupAsSender Nothing sharedMsgId_ ciContent quoteRow Nothing Nothing False False hasLink itemTs Nothing msgSigned
|
||||
createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> Bool -> MsgVerified -> UTCTime -> UTCTime -> IO ChatItemId
|
||||
createNewChatItemNoMsg db user chatDirection showGroupAsSender ciContent sharedMsgId_ hasLink msgVerified itemTs =
|
||||
createNewChatItem_ db user chatDirection showGroupAsSender Nothing sharedMsgId_ ciContent quoteRow Nothing Nothing False False hasLink itemTs Nothing msgVerified
|
||||
where
|
||||
quoteRow :: NewQuoteRow
|
||||
quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing)
|
||||
|
||||
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> Maybe GroupMemberId -> Maybe MsgSigStatus -> UTCTime -> IO ChatItemId
|
||||
createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember msgSigned createdAt = do
|
||||
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> Maybe GroupMemberId -> MsgVerified -> UTCTime -> IO ChatItemId
|
||||
createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember msgVerified createdAt = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
@@ -610,8 +610,8 @@ createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ share
|
||||
forM_ msgId_ $ \msgId -> insertChatItemMessage_ db ciId msgId createdAt
|
||||
pure ciId
|
||||
where
|
||||
itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, Text, CIStatus d, Maybe MsgContentTag, Maybe SharedMsgId, Maybe GroupMemberId, BoolInt) :. (UTCTime, UTCTime, Maybe BoolInt, BoolInt, BoolInt, BoolInt, BoolInt, Maybe MsgSigStatus) :. (Maybe Int, Maybe UTCTime)
|
||||
itemRow = (msgDirection @d, itemTs, ciContent, toCIContentTag ciContent, ciContentToText ciContent, ciCreateStatus ciContent, mcTag_, sharedMsgId, forwardedByMember, BI includeInHistory) :. (createdAt, createdAt, BI <$> justTrue live, BI userMention, BI hasLink, BI itemViewed, BI showGroupAsSender, msgSigned) :. ciTimedRow timed
|
||||
itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, Text, CIStatus d, Maybe MsgContentTag, Maybe SharedMsgId, Maybe GroupMemberId, BoolInt) :. (UTCTime, UTCTime, Maybe BoolInt, BoolInt, BoolInt, BoolInt, BoolInt, MsgVerified) :. (Maybe Int, Maybe UTCTime)
|
||||
itemRow = (msgDirection @d, itemTs, ciContent, toCIContentTag ciContent, ciContentToText ciContent, ciCreateStatus ciContent, mcTag_, sharedMsgId, forwardedByMember, BI includeInHistory) :. (createdAt, createdAt, BI <$> justTrue live, BI userMention, BI hasLink, BI itemViewed, BI showGroupAsSender, msgVerified) :. ciTimedRow timed
|
||||
quoteRow' = let (a, b, c, d, e) = quoteRow in (a, b, c, BI <$> d, e)
|
||||
idsRow :: (Maybe ContactId, Maybe GroupId, Maybe GroupMemberId, Maybe NoteFolderId)
|
||||
idsRow = case chatDirection of
|
||||
@@ -1116,7 +1116,7 @@ toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentTex
|
||||
_ -> Just (CIDeleted @'CTLocal deletedTs)
|
||||
itemEdited' = maybe False unBI itemEdited
|
||||
itemForwarded = toCIForwardedFrom forwardedFromRow
|
||||
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned createdAt updatedAt
|
||||
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False (fromMaybe MVUnsigned msgSigned) createdAt updatedAt
|
||||
ciTimed :: Maybe CITimed
|
||||
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
|
||||
|
||||
@@ -2266,7 +2266,7 @@ updateLocalChatItemsRead db User {userId} noteFolderId = do
|
||||
|
||||
type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe ACIFileStatus, Maybe FileProtocol)
|
||||
|
||||
type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe BoolInt, BoolInt, BoolInt, Maybe MsgSigStatus)
|
||||
type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe BoolInt, BoolInt, BoolInt, Maybe MsgVerified)
|
||||
|
||||
type ChatItemForwardedFromRow = (Maybe CIForwardedFromTag, Maybe Text, Maybe MsgDirection, Maybe Int64, Maybe Int64, Maybe Int64)
|
||||
|
||||
@@ -2323,7 +2323,7 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
|
||||
_ -> Just (CIDeleted @'CTDirect deletedTs)
|
||||
itemEdited' = maybe False unBI itemEdited
|
||||
itemForwarded = toCIForwardedFrom forwardedFromRow
|
||||
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned createdAt updatedAt
|
||||
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False (fromMaybe MVUnsigned msgSigned) createdAt updatedAt
|
||||
ciTimed :: Maybe CITimed
|
||||
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
|
||||
|
||||
@@ -2412,7 +2412,7 @@ toGroupChatItem
|
||||
_ -> Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_)
|
||||
itemEdited' = maybe False unBI itemEdited
|
||||
itemForwarded = toCIForwardedFrom forwardedFromRow
|
||||
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs forwardedByMember showGroupAsSender msgSigned createdAt updatedAt
|
||||
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs forwardedByMember showGroupAsSender (fromMaybe MVUnsigned msgSigned) createdAt updatedAt
|
||||
ciTimed :: Maybe CITimed
|
||||
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
|
||||
|
||||
|
||||
@@ -40,6 +40,7 @@ import Simplex.Chat.Store.Postgres.Migrations.M20260601_relay_sent_web_domain
|
||||
import Simplex.Chat.Store.Postgres.Migrations.M20260602_group_roster
|
||||
import Simplex.Chat.Store.Postgres.Migrations.M20260603_simplex_name
|
||||
import Simplex.Chat.Store.Postgres.Migrations.M20260629_roster_catchup
|
||||
import Simplex.Chat.Store.Postgres.Migrations.M20260707_file_digest
|
||||
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Text, Maybe Text)]
|
||||
@@ -79,7 +80,8 @@ schemaMigrations =
|
||||
("20260601_relay_sent_web_domain", m20260601_relay_sent_web_domain, Just down_m20260601_relay_sent_web_domain),
|
||||
("20260602_group_roster", m20260602_group_roster, Just down_m20260602_group_roster),
|
||||
("20260603_simplex_name", m20260603_simplex_name, Just down_m20260603_simplex_name),
|
||||
("20260629_roster_catchup", m20260629_roster_catchup, Just down_m20260629_roster_catchup)
|
||||
("20260629_roster_catchup", m20260629_roster_catchup, Just down_m20260629_roster_catchup),
|
||||
("20260707_file_digest", m20260707_file_digest, Just down_m20260707_file_digest)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
@@ -0,0 +1,19 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Store.Postgres.Migrations.M20260707_file_digest where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
m20260707_file_digest :: Text
|
||||
m20260707_file_digest =
|
||||
[r|
|
||||
ALTER TABLE files ADD COLUMN file_digest BYTEA;
|
||||
|]
|
||||
|
||||
down_m20260707_file_digest :: Text
|
||||
down_m20260707_file_digest =
|
||||
[r|
|
||||
ALTER TABLE files DROP COLUMN file_digest;
|
||||
|]
|
||||
@@ -758,7 +758,8 @@ CREATE TABLE test_chat_schema.files (
|
||||
redirect_file_id bigint,
|
||||
shared_msg_id bytea,
|
||||
file_type text DEFAULT 'normal'::text NOT NULL,
|
||||
roster_transfer_id bigint
|
||||
roster_transfer_id bigint,
|
||||
file_digest bytea
|
||||
);
|
||||
|
||||
|
||||
@@ -985,7 +986,7 @@ CREATE TABLE test_chat_schema.groups (
|
||||
public_member_count bigint,
|
||||
relay_request_retries bigint DEFAULT 0 NOT NULL,
|
||||
relay_request_delay bigint DEFAULT 0 NOT NULL,
|
||||
relay_request_execute_at timestamp with time zone DEFAULT '1970-01-01 01:00:00+01'::timestamp with time zone NOT NULL,
|
||||
relay_request_execute_at timestamp with time zone DEFAULT '1970-01-01 04:00:00+04'::timestamp with time zone NOT NULL,
|
||||
relay_inactive_at timestamp with time zone,
|
||||
relay_sent_web_domain text,
|
||||
roster_version bigint,
|
||||
|
||||
@@ -163,6 +163,7 @@ import Simplex.Chat.Store.SQLite.Migrations.M20260601_relay_sent_web_domain
|
||||
import Simplex.Chat.Store.SQLite.Migrations.M20260602_group_roster
|
||||
import Simplex.Chat.Store.SQLite.Migrations.M20260603_simplex_name
|
||||
import Simplex.Chat.Store.SQLite.Migrations.M20260629_roster_catchup
|
||||
import Simplex.Chat.Store.SQLite.Migrations.M20260707_file_digest
|
||||
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||
@@ -325,7 +326,8 @@ schemaMigrations =
|
||||
("20260601_relay_sent_web_domain", m20260601_relay_sent_web_domain, Just down_m20260601_relay_sent_web_domain),
|
||||
("20260602_group_roster", m20260602_group_roster, Just down_m20260602_group_roster),
|
||||
("20260603_simplex_name", m20260603_simplex_name, Just down_m20260603_simplex_name),
|
||||
("20260629_roster_catchup", m20260629_roster_catchup, Just down_m20260629_roster_catchup)
|
||||
("20260629_roster_catchup", m20260629_roster_catchup, Just down_m20260629_roster_catchup),
|
||||
("20260707_file_digest", m20260707_file_digest, Just down_m20260707_file_digest)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
@@ -0,0 +1,18 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Store.SQLite.Migrations.M20260707_file_digest where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20260707_file_digest :: Query
|
||||
m20260707_file_digest =
|
||||
[sql|
|
||||
ALTER TABLE files ADD COLUMN file_digest BLOB;
|
||||
|]
|
||||
|
||||
down_m20260707_file_digest :: Query
|
||||
down_m20260707_file_digest =
|
||||
[sql|
|
||||
ALTER TABLE files DROP COLUMN file_digest;
|
||||
|]
|
||||
@@ -1705,7 +1705,7 @@ Query:
|
||||
SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name,
|
||||
f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name,
|
||||
f.file_path, f.file_crypto_key, f.file_crypto_nonce, r.file_inline, r.rcv_file_inline,
|
||||
r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name, f.file_type
|
||||
r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name, f.file_type, f.file_digest
|
||||
FROM rcv_files r
|
||||
JOIN files f USING (file_id)
|
||||
LEFT JOIN contacts cs ON cs.contact_id = f.contact_id
|
||||
@@ -3796,7 +3796,16 @@ Query:
|
||||
SELECT g.group_id, g.conn_full_link_to_connect, g.conn_short_link_to_connect FROM groups g
|
||||
JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id
|
||||
WHERE g.user_id = ? AND gp.group_domain = ? AND g.group_domain_verified = 1
|
||||
|
||||
AND g.business_chat IS NOT NULL
|
||||
Plan:
|
||||
SEARCH g USING INDEX sqlite_autoindex_groups_2 (user_id=?)
|
||||
SEARCH gp USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query:
|
||||
SELECT g.group_id, g.conn_full_link_to_connect, g.conn_short_link_to_connect FROM groups g
|
||||
JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id
|
||||
WHERE g.user_id = ? AND gp.group_domain = ? AND g.group_domain_verified = 1
|
||||
AND g.business_chat IS NULL
|
||||
Plan:
|
||||
SEARCH g USING INDEX sqlite_autoindex_groups_2 (user_id=?)
|
||||
SEARCH gp USING INTEGER PRIMARY KEY (rowid=?)
|
||||
@@ -6966,7 +6975,7 @@ Plan:
|
||||
Query: INSERT INTO files (user_id, file_name, file_path, file_size, chunk_size, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)
|
||||
Plan:
|
||||
|
||||
Query: INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_type, shared_msg_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
Query: INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_type, shared_msg_id, created_at, updated_at, file_digest) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
Plan:
|
||||
|
||||
Query: INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_type, shared_msg_id, roster_transfer_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
@@ -7119,6 +7128,10 @@ Plan:
|
||||
SCAN m USING COVERING INDEX idx_group_members_user_id_local_display_name
|
||||
SEARCH c USING INDEX idx_connections_group_member_id (group_member_id=?)
|
||||
|
||||
Query: SELECT chat_item_id FROM chat_items WHERE item_text LIKE '%' || ? || '%' ORDER BY chat_item_id DESC LIMIT 1
|
||||
Plan:
|
||||
SCAN chat_items
|
||||
|
||||
Query: SELECT chat_item_id FROM chat_items WHERE user_id = ? AND contact_id = ? AND shared_msg_id = ? AND item_sent = ?
|
||||
Plan:
|
||||
SEARCH chat_items USING INDEX idx_chat_items_direct_shared_msg_id (user_id=? AND contact_id=? AND shared_msg_id=?)
|
||||
@@ -7227,6 +7240,10 @@ Query: SELECT count(1) FROM chat_items WHERE chat_item_id > ?
|
||||
Plan:
|
||||
SEARCH chat_items USING INTEGER PRIMARY KEY (rowid>?)
|
||||
|
||||
Query: SELECT count(1) FROM files WHERE file_digest IS NOT NULL
|
||||
Plan:
|
||||
SCAN files
|
||||
|
||||
Query: SELECT count(1) FROM group_members
|
||||
Plan:
|
||||
SCAN group_members USING COVERING INDEX idx_group_members_invited_by_group_member_id
|
||||
@@ -7431,6 +7448,10 @@ Query: SELECT sent_inv_queue_info FROM group_members WHERE group_member_id = ? A
|
||||
Plan:
|
||||
SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query: SELECT shared_msg_id FROM chat_items WHERE shared_msg_id IS NOT NULL ORDER BY chat_item_id DESC LIMIT 1
|
||||
Plan:
|
||||
SCAN chat_items
|
||||
|
||||
Query: SELECT should_sync FROM connections_sync WHERE connections_sync_id = 1
|
||||
Plan:
|
||||
SEARCH connections_sync USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
@@ -296,7 +296,8 @@ CREATE TABLE files(
|
||||
redirect_file_id INTEGER REFERENCES files ON DELETE CASCADE,
|
||||
shared_msg_id BLOB,
|
||||
file_type TEXT NOT NULL DEFAULT 'normal',
|
||||
roster_transfer_id INTEGER
|
||||
roster_transfer_id INTEGER,
|
||||
file_digest BLOB
|
||||
) STRICT;
|
||||
CREATE TABLE snd_files(
|
||||
file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE,
|
||||
|
||||
@@ -179,6 +179,7 @@ data GroupFeature
|
||||
| GFSupport
|
||||
| GFSessions
|
||||
| GFComments
|
||||
| GFSignMessages
|
||||
deriving (Show)
|
||||
|
||||
data SGroupFeature (f :: GroupFeature) where
|
||||
@@ -194,6 +195,7 @@ data SGroupFeature (f :: GroupFeature) where
|
||||
SGFSupport :: SGroupFeature 'GFSupport
|
||||
SGFSessions :: SGroupFeature 'GFSessions
|
||||
SGFComments :: SGroupFeature 'GFComments
|
||||
SGFSignMessages :: SGroupFeature 'GFSignMessages
|
||||
|
||||
deriving instance Show (SGroupFeature f)
|
||||
|
||||
@@ -223,6 +225,7 @@ groupFeatureNameText = \case
|
||||
GFSupport -> "Chat with admins"
|
||||
GFSessions -> "Chat sessions"
|
||||
GFComments -> "Comments"
|
||||
GFSignMessages -> "Sign messages"
|
||||
|
||||
groupFeatureNameText' :: SGroupFeature f -> Text
|
||||
groupFeatureNameText' = groupFeatureNameText . toGroupFeature
|
||||
@@ -249,7 +252,8 @@ allGroupFeatures =
|
||||
AGF SGFSimplexLinks,
|
||||
AGF SGFReports,
|
||||
AGF SGFHistory,
|
||||
AGF SGFSupport
|
||||
AGF SGFSupport,
|
||||
AGF SGFSignMessages
|
||||
]
|
||||
|
||||
-- Channels (public groups) show a subset of group features. Direct messages, voice,
|
||||
@@ -271,9 +275,31 @@ groupFeatureInChannel = \case
|
||||
GFSupport -> True
|
||||
GFSessions -> False
|
||||
GFComments -> False
|
||||
GFSignMessages -> True
|
||||
|
||||
-- Regular groups show a subset of group features. Signing is channel-only for now
|
||||
-- (keys are not shared between members in regular groups), so it is excluded.
|
||||
regularGroupFeatures :: [AGroupFeature]
|
||||
regularGroupFeatures = filter (\(AGF f) -> groupFeatureInRegularGroup (toGroupFeature f)) allGroupFeatures
|
||||
|
||||
groupFeatureInRegularGroup :: GroupFeature -> Bool
|
||||
groupFeatureInRegularGroup = \case
|
||||
GFTimedMessages -> True
|
||||
GFDirectMessages -> True
|
||||
GFFullDelete -> True
|
||||
GFReactions -> True
|
||||
GFVoice -> True
|
||||
GFFiles -> True
|
||||
GFSimplexLinks -> True
|
||||
GFReports -> True
|
||||
GFHistory -> True
|
||||
GFSupport -> True
|
||||
GFSessions -> False
|
||||
GFComments -> False
|
||||
GFSignMessages -> False
|
||||
|
||||
groupPrefSel :: SGroupFeature f -> GroupPreferences -> Maybe (GroupFeaturePreference f)
|
||||
groupPrefSel f GroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, simplexLinks, reports, history, support, sessions, comments} = case f of
|
||||
groupPrefSel f GroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, simplexLinks, reports, history, support, sessions, comments, signMessages} = case f of
|
||||
SGFTimedMessages -> timedMessages
|
||||
SGFDirectMessages -> directMessages
|
||||
SGFFullDelete -> fullDelete
|
||||
@@ -286,6 +312,7 @@ groupPrefSel f GroupPreferences {timedMessages, directMessages, fullDelete, reac
|
||||
SGFSupport -> support
|
||||
SGFSessions -> sessions
|
||||
SGFComments -> comments
|
||||
SGFSignMessages -> signMessages
|
||||
|
||||
toGroupFeature :: SGroupFeature f -> GroupFeature
|
||||
toGroupFeature = \case
|
||||
@@ -301,6 +328,7 @@ toGroupFeature = \case
|
||||
SGFSupport -> GFSupport
|
||||
SGFSessions -> GFSessions
|
||||
SGFComments -> GFComments
|
||||
SGFSignMessages -> GFSignMessages
|
||||
|
||||
class GroupPreferenceI p where
|
||||
getGroupPreference :: SGroupFeature f -> p -> GroupFeaturePreference f
|
||||
@@ -312,7 +340,7 @@ instance GroupPreferenceI (Maybe GroupPreferences) where
|
||||
getGroupPreference pt prefs = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPrefSel pt =<< prefs)
|
||||
|
||||
instance GroupPreferenceI FullGroupPreferences where
|
||||
getGroupPreference f FullGroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, simplexLinks, reports, history, support, sessions, comments} = case f of
|
||||
getGroupPreference f FullGroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, simplexLinks, reports, history, support, sessions, comments, signMessages} = case f of
|
||||
SGFTimedMessages -> timedMessages
|
||||
SGFDirectMessages -> directMessages
|
||||
SGFFullDelete -> fullDelete
|
||||
@@ -325,6 +353,7 @@ instance GroupPreferenceI FullGroupPreferences where
|
||||
SGFSupport -> support
|
||||
SGFSessions -> sessions
|
||||
SGFComments -> comments
|
||||
SGFSignMessages -> signMessages
|
||||
{-# INLINE getGroupPreference #-}
|
||||
|
||||
-- collection of optional group preferences
|
||||
@@ -341,6 +370,7 @@ data GroupPreferences = GroupPreferences
|
||||
support :: Maybe SupportGroupPreference,
|
||||
sessions :: Maybe SessionsGroupPreference,
|
||||
comments :: Maybe CommentsGroupPreference,
|
||||
signMessages :: Maybe SignMessagesGroupPreference,
|
||||
commands :: Maybe [ChatBotCommand]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
@@ -393,6 +423,7 @@ setGroupPreference_ f pref prefs =
|
||||
SGFSupport -> prefs {support = pref}
|
||||
SGFSessions -> prefs {sessions = pref}
|
||||
SGFComments -> prefs {comments = pref}
|
||||
SGFSignMessages -> prefs {signMessages = pref}
|
||||
|
||||
setGroupTimedMessagesPreference :: TimedMessagesGroupPreference -> Maybe GroupPreferences -> GroupPreferences
|
||||
setGroupTimedMessagesPreference pref prefs_ =
|
||||
@@ -437,6 +468,7 @@ data FullGroupPreferences = FullGroupPreferences
|
||||
support :: SupportGroupPreference,
|
||||
sessions :: SessionsGroupPreference,
|
||||
comments :: CommentsGroupPreference,
|
||||
signMessages :: SignMessagesGroupPreference,
|
||||
commands :: ListDef ChatBotCommand
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
@@ -508,11 +540,12 @@ defaultGroupPrefs =
|
||||
support = SupportGroupPreference {enable = FEOn},
|
||||
sessions = SessionsGroupPreference {enable = FEOff, role = Nothing},
|
||||
comments = CommentsGroupPreference {enable = FEOff, duration = Nothing},
|
||||
signMessages = SignMessagesGroupPreference {enable = FEOff},
|
||||
commands = ListDef []
|
||||
}
|
||||
|
||||
emptyGroupPrefs :: GroupPreferences
|
||||
emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
businessGroupPrefs :: Preferences -> GroupPreferences
|
||||
businessGroupPrefs Preferences {timedMessages, fullDelete, reactions, voice, files, sessions, commands} =
|
||||
@@ -546,6 +579,7 @@ defaultBusinessGroupPrefs =
|
||||
support = Just $ SupportGroupPreference FEOn,
|
||||
sessions = Just $ SessionsGroupPreference FEOn Nothing,
|
||||
comments = Just $ CommentsGroupPreference FEOff Nothing,
|
||||
signMessages = Just $ SignMessagesGroupPreference FEOff,
|
||||
commands = Nothing
|
||||
}
|
||||
|
||||
@@ -672,6 +706,10 @@ data ReportsGroupPreference = ReportsGroupPreference
|
||||
{enable :: GroupFeatureEnabled}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data SignMessagesGroupPreference = SignMessagesGroupPreference
|
||||
{enable :: GroupFeatureEnabled}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data HistoryGroupPreference = HistoryGroupPreference
|
||||
{enable :: GroupFeatureEnabled}
|
||||
deriving (Eq, Show)
|
||||
@@ -729,6 +767,9 @@ instance HasField "enable" SimplexLinksGroupPreference GroupFeatureEnabled where
|
||||
instance HasField "enable" ReportsGroupPreference GroupFeatureEnabled where
|
||||
hasField p@ReportsGroupPreference {enable} = (\e -> p {enable = e}, enable)
|
||||
|
||||
instance HasField "enable" SignMessagesGroupPreference GroupFeatureEnabled where
|
||||
hasField p@SignMessagesGroupPreference {enable} = (\e -> p {enable = e}, enable)
|
||||
|
||||
instance HasField "enable" HistoryGroupPreference GroupFeatureEnabled where
|
||||
hasField p@HistoryGroupPreference {enable} = (\e -> p {enable = e}, enable)
|
||||
|
||||
@@ -789,6 +830,12 @@ instance GroupFeatureI 'GFReports where
|
||||
groupPrefParam _ = Nothing
|
||||
groupPrefRole _ = Nothing
|
||||
|
||||
instance GroupFeatureI 'GFSignMessages where
|
||||
type GroupFeaturePreference 'GFSignMessages = SignMessagesGroupPreference
|
||||
sGroupFeature = SGFSignMessages
|
||||
groupPrefParam _ = Nothing
|
||||
groupPrefRole _ = Nothing
|
||||
|
||||
instance GroupFeatureI 'GFHistory where
|
||||
type GroupFeaturePreference 'GFHistory = HistoryGroupPreference
|
||||
sGroupFeature = SGFHistory
|
||||
@@ -821,6 +868,8 @@ instance GroupFeatureNoRoleI 'GFReactions
|
||||
|
||||
instance GroupFeatureNoRoleI 'GFReports
|
||||
|
||||
instance GroupFeatureNoRoleI 'GFSignMessages
|
||||
|
||||
instance GroupFeatureNoRoleI 'GFHistory
|
||||
|
||||
instance GroupFeatureNoRoleI 'GFSupport
|
||||
@@ -1020,6 +1069,7 @@ mergeGroupPreferences groupPreferences =
|
||||
support = pref SGFSupport,
|
||||
sessions = pref SGFSessions,
|
||||
comments = pref SGFComments,
|
||||
signMessages = pref SGFSignMessages,
|
||||
commands = ListDef $ fromMaybe [] $ groupPreferences >>= commands_
|
||||
}
|
||||
where
|
||||
@@ -1041,6 +1091,7 @@ toGroupPreferences groupPreferences@FullGroupPreferences {commands = ListDef cmd
|
||||
support = pref SGFSupport,
|
||||
sessions = pref SGFSessions,
|
||||
comments = pref SGFComments,
|
||||
signMessages = pref SGFSignMessages,
|
||||
commands = Just cmds
|
||||
}
|
||||
where
|
||||
@@ -1167,6 +1218,12 @@ $(J.deriveJSON defaultJSON ''SimplexLinksGroupPreference)
|
||||
|
||||
$(J.deriveJSON defaultJSON ''ReportsGroupPreference)
|
||||
|
||||
$(J.deriveToJSON defaultJSON ''SignMessagesGroupPreference)
|
||||
|
||||
instance FromJSON SignMessagesGroupPreference where
|
||||
parseJSON v = $(J.mkParseJSON defaultJSON ''SignMessagesGroupPreference) v
|
||||
omittedField = Just SignMessagesGroupPreference {enable = FEOff}
|
||||
|
||||
$(J.deriveJSON defaultJSON ''HistoryGroupPreference)
|
||||
|
||||
$(J.deriveToJSON defaultJSON ''SupportGroupPreference)
|
||||
|
||||
@@ -13,7 +13,7 @@ import Simplex.Chat.Options.DB (FromField (..), ToField (..))
|
||||
import Simplex.Messaging.Agent.Store.DB (fromTextField_)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (dropPrefix, enumJSON)
|
||||
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, sumTypeJSON)
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
|
||||
data GroupMemberRole
|
||||
@@ -148,3 +148,31 @@ instance ToField MsgSigStatus where toField = toField . textEncode
|
||||
instance FromField MsgSigStatus where fromField = fromTextField_ textDecode
|
||||
|
||||
$(JQ.deriveJSON (enumJSON $ dropPrefix "MSS") ''MsgSigStatus)
|
||||
|
||||
data MsgVerified = MVSigned {sigStatus :: MsgSigStatus} | MVSigMissing | MVUnsigned
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance TextEncoding MsgVerified where
|
||||
textEncode = \case
|
||||
MVSigned s -> textEncode s
|
||||
MVSigMissing -> "sig_missing"
|
||||
MVUnsigned -> "unsigned"
|
||||
textDecode = \case
|
||||
"sig_missing" -> Just MVSigMissing
|
||||
"unsigned" -> Just MVUnsigned
|
||||
s -> MVSigned <$> textDecode s
|
||||
|
||||
instance ToField MsgVerified where toField = toField . textEncode
|
||||
|
||||
instance FromField MsgVerified where fromField = fromTextField_ textDecode
|
||||
|
||||
$(JQ.deriveToJSON (sumTypeJSON $ dropPrefix "MV") ''MsgVerified)
|
||||
|
||||
instance FromJSON MsgVerified where
|
||||
parseJSON = $(JQ.mkParseJSON (sumTypeJSON $ dropPrefix "MV") ''MsgVerified)
|
||||
omittedField = Just MVUnsigned
|
||||
|
||||
toMsgVerified :: Bool -> Maybe MsgSigStatus -> MsgVerified
|
||||
toMsgVerified signRequired = \case
|
||||
Just s -> MVSigned s
|
||||
Nothing -> if signRequired then MVSigMissing else MVUnsigned
|
||||
|
||||
@@ -375,9 +375,9 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte
|
||||
Just CIFile {fileSource = Just (CryptoFile fp _)} -> Just fp
|
||||
_ -> Nothing
|
||||
testViewItem :: CChatItem c -> Maybe GroupMember -> Text
|
||||
testViewItem (CChatItem _ ci@ChatItem {meta = CIMeta {itemText, msgSigned}}) membership_ =
|
||||
testViewItem (CChatItem _ ci@ChatItem {meta = CIMeta {itemText, msgVerified}}) membership_ =
|
||||
let deleted_ = maybe "" (\t -> " [" <> t <> "]") (chatItemDeletedText ci membership_)
|
||||
in itemText <> sigStatusStr msgSigned <> deleted_
|
||||
in itemText <> msgVerifiedStr msgVerified <> deleted_
|
||||
unmuted :: User -> ChatInfo c -> ChatItem c d -> [StyledString] -> [StyledString]
|
||||
unmuted u chat ci@ChatItem {chatDir} = unmuted' u chat chatDir $ isUserMention ci
|
||||
unmutedReaction :: User -> ChatInfo c -> CIReaction c d -> [StyledString] -> [StyledString]
|
||||
@@ -395,6 +395,12 @@ sigStatusStr = \case
|
||||
Just MSSSignedNoKey -> " (signed, no key to verify)"
|
||||
Nothing -> ""
|
||||
|
||||
msgVerifiedStr :: IsString a => MsgVerified -> a
|
||||
msgVerifiedStr = \case
|
||||
MVSigned s -> sigStatusStr (Just s)
|
||||
MVSigMissing -> " (signature missing)"
|
||||
MVUnsigned -> ""
|
||||
|
||||
signedStr :: IsString a => Bool -> a
|
||||
signedStr signed = if signed then " (signed)" else ""
|
||||
|
||||
@@ -677,7 +683,7 @@ viewChatItems ttyUser unmuted u chatItems ts tz testView
|
||||
| otherwise = ttyUser u [sShow (length chatItems) <> " new messages created"]
|
||||
|
||||
viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString]
|
||||
viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwardedByMember, userMention, msgSigned}, content, quotedItem, file} doShow ts tz =
|
||||
viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwardedByMember, userMention, msgVerified}, content, quotedItem, file} doShow ts tz =
|
||||
withGroupMsgForwarded . withItemDeleted <$> viewCI
|
||||
where
|
||||
viewCI = case chat of
|
||||
@@ -763,8 +769,8 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwa
|
||||
("", Just _, []) -> []
|
||||
("", Just CIFile {fileName}, _) -> view dir context (MCText $ T.pack fileName) ts tz meta
|
||||
_ -> view dir context mc ts tz meta
|
||||
showSndItem to = showItem $ sentWithTime_ ts tz [to <> plainContent content <> sigStatusStr msgSigned] meta
|
||||
showRcvItem from = showItem $ receivedWithTime_ ts tz from [] meta [plainContent content <> sigStatusStr msgSigned] False
|
||||
showSndItem to = showItem $ sentWithTime_ ts tz [to <> plainContent content <> msgVerifiedStr msgVerified] meta
|
||||
showRcvItem from = showItem $ receivedWithTime_ ts tz from [] meta [plainContent content <> msgVerifiedStr msgVerified] False
|
||||
showSndItemProhibited to = showItem $ sentWithTime_ ts tz [to <> plainContent content <> " " <> prohibited] meta
|
||||
showRcvItemProhibited from = showItem $ receivedWithTime_ ts tz from [] meta [plainContent content <> " " <> prohibited] False
|
||||
showItem ss = if doShow then ss else []
|
||||
@@ -2033,7 +2039,7 @@ viewGroupUpdated
|
||||
| null prefs = []
|
||||
| otherwise = bold' "updated group preferences:" : prefs
|
||||
where
|
||||
prefs = mapMaybe viewPref allGroupFeatures
|
||||
prefs = mapMaybe viewPref (if useRelays' g' then channelGroupFeatures else regularGroupFeatures)
|
||||
viewPref (AGF f)
|
||||
| pref gps == pref gps' = Nothing
|
||||
| otherwise = Just . plain $ groupPreferenceText (pref gps')
|
||||
@@ -2061,7 +2067,7 @@ viewGroupProfile g@GroupInfo {groupProfile = GroupProfile {shortDescr, descripti
|
||||
<> maybe [] (\sd -> ["description: " <> plain sd]) shortDescr
|
||||
<> maybe [] (const ["has profile image"]) image
|
||||
<> maybe [] ((bold' "welcome message:" :) . map plain . T.lines) description
|
||||
<> (bold' "group preferences:" : map viewPref allGroupFeatures)
|
||||
<> (bold' "group preferences:" : map viewPref (if useRelays' g then channelGroupFeatures else regularGroupFeatures))
|
||||
where
|
||||
viewPref (AGF f) = plain $ groupPreferenceText (pref gps)
|
||||
where
|
||||
@@ -2270,7 +2276,7 @@ viewReceivedUpdatedMessage :: StyledString -> [StyledString] -> MsgContent -> Cu
|
||||
viewReceivedUpdatedMessage = viewReceivedMessage_ True
|
||||
|
||||
viewReceivedMessage_ :: Bool -> StyledString -> [StyledString] -> MsgContent -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString]
|
||||
viewReceivedMessage_ updated from context mc ts tz meta = receivedWithTime_ ts tz from context meta (ttyMsgContent mc) updated
|
||||
viewReceivedMessage_ updated from context mc ts tz meta@CIMeta {msgVerified} = receivedWithTime_ ts tz from context meta (appendLast (msgVerifiedStr msgVerified) $ ttyMsgContent mc) updated
|
||||
|
||||
viewReceivedReaction :: StyledString -> [StyledString] -> StyledString -> CurrentTime -> TimeZone -> UTCTime -> [StyledString]
|
||||
viewReceivedReaction from styledMsg reactionText ts tz reactionTs =
|
||||
@@ -2308,7 +2314,7 @@ recent now tz time = do
|
||||
|| (localNow < currentDay12 && localTime >= previousDay18 && localTimeDay < localNowDay)
|
||||
|
||||
viewSentMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString]
|
||||
viewSentMessage to context mc ts tz meta@CIMeta {itemEdited, itemDeleted, itemLive} = sentWithTime_ ts tz (prependFirst to $ context <> prependFirst (indent <> live) (ttyMsgContent mc)) meta
|
||||
viewSentMessage to context mc ts tz meta@CIMeta {itemEdited, itemDeleted, itemLive, msgVerified} = sentWithTime_ ts tz (prependFirst to $ context <> prependFirst (indent <> live) (appendLast (msgVerifiedStr msgVerified) $ ttyMsgContent mc)) meta
|
||||
where
|
||||
indent = if null context then "" else " "
|
||||
live
|
||||
@@ -2365,6 +2371,10 @@ prependFirst :: StyledString -> [StyledString] -> [StyledString]
|
||||
prependFirst s [] = [s]
|
||||
prependFirst s (s' : ss) = (s <> s') : ss
|
||||
|
||||
appendLast :: StyledString -> [StyledString] -> [StyledString]
|
||||
appendLast _ [] = []
|
||||
appendLast s ss = init ss <> [last ss <> s]
|
||||
|
||||
msgPlain :: Text -> [StyledString]
|
||||
msgPlain = map (styleMarkdownList . parseMarkdownList) . T.lines
|
||||
|
||||
|
||||
Reference in New Issue
Block a user