core: full/merged preferences in User, Contact, GroupInfo types (#1365)
* core: preferences in User, Contact, GroupInfo types * user and group preferences * refactor * linebreak * remove synonyms * refactor * refactor Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
JRoberts
GitHub
parent
40e1b01baf
commit
b5a812769b
@ -279,7 +279,7 @@ processChatCommand = \case
|
||||
APIGetChatItems _pagination -> pure $ chatCmdError "not implemented"
|
||||
APISendMessage (ChatRef cType chatId) (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user@User {userId} -> withChatLock "sendMessage" $ case cType of
|
||||
CTDirect -> do
|
||||
ct@Contact {localDisplayName = c, contactUsed} <- withStore $ \db -> getContact db userId chatId
|
||||
ct@Contact {localDisplayName = c, contactUsed} <- withStore $ \db -> getContact db user chatId
|
||||
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
|
||||
(fileInvitation_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer ct
|
||||
(msgContainer, quotedItem_) <- prepareMsg fileInvitation_
|
||||
@ -396,7 +396,7 @@ processChatCommand = \case
|
||||
unzipMaybe3 _ = (Nothing, Nothing, Nothing)
|
||||
APIUpdateChatItem (ChatRef cType chatId) itemId mc -> withUser $ \user@User {userId} -> withChatLock "updateChatItem" $ case cType of
|
||||
CTDirect -> do
|
||||
(ct@Contact {contactId, localDisplayName = c}, ci) <- withStore $ \db -> (,) <$> getContact db userId chatId <*> getDirectChatItem db userId chatId itemId
|
||||
(ct@Contact {contactId, localDisplayName = c}, ci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db userId chatId itemId
|
||||
case ci of
|
||||
CChatItem SMDSnd ChatItem {meta = CIMeta {itemSharedMsgId}, content = ciContent} -> do
|
||||
case (ciContent, itemSharedMsgId) of
|
||||
@ -425,7 +425,7 @@ processChatCommand = \case
|
||||
CTContactConnection -> pure $ chatCmdError "not supported"
|
||||
APIDeleteChatItem (ChatRef cType chatId) itemId mode -> withUser $ \user@User {userId} -> withChatLock "deleteChatItem" $ case cType of
|
||||
CTDirect -> do
|
||||
(ct@Contact {localDisplayName = c}, CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemSharedMsgId}, file}) <- withStore $ \db -> (,) <$> getContact db userId chatId <*> getDirectChatItem db userId chatId itemId
|
||||
(ct@Contact {localDisplayName = c}, CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemSharedMsgId}, file}) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db userId chatId itemId
|
||||
case (mode, msgDir, itemSharedMsgId) of
|
||||
(CIDMInternal, _, _) -> do
|
||||
deleteCIFile user file
|
||||
@ -468,10 +468,10 @@ processChatCommand = \case
|
||||
CTGroup -> withStore' (\db -> updateGroupChatItemsRead db chatId fromToIds) $> CRCmdOk
|
||||
CTContactRequest -> pure $ chatCmdError "not supported"
|
||||
CTContactConnection -> pure $ chatCmdError "not supported"
|
||||
APIChatUnread (ChatRef cType chatId) unreadChat -> withUser $ \user@User {userId} -> case cType of
|
||||
APIChatUnread (ChatRef cType chatId) unreadChat -> withUser $ \user -> case cType of
|
||||
CTDirect -> do
|
||||
withStore $ \db -> do
|
||||
ct <- getContact db userId chatId
|
||||
ct <- getContact db user chatId
|
||||
liftIO $ updateContactUnreadChat db user ct unreadChat
|
||||
pure CRCmdOk
|
||||
CTGroup -> do
|
||||
@ -482,7 +482,7 @@ processChatCommand = \case
|
||||
_ -> pure $ chatCmdError "not supported"
|
||||
APIDeleteChat (ChatRef cType chatId) -> withUser $ \user@User {userId} -> case cType of
|
||||
CTDirect -> do
|
||||
ct@Contact {localDisplayName} <- withStore $ \db -> getContact db userId chatId
|
||||
ct@Contact {localDisplayName} <- withStore $ \db -> getContact db user chatId
|
||||
filesInfo <- withStore' $ \db -> getContactFileInfo db user ct
|
||||
conns <- withStore $ \db -> getContactConnections db userId ct
|
||||
withChatLock "deleteChat direct" . procCmd $ do
|
||||
@ -516,9 +516,9 @@ processChatCommand = \case
|
||||
withStore' $ \db -> deleteGroup db user gInfo
|
||||
pure $ CRGroupDeletedUser gInfo
|
||||
CTContactRequest -> pure $ chatCmdError "not supported"
|
||||
APIClearChat (ChatRef cType chatId) -> withUser $ \user@User {userId} -> case cType of
|
||||
APIClearChat (ChatRef cType chatId) -> withUser $ \user -> case cType of
|
||||
CTDirect -> do
|
||||
ct <- withStore $ \db -> getContact db userId chatId
|
||||
ct <- withStore $ \db -> getContact db user chatId
|
||||
filesInfo <- withStore' $ \db -> getContactFileInfo db user ct
|
||||
maxItemTs_ <- withStore' $ \db -> getContactMaxItemTs db user ct
|
||||
forM_ filesInfo $ \fileInfo -> deleteFile user fileInfo
|
||||
@ -561,7 +561,7 @@ processChatCommand = \case
|
||||
pure $ CRContactRequestRejected cReq
|
||||
APISendCallInvitation contactId callType -> withUser $ \user@User {userId} -> do
|
||||
-- party initiating call
|
||||
ct <- withStore $ \db -> getContact db userId contactId
|
||||
ct <- withStore $ \db -> getContact db user contactId
|
||||
calls <- asks currentCalls
|
||||
withChatLock "sendCallInvitation" $ do
|
||||
callId <- CallId <$> (asks idsDrg >>= liftIO . (`randomBytes` 16))
|
||||
@ -629,27 +629,27 @@ processChatCommand = \case
|
||||
(SndMessage {msgId}, _) <- sendDirectContactMessage ct (XCallEnd callId)
|
||||
updateCallItemStatus userId ct call WCSDisconnected $ Just msgId
|
||||
pure Nothing
|
||||
APIGetCallInvitations -> withUser $ \User {userId} -> do
|
||||
APIGetCallInvitations -> withUser $ \user -> do
|
||||
calls <- asks currentCalls >>= readTVarIO
|
||||
let invs = mapMaybe callInvitation $ M.elems calls
|
||||
CRCallInvitations <$> mapM (rcvCallInvitation userId) invs
|
||||
CRCallInvitations <$> mapM (rcvCallInvitation user) invs
|
||||
where
|
||||
callInvitation Call {contactId, callState, callTs} = case callState of
|
||||
CallInvitationReceived {peerCallType, sharedKey} -> Just (contactId, callTs, peerCallType, sharedKey)
|
||||
_ -> Nothing
|
||||
rcvCallInvitation userId (contactId, callTs, peerCallType, sharedKey) = do
|
||||
contact <- withStore (\db -> getContact db userId contactId)
|
||||
rcvCallInvitation user (contactId, callTs, peerCallType, sharedKey) = do
|
||||
contact <- withStore (\db -> getContact db user contactId)
|
||||
pure RcvCallInvitation {contact, callType = peerCallType, sharedKey, callTs}
|
||||
APICallStatus contactId receivedStatus ->
|
||||
withCurrentCall contactId $ \userId ct call ->
|
||||
updateCallItemStatus userId ct call receivedStatus Nothing $> Just call
|
||||
APIUpdateProfile profile -> withUser (`updateProfile` profile)
|
||||
APISetContactPrefs contactId prefs' -> withUser $ \user@User {userId} -> do
|
||||
ct <- withStore $ \db -> getContact db userId contactId
|
||||
APISetContactPrefs contactId prefs' -> withUser $ \user -> do
|
||||
ct <- withStore $ \db -> getContact db user contactId
|
||||
updateContactPrefs user ct prefs'
|
||||
APISetContactAlias contactId localAlias -> withUser $ \User {userId} -> do
|
||||
APISetContactAlias contactId localAlias -> withUser $ \user@User {userId} -> do
|
||||
ct' <- withStore $ \db -> do
|
||||
ct <- getContact db userId contactId
|
||||
ct <- getContact db user contactId
|
||||
liftIO $ updateContactAlias db userId ct localAlias
|
||||
pure $ CRContactAliasUpdated ct'
|
||||
APISetConnectionAlias connId localAlias -> withUser $ \User {userId} -> do
|
||||
@ -692,10 +692,10 @@ processChatCommand = \case
|
||||
APIGetChatItemTTL -> CRChatItemTTL <$> withUser (\user -> withStore' (`getChatItemTTL` user))
|
||||
APISetNetworkConfig cfg -> withUser' $ \_ -> withAgent (`setNetworkConfig` cfg) $> CRCmdOk
|
||||
APIGetNetworkConfig -> CRNetworkConfig <$> withUser' (\_ -> withAgent getNetworkConfig)
|
||||
APISetChatSettings (ChatRef cType chatId) chatSettings -> withUser $ \user@User {userId} -> case cType of
|
||||
APISetChatSettings (ChatRef cType chatId) chatSettings -> withUser $ \user -> case cType of
|
||||
CTDirect -> do
|
||||
ct <- withStore $ \db -> do
|
||||
ct <- getContact db userId chatId
|
||||
ct <- getContact db user chatId
|
||||
liftIO $ updateContactSettings db user chatId chatSettings
|
||||
pure ct
|
||||
withAgent $ \a -> toggleConnectionNtfs a (contactConnId ct) (enableNtfs chatSettings)
|
||||
@ -709,9 +709,9 @@ processChatCommand = \case
|
||||
withAgent (\a -> toggleConnectionNtfs a connId $ enableNtfs chatSettings) `catchError` (toView . CRChatError)
|
||||
pure CRCmdOk
|
||||
_ -> pure $ chatCmdError "not supported"
|
||||
APIContactInfo contactId -> withUser $ \User {userId} -> do
|
||||
APIContactInfo contactId -> withUser $ \user@User {userId} -> do
|
||||
-- [incognito] print user's incognito profile for this contact
|
||||
ct@Contact {activeConn = Connection {customUserProfileId}} <- withStore $ \db -> getContact db userId contactId
|
||||
ct@Contact {activeConn = Connection {customUserProfileId}} <- withStore $ \db -> getContact db user contactId
|
||||
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
|
||||
connectionStats <- withAgent (`getConnectionServers` contactConnId ct)
|
||||
pure $ CRContactInfo ct connectionStats (fmap fromLocalProfile incognitoProfile)
|
||||
@ -719,8 +719,8 @@ processChatCommand = \case
|
||||
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
|
||||
connectionStats <- mapM (withAgent . flip getConnectionServers) (memberConnId m)
|
||||
pure $ CRGroupMemberInfo g m connectionStats
|
||||
APISwitchContact contactId -> withUser $ \User {userId} -> do
|
||||
ct <- withStore $ \db -> getContact db userId contactId
|
||||
APISwitchContact contactId -> withUser $ \user -> do
|
||||
ct <- withStore $ \db -> getContact db user contactId
|
||||
withAgent $ \a -> switchConnectionAsync a "" $ contactConnId ct
|
||||
pure CRCmdOk
|
||||
APISwitchGroupMember gId gMemberId -> withUser $ \user -> do
|
||||
@ -837,9 +837,9 @@ processChatCommand = \case
|
||||
gVar <- asks idsDrg
|
||||
groupInfo <- withStore (\db -> createNewGroup db gVar user gProfile)
|
||||
pure $ CRGroupCreated groupInfo
|
||||
APIAddMember groupId contactId memRole -> withUser $ \user@User {userId} -> withChatLock "addMember" $ do
|
||||
APIAddMember groupId contactId memRole -> withUser $ \user -> withChatLock "addMember" $ do
|
||||
-- TODO for large groups: no need to load all members to determine if contact is a member
|
||||
(group, contact) <- withStore $ \db -> (,) <$> getGroup db user groupId <*> getContact db userId contactId
|
||||
(group, contact) <- withStore $ \db -> (,) <$> getGroup db user groupId <*> getContact db user contactId
|
||||
let Group gInfo@GroupInfo {membership} members = group
|
||||
GroupMember {memberRole = userRole} = membership
|
||||
Contact {localDisplayName = cName} = contact
|
||||
@ -891,7 +891,7 @@ processChatCommand = \case
|
||||
Just m -> changeMemberRole user gInfo members m $ SGEMemberRole memberId (fromLocalProfile $ memberProfile m) memRole
|
||||
_ -> throwChatError CEGroupMemberNotFound
|
||||
where
|
||||
changeMemberRole user@User {userId} gInfo@GroupInfo {membership} members m gEvent = do
|
||||
changeMemberRole user gInfo@GroupInfo {membership} members m gEvent = do
|
||||
let GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberContactId, localDisplayName = cName} = m
|
||||
GroupMember {memberRole = userRole} = membership
|
||||
canChangeRole = userRole >= GRAdmin && userRole >= mRole && userRole >= memRole && memberCurrent membership
|
||||
@ -901,7 +901,7 @@ processChatCommand = \case
|
||||
withStore' $ \db -> updateGroupMemberRole db user m memRole
|
||||
case mStatus of
|
||||
GSMemInvited -> do
|
||||
withStore (\db -> (,) <$> mapM (getContact db userId) memberContactId <*> liftIO (getMemberInvitation db user $ groupMemberId' m)) >>= \case
|
||||
withStore (\db -> (,) <$> mapM (getContact db user) memberContactId <*> liftIO (getMemberInvitation db user $ groupMemberId' m)) >>= \case
|
||||
(Just ct, Just cReq) -> sendGrpInvitation user ct gInfo (m :: GroupMember) {memberRole = memRole} cReq
|
||||
_ -> throwChatError $ CEGroupCantResendInvitation gInfo cName
|
||||
_ -> do
|
||||
@ -1051,7 +1051,7 @@ processChatCommand = \case
|
||||
sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId
|
||||
withStore (\db -> getChatRefByFileId db user fileId) >>= \case
|
||||
ChatRef CTDirect contactId -> do
|
||||
contact <- withStore $ \db -> getContact db userId contactId
|
||||
contact <- withStore $ \db -> getContact db user contactId
|
||||
void . sendDirectContactMessage contact $ XFileCancel sharedMsgId
|
||||
ChatRef CTGroup groupId -> do
|
||||
Group gInfo ms <- withStore $ \db -> getGroup db user groupId
|
||||
@ -1114,7 +1114,7 @@ processChatCommand = \case
|
||||
connectViaContact :: User -> ConnectionRequestUri 'CMContact -> m ChatResponse
|
||||
connectViaContact user@User {userId} cReq@(CRContactUri ConnReqUriData {crClientData}) = withChatLock "connectViaContact" $ do
|
||||
let cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq
|
||||
withStore' (\db -> getConnReqContactXContactId db userId cReqHash) >>= \case
|
||||
withStore' (\db -> getConnReqContactXContactId db user cReqHash) >>= \case
|
||||
(Just contact, _) -> pure $ CRContactAlreadyExists contact
|
||||
(_, xContactId_) -> procCmd $ do
|
||||
let randomXContactId = XContactId <$> (asks idsDrg >>= liftIO . (`randomBytes` 16))
|
||||
@ -1165,25 +1165,22 @@ processChatCommand = \case
|
||||
void (sendDirectContactMessage ct $ XInfo mergedProfile) `catchError` (toView . CRChatError)
|
||||
pure $ CRUserProfileUpdated (fromLocalProfile p) p'
|
||||
updateContactPrefs :: User -> Contact -> Preferences -> m ChatResponse
|
||||
updateContactPrefs user@User {userId} ct@Contact {contactId, activeConn = Connection {customUserProfileId}, userPreferences = contactUserPrefs} contactUserPrefs'
|
||||
| contactUserPrefs == contactUserPrefs' = pure $ CRContactPrefsUpdated ct ct $ contactUserPreferences user ct -- nothing changed actually
|
||||
updateContactPrefs user@User {userId} ct@Contact {activeConn = Connection {customUserProfileId}, userPreferences = contactUserPrefs} contactUserPrefs'
|
||||
| contactUserPrefs == contactUserPrefs' = pure $ CRContactPrefsUpdated ct ct
|
||||
| otherwise = do
|
||||
withStore' $ \db -> updateContactUserPreferences db userId contactId contactUserPrefs'
|
||||
-- [incognito] filter out contacts with whom user has incognito connections
|
||||
let ct' = (ct :: Contact) {userPreferences = contactUserPrefs'}
|
||||
ct' <- withStore' $ \db -> updateContactUserPreferences db user ct contactUserPrefs'
|
||||
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId
|
||||
let p' = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct')
|
||||
withChatLock "updateProfile" . procCmd $ do
|
||||
void (sendDirectContactMessage ct' $ XInfo p') `catchError` (toView . CRChatError)
|
||||
pure $ CRContactPrefsUpdated ct ct' $ contactUserPreferences user ct'
|
||||
|
||||
pure $ CRContactPrefsUpdated ct ct'
|
||||
isReady :: Contact -> Bool
|
||||
isReady ct =
|
||||
let s = connStatus $ activeConn (ct :: Contact)
|
||||
in s == ConnReady || s == ConnSndReady
|
||||
withCurrentCall :: ContactId -> (UserId -> Contact -> Call -> m (Maybe Call)) -> m ChatResponse
|
||||
withCurrentCall ctId action = withUser $ \user@User {userId} -> do
|
||||
ct <- withStore $ \db -> getContact db userId ctId
|
||||
ct <- withStore $ \db -> getContact db user ctId
|
||||
calls <- asks currentCalls
|
||||
withChatLock "currentCall" $
|
||||
atomically (TM.lookup ctId calls) >>= \case
|
||||
@ -1313,7 +1310,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, fileInvitation = F
|
||||
chatRef <- withStore $ \db -> getChatRefByFileId db user fileId
|
||||
case (chatRef, grpMemberId) of
|
||||
(ChatRef CTDirect contactId, Nothing) -> do
|
||||
ct <- withStore $ \db -> getContact db userId contactId
|
||||
ct <- withStore $ \db -> getContact db user contactId
|
||||
(msg, ci) <- acceptFile
|
||||
void $ sendDirectContactMessage ct msg
|
||||
pure ci
|
||||
@ -2057,7 +2054,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
|
||||
where
|
||||
profileContactRequest :: InvitationId -> Profile -> Maybe XContactId -> m ()
|
||||
profileContactRequest invId p xContactId_ = do
|
||||
withStore (\db -> createOrUpdateContactRequest db userId userContactLinkId invId p xContactId_) >>= \case
|
||||
withStore (\db -> createOrUpdateContactRequest db user userContactLinkId invId p xContactId_) >>= \case
|
||||
CORContact contact -> toView $ CRContactRequestAlreadyAccepted contact
|
||||
CORRequest cReq@UserContactRequest {localDisplayName} -> do
|
||||
withStore' (\db -> getUserContactLinkById db userId userContactLinkId) >>= \case
|
||||
@ -2151,7 +2148,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
|
||||
if connectedIncognito
|
||||
then withStore' $ \db -> deleteSentProbe db userId probeId
|
||||
else do
|
||||
cs <- withStore' $ \db -> getMatchingContacts db userId ct
|
||||
cs <- withStore' $ \db -> getMatchingContacts db user ct
|
||||
let probeHash = ProbeHash $ C.sha256Hash (unProbe probe)
|
||||
forM_ cs $ \c -> sendProbeHash c probeHash probeId `catchError` const (pure ())
|
||||
where
|
||||
@ -2466,21 +2463,21 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
|
||||
|
||||
xInfo :: Contact -> Profile -> m ()
|
||||
xInfo c@Contact {profile = p} p' = unless (fromLocalProfile p == p') $ do
|
||||
c' <- withStore $ \db -> updateContactProfile db userId c p'
|
||||
toView $ CRContactUpdated c c' $ contactUserPreferences user c'
|
||||
c' <- withStore $ \db -> updateContactProfile db user c p'
|
||||
toView $ CRContactUpdated c c'
|
||||
|
||||
xInfoProbe :: Contact -> Probe -> m ()
|
||||
xInfoProbe c2 probe =
|
||||
-- [incognito] unless connected incognito
|
||||
unless (contactConnIncognito c2) $ do
|
||||
r <- withStore' $ \db -> matchReceivedProbe db userId c2 probe
|
||||
r <- withStore' $ \db -> matchReceivedProbe db user c2 probe
|
||||
forM_ r $ \c1 -> probeMatch c1 c2 probe
|
||||
|
||||
xInfoProbeCheck :: Contact -> ProbeHash -> m ()
|
||||
xInfoProbeCheck c1 probeHash =
|
||||
-- [incognito] unless connected incognito
|
||||
unless (contactConnIncognito c1) $ do
|
||||
r <- withStore' $ \db -> matchReceivedProbeHash db userId c1 probeHash
|
||||
r <- withStore' $ \db -> matchReceivedProbeHash db user c1 probeHash
|
||||
forM_ r . uncurry $ probeMatch c1
|
||||
|
||||
probeMatch :: Contact -> Contact -> Probe -> m ()
|
||||
@ -2493,7 +2490,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
|
||||
|
||||
xInfoProbeOk :: Contact -> Probe -> m ()
|
||||
xInfoProbeOk c1@Contact {contactId = cId1} probe = do
|
||||
r <- withStore' $ \db -> matchSentProbe db userId c1 probe
|
||||
r <- withStore' $ \db -> matchSentProbe db user c1 probe
|
||||
forM_ r $ \c2@Contact {contactId = cId2} ->
|
||||
if cId1 /= cId2
|
||||
then mergeContacts c1 c2
|
||||
@ -2608,7 +2605,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
|
||||
ChatMessage {chatMsgEvent} <- parseChatMessage connInfo
|
||||
case chatMsgEvent of
|
||||
XInfo p -> do
|
||||
ct <- withStore $ \db -> createDirectContact db userId activeConn p
|
||||
ct <- withStore $ \db -> createDirectContact db user activeConn p
|
||||
toView $ CRContactConnecting ct
|
||||
-- TODO show/log error, other events in SMP confirmation
|
||||
_ -> pure ()
|
||||
|
||||
@ -296,7 +296,7 @@ data ChatResponse
|
||||
| CRInvitation {connReqInvitation :: ConnReqInvitation}
|
||||
| CRSentConfirmation
|
||||
| CRSentInvitation {customUserProfile :: Maybe Profile}
|
||||
| CRContactUpdated {fromContact :: Contact, toContact :: Contact, preferences :: ContactUserPreferences}
|
||||
| CRContactUpdated {fromContact :: Contact, toContact :: Contact}
|
||||
| CRContactsMerged {intoContact :: Contact, mergedContact :: Contact}
|
||||
| CRContactDeleted {contact :: Contact}
|
||||
| CRChatCleared {chatInfo :: AChatInfo}
|
||||
@ -322,7 +322,7 @@ data ChatResponse
|
||||
| CRUserProfileUpdated {fromProfile :: Profile, toProfile :: Profile}
|
||||
| CRContactAliasUpdated {toContact :: Contact}
|
||||
| CRConnectionAliasUpdated {toConnection :: PendingContactConnection}
|
||||
| CRContactPrefsUpdated {fromContact :: Contact, toContact :: Contact, preferences :: ContactUserPreferences}
|
||||
| CRContactPrefsUpdated {fromContact :: Contact, toContact :: Contact}
|
||||
| CRContactConnecting {contact :: Contact}
|
||||
| CRContactConnected {contact :: Contact, userCustomProfile :: Maybe Profile}
|
||||
| CRContactAnotherClient {contact :: Contact}
|
||||
|
||||
@ -414,7 +414,7 @@ getUsers db =
|
||||
toUser :: (UserId, ContactId, ProfileId, Bool, ContactName, Text, Maybe ImageData, Maybe Preferences) -> User
|
||||
toUser (userId, userContactId, profileId, activeUser, displayName, fullName, image, userPreferences) =
|
||||
let profile = LocalProfile {profileId, displayName, fullName, image, preferences = userPreferences, localAlias = ""}
|
||||
in User {userId, userContactId, localDisplayName = displayName, profile, activeUser}
|
||||
in User {userId, userContactId, localDisplayName = displayName, profile, activeUser, fullPreferences = mergePreferences Nothing userPreferences}
|
||||
|
||||
setActiveUser :: DB.Connection -> UserId -> IO ()
|
||||
setActiveUser db userId = do
|
||||
@ -438,15 +438,15 @@ createConnReqConnection db userId acId cReqHash xContactId incognitoProfile grou
|
||||
pccConnId <- insertedRowId db
|
||||
pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = True, viaUserContactLink = Nothing, groupLinkId, customUserProfileId, connReqInv = Nothing, localAlias = "", createdAt, updatedAt = createdAt}
|
||||
|
||||
getConnReqContactXContactId :: DB.Connection -> UserId -> ConnReqUriHash -> IO (Maybe Contact, Maybe XContactId)
|
||||
getConnReqContactXContactId db userId cReqHash = do
|
||||
getConnReqContactXContactId :: DB.Connection -> User -> ConnReqUriHash -> IO (Maybe Contact, Maybe XContactId)
|
||||
getConnReqContactXContactId db user@User {userId} cReqHash = do
|
||||
getContact' >>= \case
|
||||
c@(Just _) -> pure (c, Nothing)
|
||||
Nothing -> (Nothing,) <$> getXContactId
|
||||
where
|
||||
getContact' :: IO (Maybe Contact)
|
||||
getContact' =
|
||||
maybeFirstRow toContact $
|
||||
maybeFirstRow (toContact user) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
@ -534,11 +534,14 @@ createConnection_ db userId connType entityId acId viaContact viaUserContactLink
|
||||
where
|
||||
ent ct = if connType == ct then entityId else Nothing
|
||||
|
||||
createDirectContact :: DB.Connection -> UserId -> Connection -> Profile -> ExceptT StoreError IO Contact
|
||||
createDirectContact db userId activeConn@Connection {connId, localAlias} profile = do
|
||||
createDirectContact :: DB.Connection -> User -> Connection -> Profile -> ExceptT StoreError IO Contact
|
||||
createDirectContact db user@User {userId} activeConn@Connection {connId, localAlias} p@Profile {preferences} = do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
(localDisplayName, contactId, profileId) <- createContact_ db userId connId profile localAlias Nothing createdAt
|
||||
pure $ Contact {contactId, localDisplayName, profile = toLocalProfile profileId profile localAlias, activeConn, viaGroup = Nothing, contactUsed = False, chatSettings = defaultChatSettings, userPreferences = emptyChatPrefs, createdAt, updatedAt = createdAt}
|
||||
(localDisplayName, contactId, profileId) <- createContact_ db userId connId p localAlias Nothing createdAt
|
||||
let profile = toLocalProfile profileId p localAlias
|
||||
userPreferences = emptyChatPrefs
|
||||
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
|
||||
pure $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup = Nothing, contactUsed = False, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt, updatedAt = createdAt}
|
||||
|
||||
createContact_ :: DB.Connection -> UserId -> Int64 -> Profile -> LocalAlias -> Maybe Int64 -> UTCTime -> ExceptT StoreError IO (Text, ContactId, ProfileId)
|
||||
createContact_ db userId connId Profile {displayName, fullName, image, preferences} localAlias viaGroup currentTs =
|
||||
@ -632,24 +635,32 @@ updateUserProfile db User {userId, userContactId, localDisplayName, profile = Lo
|
||||
updateContactProfile_' db userId profileId p' currentTs
|
||||
updateContact_ db userId userContactId localDisplayName newName currentTs
|
||||
|
||||
updateContactProfile :: DB.Connection -> UserId -> Contact -> Profile -> ExceptT StoreError IO Contact
|
||||
updateContactProfile db userId c@Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}} p'@Profile {displayName = newName}
|
||||
| displayName == newName =
|
||||
liftIO $ updateContactProfile_ db userId profileId p' $> (c :: Contact) {profile = toLocalProfile profileId p' localAlias}
|
||||
updateContactProfile :: DB.Connection -> User -> Contact -> Profile -> ExceptT StoreError IO Contact
|
||||
updateContactProfile db user@User {userId} c p'
|
||||
| displayName == newName = do
|
||||
liftIO $ updateContactProfile_ db userId profileId p'
|
||||
pure $ c {profile, mergedPreferences}
|
||||
| otherwise =
|
||||
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
|
||||
currentTs <- getCurrentTime
|
||||
updateContactProfile_' db userId profileId p' currentTs
|
||||
updateContact_ db userId contactId localDisplayName ldn currentTs
|
||||
pure . Right $ (c :: Contact) {localDisplayName = ldn, profile = toLocalProfile profileId p' localAlias}
|
||||
pure . Right $ c {localDisplayName = ldn, profile, mergedPreferences}
|
||||
where
|
||||
Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}, activeConn, userPreferences} = c
|
||||
Profile {displayName = newName, preferences} = p'
|
||||
profile = toLocalProfile profileId p' localAlias
|
||||
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
|
||||
|
||||
updateContactUserPreferences :: DB.Connection -> UserId -> Int64 -> Preferences -> IO ()
|
||||
updateContactUserPreferences db userId contactId userPreferences = do
|
||||
updateContactUserPreferences :: DB.Connection -> User -> Contact -> Preferences -> IO Contact
|
||||
updateContactUserPreferences db user@User {userId} c@Contact {contactId, activeConn} userPreferences = do
|
||||
updatedAt <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE contacts SET user_preferences = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?"
|
||||
(userPreferences, updatedAt, userId, contactId)
|
||||
let mergedPreferences = contactUserPreferences user userPreferences (preferences' c) $ connIncognito activeConn
|
||||
pure $ c {mergedPreferences, userPreferences}
|
||||
|
||||
updateContactAlias :: DB.Connection -> UserId -> Contact -> LocalAlias -> IO Contact
|
||||
updateContactAlias db userId c@Contact {profile = lp@LocalProfile {profileId}} localAlias = do
|
||||
@ -722,33 +733,35 @@ updateContact_ db userId contactId displayName newName updatedAt = do
|
||||
|
||||
type ContactRow = (ContactId, ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, LocalAlias, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime)
|
||||
|
||||
toContact :: ContactRow :. ConnectionRow -> Contact
|
||||
toContact (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, localAlias, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt)) :. connRow) =
|
||||
toContact :: User -> ContactRow :. ConnectionRow -> Contact
|
||||
toContact user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, localAlias, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt)) :. connRow) =
|
||||
let profile = LocalProfile {profileId, displayName, fullName, image, preferences, localAlias}
|
||||
activeConn = toConnection connRow
|
||||
chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_}
|
||||
in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, createdAt, updatedAt}
|
||||
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
|
||||
in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt}
|
||||
|
||||
toContactOrError :: ContactRow :. MaybeConnectionRow -> Either StoreError Contact
|
||||
toContactOrError (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, localAlias, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt)) :. connRow) =
|
||||
toContactOrError :: User -> ContactRow :. MaybeConnectionRow -> Either StoreError Contact
|
||||
toContactOrError user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, localAlias, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt)) :. connRow) =
|
||||
let profile = LocalProfile {profileId, displayName, fullName, image, preferences, localAlias}
|
||||
chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_}
|
||||
in case toMaybeConnection connRow of
|
||||
Just activeConn ->
|
||||
Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, createdAt, updatedAt}
|
||||
let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
|
||||
in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt}
|
||||
_ -> Left $ SEContactNotReady localDisplayName
|
||||
|
||||
-- TODO return the last connection that is ready, not any last connection
|
||||
-- requires updating connection status
|
||||
getContactByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Contact
|
||||
getContactByName db user@User {userId} localDisplayName = do
|
||||
getContactByName db user localDisplayName = do
|
||||
cId <- getContactIdByName db user localDisplayName
|
||||
getContact db userId cId
|
||||
getContact db user cId
|
||||
|
||||
getUserContacts :: DB.Connection -> User -> IO [Contact]
|
||||
getUserContacts db User {userId} = do
|
||||
getUserContacts db user@User {userId} = do
|
||||
contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ?" (Only userId)
|
||||
rights <$> mapM (runExceptT . getContact db userId) contactIds
|
||||
rights <$> mapM (runExceptT . getContact db user) contactIds
|
||||
|
||||
createUserContactLink :: DB.Connection -> UserId -> ConnId -> ConnReqContact -> ExceptT StoreError IO ()
|
||||
createUserContactLink db userId agentConnId cReq =
|
||||
@ -977,8 +990,8 @@ getGroupLinkId db User {userId} GroupInfo {groupId} =
|
||||
fmap join . maybeFirstRow fromOnly $
|
||||
DB.query db "SELECT group_link_id FROM user_contact_links WHERE user_id = ? AND group_id = ? LIMIT 1" (userId, groupId)
|
||||
|
||||
createOrUpdateContactRequest :: DB.Connection -> UserId -> Int64 -> InvitationId -> Profile -> Maybe XContactId -> ExceptT StoreError IO ContactOrRequest
|
||||
createOrUpdateContactRequest db userId userContactLinkId invId Profile {displayName, fullName, image, preferences} xContactId_ =
|
||||
createOrUpdateContactRequest :: DB.Connection -> User -> Int64 -> InvitationId -> Profile -> Maybe XContactId -> ExceptT StoreError IO ContactOrRequest
|
||||
createOrUpdateContactRequest db user@User {userId} userContactLinkId invId Profile {displayName, fullName, image, preferences} xContactId_ =
|
||||
liftIO (maybeM getContact' xContactId_) >>= \case
|
||||
Just contact -> pure $ CORContact contact
|
||||
Nothing -> CORRequest <$> createOrUpdate_
|
||||
@ -1014,7 +1027,7 @@ createOrUpdateContactRequest db userId userContactLinkId invId Profile {displayN
|
||||
insertedRowId db
|
||||
getContact' :: XContactId -> IO (Maybe Contact)
|
||||
getContact' xContactId =
|
||||
maybeFirstRow toContact $
|
||||
maybeFirstRow (toContact user) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
@ -1133,20 +1146,21 @@ deleteContactRequest db userId contactRequestId = do
|
||||
DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND contact_request_id = ?" (userId, contactRequestId)
|
||||
|
||||
createAcceptedContact :: DB.Connection -> User -> ConnId -> ContactName -> ProfileId -> Profile -> Int64 -> Maybe XContactId -> Maybe IncognitoProfile -> IO Contact
|
||||
createAcceptedContact db User {userId, profile = LocalProfile {preferences}} agentConnId localDisplayName profileId profile userContactLinkId xContactId incognitoProfile = do
|
||||
createAcceptedContact db user@User {userId, profile = LocalProfile {preferences}} agentConnId localDisplayName profileId profile userContactLinkId xContactId incognitoProfile = do
|
||||
DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName)
|
||||
createdAt <- getCurrentTime
|
||||
customUserProfileId <- forM incognitoProfile $ \case
|
||||
NewIncognito p -> createIncognitoProfile_ db userId createdAt p
|
||||
ExistingIncognito LocalProfile {profileId = pId} -> pure pId
|
||||
let contactUserPrefs = fromMaybe emptyChatPrefs $ incognitoProfile >> preferences
|
||||
let userPreferences = fromMaybe emptyChatPrefs $ incognitoProfile >> preferences
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO contacts (user_id, local_display_name, contact_profile_id, enable_ntfs, user_preferences, created_at, updated_at, xcontact_id) VALUES (?,?,?,?,?,?,?,?)"
|
||||
(userId, localDisplayName, profileId, True, contactUserPrefs, createdAt, createdAt, xContactId)
|
||||
(userId, localDisplayName, profileId, True, userPreferences, createdAt, createdAt, xContactId)
|
||||
contactId <- insertedRowId db
|
||||
activeConn <- createConnection_ db userId ConnContact (Just contactId) agentConnId Nothing (Just userContactLinkId) customUserProfileId 0 createdAt
|
||||
pure $ Contact {contactId, localDisplayName, profile = toLocalProfile profileId profile "", activeConn, viaGroup = Nothing, contactUsed = False, chatSettings = defaultChatSettings, userPreferences = contactUserPrefs, createdAt = createdAt, updatedAt = createdAt}
|
||||
let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
|
||||
pure $ Contact {contactId, localDisplayName, profile = toLocalProfile profileId profile "", activeConn, viaGroup = Nothing, contactUsed = False, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = createdAt, updatedAt = createdAt}
|
||||
|
||||
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
|
||||
getLiveSndFileTransfers db User {userId} = do
|
||||
@ -1249,8 +1263,8 @@ toMaybeConnection ((Just connId, Just agentConnId, Just connLevel, viaContact, v
|
||||
Just $ toConnection ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. Only createdAt)
|
||||
toMaybeConnection _ = Nothing
|
||||
|
||||
getMatchingContacts :: DB.Connection -> UserId -> Contact -> IO [Contact]
|
||||
getMatchingContacts db userId Contact {contactId, profile = LocalProfile {displayName, fullName, image}} = do
|
||||
getMatchingContacts :: DB.Connection -> User -> Contact -> IO [Contact]
|
||||
getMatchingContacts db user@User {userId} Contact {contactId, profile = LocalProfile {displayName, fullName, image}} = do
|
||||
contactIds <-
|
||||
map fromOnly
|
||||
<$> DB.query
|
||||
@ -1264,7 +1278,7 @@ getMatchingContacts db userId Contact {contactId, profile = LocalProfile {displa
|
||||
AND ((p.image IS NULL AND ? IS NULL) OR p.image = ?)
|
||||
|]
|
||||
(userId, contactId, displayName, fullName, image, image)
|
||||
rights <$> mapM (runExceptT . getContact db userId) contactIds
|
||||
rights <$> mapM (runExceptT . getContact db user) contactIds
|
||||
|
||||
createSentProbe :: DB.Connection -> TVar ChaChaDRG -> UserId -> Contact -> ExceptT StoreError IO (Probe, Int64)
|
||||
createSentProbe db gVar userId _to@Contact {contactId} =
|
||||
@ -1291,8 +1305,8 @@ deleteSentProbe db userId probeId =
|
||||
"DELETE FROM sent_probes WHERE user_id = ? AND sent_probe_id = ?"
|
||||
(userId, probeId)
|
||||
|
||||
matchReceivedProbe :: DB.Connection -> UserId -> Contact -> Probe -> IO (Maybe Contact)
|
||||
matchReceivedProbe db userId _from@Contact {contactId} (Probe probe) = do
|
||||
matchReceivedProbe :: DB.Connection -> User -> Contact -> Probe -> IO (Maybe Contact)
|
||||
matchReceivedProbe db user@User {userId} _from@Contact {contactId} (Probe probe) = do
|
||||
let probeHash = C.sha256Hash probe
|
||||
contactIds <-
|
||||
map fromOnly
|
||||
@ -1312,10 +1326,10 @@ matchReceivedProbe db userId _from@Contact {contactId} (Probe probe) = do
|
||||
(contactId, probe, probeHash, userId, currentTs, currentTs)
|
||||
case contactIds of
|
||||
[] -> pure Nothing
|
||||
cId : _ -> eitherToMaybe <$> runExceptT (getContact db userId cId)
|
||||
cId : _ -> eitherToMaybe <$> runExceptT (getContact db user cId)
|
||||
|
||||
matchReceivedProbeHash :: DB.Connection -> UserId -> Contact -> ProbeHash -> IO (Maybe (Contact, Probe))
|
||||
matchReceivedProbeHash db userId _from@Contact {contactId} (ProbeHash probeHash) = do
|
||||
matchReceivedProbeHash :: DB.Connection -> User -> Contact -> ProbeHash -> IO (Maybe (Contact, Probe))
|
||||
matchReceivedProbeHash db user@User {userId} _from@Contact {contactId} (ProbeHash probeHash) = do
|
||||
namesAndProbes <-
|
||||
DB.query
|
||||
db
|
||||
@ -1335,10 +1349,10 @@ matchReceivedProbeHash db userId _from@Contact {contactId} (ProbeHash probeHash)
|
||||
[] -> pure Nothing
|
||||
(cId, probe) : _ ->
|
||||
either (const Nothing) (Just . (,Probe probe))
|
||||
<$> runExceptT (getContact db userId cId)
|
||||
<$> runExceptT (getContact db user cId)
|
||||
|
||||
matchSentProbe :: DB.Connection -> UserId -> Contact -> Probe -> IO (Maybe Contact)
|
||||
matchSentProbe db userId _from@Contact {contactId} (Probe probe) = do
|
||||
matchSentProbe :: DB.Connection -> User -> Contact -> Probe -> IO (Maybe Contact)
|
||||
matchSentProbe db user@User {userId} _from@Contact {contactId} (Probe probe) = do
|
||||
contactIds <-
|
||||
map fromOnly
|
||||
<$> DB.query
|
||||
@ -1353,7 +1367,7 @@ matchSentProbe db userId _from@Contact {contactId} (Probe probe) = do
|
||||
(userId, probe, contactId)
|
||||
case contactIds of
|
||||
[] -> pure Nothing
|
||||
cId : _ -> eitherToMaybe <$> runExceptT (getContact db userId cId)
|
||||
cId : _ -> eitherToMaybe <$> runExceptT (getContact db user cId)
|
||||
|
||||
mergeContactRecords :: DB.Connection -> UserId -> Contact -> Contact -> IO ()
|
||||
mergeContactRecords db userId Contact {contactId = toContactId} Contact {contactId = fromContactId, localDisplayName} = do
|
||||
@ -1438,7 +1452,8 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
|
||||
toContact' contactId activeConn [(profileId, localDisplayName, displayName, fullName, image, localAlias, viaGroup, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt)] =
|
||||
let profile = LocalProfile {profileId, displayName, fullName, image, preferences, localAlias}
|
||||
chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_}
|
||||
in Right $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, createdAt, updatedAt}
|
||||
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
|
||||
in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt}
|
||||
toContact' _ _ _ = Left $ SEInternalError "referenced contact not found"
|
||||
getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
getGroupAndMember_ groupMemberId c = ExceptT $ do
|
||||
@ -1590,6 +1605,7 @@ updateConnectionStatus db Connection {connId} connStatus = do
|
||||
createNewGroup :: DB.Connection -> TVar ChaChaDRG -> User -> GroupProfile -> ExceptT StoreError IO GroupInfo
|
||||
createNewGroup db gVar user@User {userId} groupProfile = ExceptT $ do
|
||||
let GroupProfile {displayName, fullName, image, groupPreferences} = groupProfile
|
||||
fullGroupPreferences = mergeGroupPreferences groupPreferences
|
||||
currentTs <- getCurrentTime
|
||||
withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do
|
||||
groupId <- liftIO $ do
|
||||
@ -1606,7 +1622,7 @@ createNewGroup db gVar user@User {userId} groupProfile = ExceptT $ do
|
||||
memberId <- liftIO $ encodedRandomBytes gVar 12
|
||||
membership <- createContactMemberInv_ db user groupId user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser Nothing currentTs
|
||||
let chatSettings = ChatSettings {enableNtfs = True}
|
||||
pure GroupInfo {groupId, localDisplayName = ldn, groupProfile, membership, hostConnCustomUserProfileId = Nothing, chatSettings, createdAt = currentTs, updatedAt = currentTs}
|
||||
pure GroupInfo {groupId, localDisplayName = ldn, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = Nothing, chatSettings, createdAt = currentTs, updatedAt = currentTs}
|
||||
|
||||
-- | creates a new group record for the group the current user was invited to, or returns an existing one
|
||||
createGroupInvitation :: DB.Connection -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
|
||||
@ -1633,6 +1649,7 @@ createGroupInvitation db user@User {userId} contact@Contact {contactId, activeCo
|
||||
createGroupInvitation_ :: ExceptT StoreError IO (GroupInfo, GroupMemberId)
|
||||
createGroupInvitation_ = do
|
||||
let GroupProfile {displayName, fullName, image, groupPreferences} = groupProfile
|
||||
fullGroupPreferences = mergeGroupPreferences groupPreferences
|
||||
ExceptT $
|
||||
withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
@ -1650,7 +1667,7 @@ createGroupInvitation db user@User {userId} contact@Contact {contactId, activeCo
|
||||
GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId contact fromMember GCHostMember GSMemInvited IBUnknown Nothing currentTs
|
||||
membership <- createContactMemberInv_ db user groupId user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId currentTs
|
||||
let chatSettings = ChatSettings {enableNtfs = True}
|
||||
pure (GroupInfo {groupId, localDisplayName, groupProfile, membership, hostConnCustomUserProfileId = customUserProfileId, chatSettings, createdAt = currentTs, updatedAt = currentTs}, groupMemberId)
|
||||
pure (GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = customUserProfileId, chatSettings, createdAt = currentTs, updatedAt = currentTs}, groupMemberId)
|
||||
|
||||
getHostMemberId_ :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO GroupMemberId
|
||||
getHostMemberId_ db User {userId} groupId =
|
||||
@ -1805,7 +1822,8 @@ toGroupInfo :: Int64 -> GroupInfoRow -> GroupInfo
|
||||
toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, image, hostConnCustomUserProfileId, enableNtfs_, groupPreferences, createdAt, updatedAt) :. userMemberRow) =
|
||||
let membership = toGroupMember userContactId userMemberRow
|
||||
chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_}
|
||||
in GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName, fullName, image, groupPreferences}, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt}
|
||||
fullGroupPreferences = mergeGroupPreferences groupPreferences
|
||||
in GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName, fullName, image, groupPreferences}, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt}
|
||||
|
||||
getGroupMember :: DB.Connection -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO GroupMember
|
||||
getGroupMember db user@User {userId} groupId groupMemberId =
|
||||
@ -1976,8 +1994,8 @@ createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Co
|
||||
)
|
||||
|
||||
getContactViaMember :: DB.Connection -> User -> GroupMember -> IO (Maybe Contact)
|
||||
getContactViaMember db User {userId} GroupMember {groupMemberId} =
|
||||
maybeFirstRow toContact $
|
||||
getContactViaMember db user@User {userId} GroupMember {groupMemberId} =
|
||||
maybeFirstRow (toContact user) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
@ -2102,7 +2120,7 @@ cleanupMemberContactAndProfile_ :: DB.Connection -> User -> GroupMember -> IO ()
|
||||
cleanupMemberContactAndProfile_ db user@User {userId} m@GroupMember {groupMemberId, localDisplayName, memberContactId, memberContactProfileId, memberProfile = LocalProfile {profileId}} =
|
||||
case memberContactId of
|
||||
Just contactId ->
|
||||
runExceptT (getContact db userId contactId) >>= \case
|
||||
runExceptT (getContact db user contactId) >>= \case
|
||||
Right ct@Contact {activeConn = Connection {connLevel, viaGroupLink}, contactUsed} ->
|
||||
unless ((connLevel == 0 && not viaGroupLink) || contactUsed) $ deleteContact db user ct
|
||||
_ -> pure ()
|
||||
@ -2320,7 +2338,7 @@ getViaGroupMember db User {userId, userContactId} Contact {contactId} =
|
||||
in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow})
|
||||
|
||||
getViaGroupContact :: DB.Connection -> User -> GroupMember -> IO (Maybe Contact)
|
||||
getViaGroupContact db User {userId} GroupMember {groupMemberId} =
|
||||
getViaGroupContact db user@User {userId} GroupMember {groupMemberId} =
|
||||
maybeFirstRow toContact' $
|
||||
DB.query
|
||||
db
|
||||
@ -2347,7 +2365,8 @@ getViaGroupContact db User {userId} GroupMember {groupMemberId} =
|
||||
let profile = LocalProfile {profileId, displayName, fullName, image, preferences, localAlias}
|
||||
chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_}
|
||||
activeConn = toConnection connRow
|
||||
in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, createdAt, updatedAt}
|
||||
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
|
||||
in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt}
|
||||
|
||||
createSndDirectFileTransfer :: DB.Connection -> UserId -> Contact -> FilePath -> FileInvitation -> Maybe ConnId -> Integer -> IO FileTransferMeta
|
||||
createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitation {fileName, fileSize, fileInline} acId_ chunkSize = do
|
||||
@ -2659,7 +2678,7 @@ getRcvFileTransfer db user@User {userId} fileId = do
|
||||
rfi_ = \case
|
||||
(Just filePath, Just connId, Just agentConnId, _, _, _, _) -> pure $ Just RcvFileInfo {filePath, connId, agentConnId}
|
||||
(Just filePath, Nothing, Nothing, Just contactId, _, _, True) -> do
|
||||
Contact {activeConn = Connection {connId, agentConnId}} <- getContact db userId contactId
|
||||
Contact {activeConn = Connection {connId, agentConnId}} <- getContact db user contactId
|
||||
pure $ Just RcvFileInfo {filePath, connId, agentConnId}
|
||||
(Just filePath, Nothing, Nothing, _, Just groupId, Just groupMemberId, True) -> do
|
||||
getGroupMember db user groupId groupMemberId >>= \case
|
||||
@ -3194,7 +3213,7 @@ getChatPreviews db user withPCC = do
|
||||
ts (AChat _ Chat {chatInfo}) = chatInfoUpdatedAt chatInfo
|
||||
|
||||
getDirectChatPreviews_ :: DB.Connection -> User -> IO [AChat]
|
||||
getDirectChatPreviews_ db User {userId} = do
|
||||
getDirectChatPreviews_ db user@User {userId} = do
|
||||
tz <- getCurrentTimeZone
|
||||
currentTs <- getCurrentTime
|
||||
map (toDirectChatPreview tz currentTs)
|
||||
@ -3253,7 +3272,7 @@ getDirectChatPreviews_ db User {userId} = do
|
||||
where
|
||||
toDirectChatPreview :: TimeZone -> UTCTime -> ContactRow :. ConnectionRow :. ChatStatsRow :. MaybeChatItemRow :. QuoteRow -> AChat
|
||||
toDirectChatPreview tz currentTs (contactRow :. connRow :. statsRow :. ciRow_) =
|
||||
let contact = toContact $ contactRow :. connRow
|
||||
let contact = toContact user $ contactRow :. connRow
|
||||
ci_ = toDirectChatItemList tz currentTs ciRow_
|
||||
stats = toChatStats statsRow
|
||||
in AChat SCTDirect $ Chat (DirectChat contact) ci_ stats
|
||||
@ -3420,8 +3439,8 @@ getDirectChat db user contactId pagination search_ = do
|
||||
CPBefore beforeId count -> getDirectChatBefore_ db user contactId beforeId count search
|
||||
|
||||
getDirectChatLast_ :: DB.Connection -> User -> Int64 -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect)
|
||||
getDirectChatLast_ db User {userId} contactId count search = do
|
||||
contact <- getContact db userId contactId
|
||||
getDirectChatLast_ db user@User {userId} contactId count search = do
|
||||
contact <- getContact db user contactId
|
||||
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
|
||||
chatItems <- ExceptT getDirectChatItemsLast_
|
||||
pure $ Chat (DirectChat contact) (reverse chatItems) stats
|
||||
@ -3451,8 +3470,8 @@ getDirectChatLast_ db User {userId} contactId count search = do
|
||||
(userId, contactId, search, count)
|
||||
|
||||
getDirectChatAfter_ :: DB.Connection -> User -> Int64 -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect)
|
||||
getDirectChatAfter_ db User {userId} contactId afterChatItemId count search = do
|
||||
contact <- getContact db userId contactId
|
||||
getDirectChatAfter_ db user@User {userId} contactId afterChatItemId count search = do
|
||||
contact <- getContact db user contactId
|
||||
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
|
||||
chatItems <- ExceptT getDirectChatItemsAfter_
|
||||
pure $ Chat (DirectChat contact) chatItems stats
|
||||
@ -3483,8 +3502,8 @@ getDirectChatAfter_ db User {userId} contactId afterChatItemId count search = do
|
||||
(userId, contactId, search, afterChatItemId, count)
|
||||
|
||||
getDirectChatBefore_ :: DB.Connection -> User -> Int64 -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect)
|
||||
getDirectChatBefore_ db User {userId} contactId beforeChatItemId count search = do
|
||||
contact <- getContact db userId contactId
|
||||
getDirectChatBefore_ db user@User {userId} contactId beforeChatItemId count search = do
|
||||
contact <- getContact db user contactId
|
||||
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
|
||||
chatItems <- ExceptT getDirectChatItemsBefore_
|
||||
pure $ Chat (DirectChat contact) (reverse chatItems) stats
|
||||
@ -3519,9 +3538,9 @@ getContactIdByName db User {userId} cName =
|
||||
ExceptT . firstRow fromOnly (SEContactNotFoundByName cName) $
|
||||
DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND local_display_name = ?" (userId, cName)
|
||||
|
||||
getContact :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO Contact
|
||||
getContact db userId contactId =
|
||||
ExceptT . fmap join . firstRow toContactOrError (SEContactNotFound contactId) $
|
||||
getContact :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Contact
|
||||
getContact db user@User {userId} contactId =
|
||||
ExceptT . fmap join . firstRow (toContactOrError user) (SEContactNotFound contactId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
@ -4076,7 +4095,7 @@ getChatItemByGroupId db user@User {userId} groupId = do
|
||||
getAChatItem_ :: DB.Connection -> User -> ChatItemId -> ChatRef -> ExceptT StoreError IO AChatItem
|
||||
getAChatItem_ db user@User {userId} itemId = \case
|
||||
ChatRef CTDirect contactId -> do
|
||||
ct <- getContact db userId contactId
|
||||
ct <- getContact db user contactId
|
||||
(CChatItem msgDir ci) <- getDirectChatItem db userId contactId itemId
|
||||
pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci
|
||||
ChatRef CTGroup groupId -> do
|
||||
|
||||
@ -66,6 +66,7 @@ data User = User
|
||||
userContactId :: ContactId,
|
||||
localDisplayName :: ContactName,
|
||||
profile :: LocalProfile,
|
||||
fullPreferences :: FullPreferences,
|
||||
activeUser :: Bool
|
||||
}
|
||||
deriving (Show, Generic, FromJSON)
|
||||
@ -87,6 +88,7 @@ data Contact = Contact
|
||||
contactUsed :: Bool,
|
||||
chatSettings :: ChatSettings,
|
||||
userPreferences :: Preferences,
|
||||
mergedPreferences :: ContactUserPreferences,
|
||||
createdAt :: UTCTime,
|
||||
updatedAt :: UTCTime
|
||||
}
|
||||
@ -100,13 +102,10 @@ contactConn :: Contact -> Connection
|
||||
contactConn = activeConn
|
||||
|
||||
contactConnId :: Contact -> ConnId
|
||||
contactConnId Contact {activeConn} = aConnId activeConn
|
||||
contactConnId = aConnId . contactConn
|
||||
|
||||
contactConnIncognito :: Contact -> Bool
|
||||
contactConnIncognito = isJust . customUserProfileId'
|
||||
|
||||
customUserProfileId' :: Contact -> Maybe Int64
|
||||
customUserProfileId' Contact {activeConn} = customUserProfileId (activeConn :: Connection)
|
||||
contactConnIncognito = connIncognito . contactConn
|
||||
|
||||
data ContactRef = ContactRef
|
||||
{ contactId :: ContactId,
|
||||
@ -207,6 +206,7 @@ data GroupInfo = GroupInfo
|
||||
{ groupId :: GroupId,
|
||||
localDisplayName :: GroupName,
|
||||
groupProfile :: GroupProfile,
|
||||
fullGroupPreferences :: FullGroupPreferences,
|
||||
membership :: GroupMember,
|
||||
hostConnCustomUserProfileId :: Maybe ProfileId,
|
||||
chatSettings :: ChatSettings,
|
||||
@ -293,6 +293,39 @@ data Preferences = Preferences
|
||||
}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
instance ToJSON Preferences where
|
||||
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
|
||||
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
|
||||
|
||||
instance ToField Preferences where
|
||||
toField = toField . encodeJSON
|
||||
|
||||
instance FromField Preferences where
|
||||
fromField = fromTextField_ decodeJSON
|
||||
|
||||
groupPrefSel :: ChatFeature -> GroupPreferences -> Maybe GroupPreference
|
||||
groupPrefSel = \case
|
||||
CFFullDelete -> fullDelete
|
||||
-- CFReceipts -> receipts
|
||||
CFVoice -> voice
|
||||
|
||||
class GroupPreferenceI p where
|
||||
getGroupPreference :: ChatFeature -> p -> GroupPreference
|
||||
|
||||
instance GroupPreferenceI GroupPreferences where
|
||||
getGroupPreference pt prefs = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPrefSel pt prefs)
|
||||
|
||||
instance GroupPreferenceI (Maybe GroupPreferences) where
|
||||
getGroupPreference pt prefs = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPrefSel pt =<< prefs)
|
||||
|
||||
instance GroupPreferenceI FullGroupPreferences where
|
||||
getGroupPreference = \case
|
||||
CFFullDelete -> fullDelete
|
||||
-- CFReceipts -> receipts
|
||||
CFVoice -> voice
|
||||
{-# INLINE getGroupPreference #-}
|
||||
|
||||
-- collection of optional group preferences
|
||||
data GroupPreferences = GroupPreferences
|
||||
{ fullDelete :: Maybe GroupPreference,
|
||||
-- receipts :: Maybe GroupPreference,
|
||||
@ -317,7 +350,20 @@ data FullPreferences = FullPreferences
|
||||
-- receipts :: Preference,
|
||||
voice :: Preference
|
||||
}
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
instance ToJSON FullPreferences where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
-- full collection of group preferences defined in the app - it is used to ensure we include all preferences and to simplify processing
|
||||
-- if some of the preferences are not defined in GroupPreferences, defaults from defaultGroupPrefs are used here.
|
||||
data FullGroupPreferences = FullGroupPreferences
|
||||
{ fullDelete :: GroupPreference,
|
||||
-- receipts :: GroupPreference,
|
||||
voice :: GroupPreference
|
||||
}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
instance ToJSON FullGroupPreferences where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
-- merged preferences of user for a given contact - they differentiate between specific preferences for the contact and global user preferences
|
||||
data ContactUserPreferences = ContactUserPreferences
|
||||
@ -325,17 +371,17 @@ data ContactUserPreferences = ContactUserPreferences
|
||||
-- receipts :: ContactUserPreference,
|
||||
voice :: ContactUserPreference
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
data ContactUserPreference = ContactUserPreference
|
||||
{ enabled :: PrefEnabled,
|
||||
userPreference :: ContactUserPref,
|
||||
contactPreference :: Preference
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
data ContactUserPref = CUPContact {preference :: Preference} | CUPUser {preference :: Preference}
|
||||
deriving (Show, Generic)
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON ContactUserPreferences where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
@ -364,26 +410,24 @@ defaultChatPrefs =
|
||||
emptyChatPrefs :: Preferences
|
||||
emptyChatPrefs = Preferences Nothing Nothing
|
||||
|
||||
instance ToJSON Preferences where
|
||||
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
|
||||
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
|
||||
|
||||
instance ToField Preferences where
|
||||
toField = toField . encodeJSON
|
||||
|
||||
instance FromField Preferences where
|
||||
fromField = fromTextField_ decodeJSON
|
||||
defaultGroupPrefs :: FullGroupPreferences
|
||||
defaultGroupPrefs =
|
||||
FullGroupPreferences
|
||||
{ fullDelete = GroupPreference {enable = FEOff},
|
||||
-- receipts = GroupPreference {enable = FEOff},
|
||||
voice = GroupPreference {enable = FEOn}
|
||||
}
|
||||
|
||||
data Preference = Preference
|
||||
{allow :: FeatureAllowed}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
instance ToJSON Preference where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
data GroupPreference = GroupPreference
|
||||
{enable :: GroupFeatureEnabled}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
instance ToJSON Preference where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
instance ToJSON GroupPreference where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
data FeatureAllowed
|
||||
@ -392,9 +436,6 @@ data FeatureAllowed
|
||||
| FANo -- do not allow
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
data GroupFeatureEnabled = FEOn | FEOff
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance FromField FeatureAllowed where fromField = fromBlobField_ strDecode
|
||||
|
||||
instance ToField FeatureAllowed where toField = toField . strEncode
|
||||
@ -418,6 +459,9 @@ instance ToJSON FeatureAllowed where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
data GroupFeatureEnabled = FEOn | FEOff
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance FromField GroupFeatureEnabled where fromField = fromBlobField_ strDecode
|
||||
|
||||
instance ToField GroupFeatureEnabled where toField = toField . strEncode
|
||||
@ -452,12 +496,25 @@ mergePreferences contactPrefs userPreferences =
|
||||
in fromMaybe (getPreference pt defaultChatPrefs) $ (contactPrefs >>= sel) <|> (userPreferences >>= sel)
|
||||
|
||||
mergeUserChatPrefs :: User -> Contact -> FullPreferences
|
||||
mergeUserChatPrefs user ct =
|
||||
let userPrefs = if contactConnIncognito ct then Nothing else preferences' user
|
||||
in mergePreferences (Just $ userPreferences ct) userPrefs
|
||||
mergeUserChatPrefs user ct = mergeUserChatPrefs' user (contactConnIncognito ct) (userPreferences ct)
|
||||
|
||||
mergeUserChatPrefs' :: User -> Bool -> Preferences -> FullPreferences
|
||||
mergeUserChatPrefs' user connectedIncognito userPreferences =
|
||||
let userPrefs = if connectedIncognito then Nothing else preferences' user
|
||||
in mergePreferences (Just userPreferences) userPrefs
|
||||
|
||||
mergeGroupPreferences :: Maybe GroupPreferences -> FullGroupPreferences
|
||||
mergeGroupPreferences groupPreferences =
|
||||
FullGroupPreferences
|
||||
{ fullDelete = pref CFFullDelete,
|
||||
-- receipts = pref CFReceipts,
|
||||
voice = pref CFVoice
|
||||
}
|
||||
where
|
||||
pref pt = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPreferences >>= groupPrefSel pt)
|
||||
|
||||
data PrefEnabled = PrefEnabled {forUser :: Bool, forContact :: Bool}
|
||||
deriving (Show, Generic)
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON PrefEnabled where
|
||||
toJSON = J.genericToJSON J.defaultOptions
|
||||
@ -471,8 +528,8 @@ prefEnabled Preference {allow = user} Preference {allow = contact} = case (user,
|
||||
(FANo, _) -> PrefEnabled False False
|
||||
_ -> PrefEnabled True True
|
||||
|
||||
contactUserPreferences :: User -> Contact -> ContactUserPreferences
|
||||
contactUserPreferences user ct =
|
||||
contactUserPreferences :: User -> Preferences -> Maybe Preferences -> Bool -> ContactUserPreferences
|
||||
contactUserPreferences user userPreferences contactPreferences connectedIncognito =
|
||||
ContactUserPreferences
|
||||
{ fullDelete = pref CFFullDelete,
|
||||
-- receipts = pref CFReceipts,
|
||||
@ -483,19 +540,19 @@ contactUserPreferences user ct =
|
||||
ContactUserPreference
|
||||
{ enabled = prefEnabled userPref ctPref,
|
||||
-- incognito contact cannot have default user preference used
|
||||
userPreference = if contactConnIncognito ct then CUPContact ctUserPref else maybe (CUPUser userPref) CUPContact ctUserPref_,
|
||||
userPreference = if connectedIncognito then CUPContact ctUserPref else maybe (CUPUser userPref) CUPContact ctUserPref_,
|
||||
contactPreference = ctPref
|
||||
}
|
||||
where
|
||||
ctUserPref = getPreference pt $ userPreferences ct
|
||||
ctUserPref_ = chatPrefSel pt $ userPreferences ct
|
||||
ctUserPref = getPreference pt userPreferences
|
||||
ctUserPref_ = chatPrefSel pt userPreferences
|
||||
userPref = getPreference pt ctUserPrefs
|
||||
ctPref = getPreference pt ctPrefs
|
||||
ctUserPrefs = mergeUserChatPrefs user ct
|
||||
ctPrefs = mergePreferences (preferences' ct) Nothing
|
||||
ctUserPrefs = mergeUserChatPrefs' user connectedIncognito userPreferences
|
||||
ctPrefs = mergePreferences contactPreferences Nothing
|
||||
|
||||
getContactUserPrefefence :: ChatFeature -> ContactUserPreferences -> ContactUserPreference
|
||||
getContactUserPrefefence = \case
|
||||
getContactUserPreference :: ChatFeature -> ContactUserPreferences -> ContactUserPreference
|
||||
getContactUserPreference = \case
|
||||
CFFullDelete -> fullDelete
|
||||
-- CFReceipts -> receipts
|
||||
CFVoice -> voice
|
||||
@ -1144,6 +1201,9 @@ data Connection = Connection
|
||||
aConnId :: Connection -> ConnId
|
||||
aConnId Connection {agentConnId = AgentConnId cId} = cId
|
||||
|
||||
connIncognito :: Connection -> Bool
|
||||
connIncognito Connection {customUserProfileId} = isJust customUserProfileId
|
||||
|
||||
instance ToJSON Connection where
|
||||
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
|
||||
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
|
||||
|
||||
@ -125,13 +125,13 @@ responseToView user_ testView ts = \case
|
||||
CRSndGroupFileCancelled _ ftm fts -> viewSndGroupFileCancelled ftm fts
|
||||
CRRcvFileCancelled ft -> receivingFile_ "cancelled" ft
|
||||
CRUserProfileUpdated p p' -> viewUserProfileUpdated p p'
|
||||
CRContactPrefsUpdated {fromContact, toContact, preferences} -> case user_ of
|
||||
Just user -> viewUserContactPrefsUpdated user fromContact toContact preferences
|
||||
CRContactPrefsUpdated {fromContact, toContact} -> case user_ of
|
||||
Just user -> viewUserContactPrefsUpdated user fromContact toContact
|
||||
_ -> ["unexpected chat event CRContactPrefsUpdated without current user"]
|
||||
CRContactAliasUpdated c -> viewContactAliasUpdated c
|
||||
CRConnectionAliasUpdated c -> viewConnectionAliasUpdated c
|
||||
CRContactUpdated {fromContact = c, toContact = c', preferences} -> case user_ of
|
||||
Just user -> viewContactUpdated c c' <> viewContactPrefsUpdated user c c' preferences
|
||||
CRContactUpdated {fromContact = c, toContact = c'} -> case user_ of
|
||||
Just user -> viewContactUpdated c c' <> viewContactPrefsUpdated user c c'
|
||||
_ -> ["unexpected chat event CRContactUpdated without current user"]
|
||||
CRContactsMerged intoCt mergedCt -> viewContactsMerged intoCt mergedCt
|
||||
CRReceivedContactRequest UserContactRequest {localDisplayName = c, profile} -> viewReceivedContactRequest c profile
|
||||
@ -710,15 +710,15 @@ viewUserProfileUpdated Profile {displayName = n, fullName, image, preferences} P
|
||||
| otherwise = ["user profile is changed to " <> ttyFullName n' fullName' <> notified]
|
||||
notified = " (your contacts are notified)"
|
||||
|
||||
viewUserContactPrefsUpdated :: User -> Contact -> Contact -> ContactUserPreferences -> [StyledString]
|
||||
viewUserContactPrefsUpdated user ct ct' cups
|
||||
viewUserContactPrefsUpdated :: User -> Contact -> Contact -> [StyledString]
|
||||
viewUserContactPrefsUpdated user ct ct'@Contact {mergedPreferences = cups}
|
||||
| null prefs = ["your preferences for " <> ttyContact' ct' <> " did not change"]
|
||||
| otherwise = ("you updated preferences for " <> ttyContact' ct' <> ":") : prefs
|
||||
where
|
||||
prefs = viewContactPreferences user ct ct' cups
|
||||
|
||||
viewContactPrefsUpdated :: User -> Contact -> Contact -> ContactUserPreferences -> [StyledString]
|
||||
viewContactPrefsUpdated user ct ct' cups
|
||||
viewContactPrefsUpdated :: User -> Contact -> Contact -> [StyledString]
|
||||
viewContactPrefsUpdated user ct ct'@Contact {mergedPreferences = cups}
|
||||
| null prefs = []
|
||||
| otherwise = (ttyContact' ct' <> " updated preferences for you:") : prefs
|
||||
where
|
||||
@ -736,7 +736,7 @@ viewContactPref userPrefs userPrefs' ctPrefs cups pt
|
||||
userPref = getPreference pt userPrefs
|
||||
userPref' = getPreference pt userPrefs'
|
||||
ctPref = getPreference pt ctPrefs
|
||||
ContactUserPreference {enabled, userPreference, contactPreference} = getContactUserPrefefence pt cups
|
||||
ContactUserPreference {enabled, userPreference, contactPreference} = getContactUserPreference pt cups
|
||||
|
||||
viewPrefsUpdated :: Maybe Preferences -> Maybe Preferences -> [StyledString]
|
||||
viewPrefsUpdated ps ps'
|
||||
|
||||
@ -32,9 +32,9 @@ activeUserExists = "{\"resp\":{\"type\":\"chatCmdError\",\"chatError\":{\"type\"
|
||||
|
||||
activeUser :: String
|
||||
#if defined(darwin_HOST_OS) && defined(swiftJSON)
|
||||
activeUser = "{\"resp\":{\"activeUser\":{\"user\":{\"userId\":1,\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"activeUser\":true}}}}"
|
||||
activeUser = "{\"resp\":{\"activeUser\":{\"user\":{\"userId\":1,\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true}}}"
|
||||
#else
|
||||
activeUser = "{\"resp\":{\"type\":\"activeUser\",\"user\":{\"userId\":1,\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"activeUser\":true}}}"
|
||||
activeUser = "{\"resp\":{\"type\":\"activeUser\",\"user\":{\"userId\":1,\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true}}}"
|
||||
#endif
|
||||
|
||||
chatStarted :: String
|
||||
|
||||
Loading…
Reference in New Issue
Block a user