diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index e05d811d0b..8156722c9f 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -55,7 +55,7 @@ import Data.Type.Equality import qualified Data.UUID as UUID import qualified Data.UUID.V4 as V4 import Simplex.Chat.Library.Subscriber -import Simplex.Chat.Badges (Badge (..), BadgeCrypto (..), BadgeStatus (..), LocalBadge (..), verifyCredential) +import Simplex.Chat.Badges (Badge (..), BadgeCrypto (..), LocalBadge (..), mkBadgeStatus, verifyCredential) import Simplex.Chat.Call import Simplex.Chat.Controller import Simplex.Chat.Delivery (DeliveryJobScope (..), DeliveryJobSpec (..), DeliveryWorkerScope (..)) @@ -3144,7 +3144,7 @@ processChatCommand cxt nm = \case joinPreparedConn subMode conn joinPreparedConn subMode conn = do -- [incognito] send membership incognito profile - let p = userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile gInfo) Nothing True + p <- presentUserBadge' (incognitoMembershipProfile gInfo) user $ userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile gInfo) Nothing True dm <- encodeConnInfo $ XInfo p (sqSecured, _serviceId) <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm PQSupportOff subMode let newStatus = if sqSecured then ConnSndReady else ConnJoined @@ -3522,7 +3522,7 @@ processChatCommand cxt nm = \case conn <- withFastStore' $ \db -> createDirectConnection' db userId connId ccLink contactId_ ConnPrepared incognitoProfile subMode chatV pqSup' joinPreparedConn conn incognitoProfile chatV joinPreparedConn conn incognitoProfile chatV = do - let profileToSend = userProfileDirect user incognitoProfile Nothing True + profileToSend <- presentUserBadge' incognitoProfile user $ userProfileDirect user incognitoProfile Nothing True dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend (sqSecured, _serviceId) <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm pqSup' subMode let newStatus = if sqSecured then ConnSndReady else ConnJoined @@ -3669,11 +3669,12 @@ processChatCommand cxt nm = \case joinContact :: User -> Connection -> ConnReqContact -> Maybe Profile -> XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> Maybe (Maybe GroupInfo) -> PQSupport -> CM Connection joinContact user conn@Connection {connChatVersion = chatV} cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ pqSup = do -- gInfo_ is Maybe (Maybe GroupInfo), where Just Nothing means "some unknown group", e.g. when joining via link without profile - let profileToSend = case gInfo_ of - Just gInfo_' -> - let allowSimplexLinks = maybe True (groupFeatureUserAllowed SGFSimplexLinks) gInfo_' - in userProfileInGroup' user allowSimplexLinks incognitoProfile - Nothing -> userProfileDirect user incognitoProfile Nothing True + profileToSend <- + presentUserBadge' incognitoProfile user $ case gInfo_ of + Just gInfo_' -> + let allowSimplexLinks = maybe True (groupFeatureUserAllowed SGFSimplexLinks) gInfo_' + in userProfileInGroup' user allowSimplexLinks incognitoProfile + Nothing -> userProfileDirect user incognitoProfile Nothing True chatEvent <- case gInfo_ of Just (Just gInfo) | useRelays' gInfo -> do let GroupInfo {membership = GroupMember {memberId}} = gInfo @@ -3784,7 +3785,8 @@ processChatCommand cxt nm = \case mergedProfile' = userProfileDirect user (fromLocalProfile <$> incognitoProfile) (Just ct') False when (mergedProfile' /= mergedProfile) $ withContactLock "updateContactPrefs" (contactId' ct) $ do - void (sendDirectContactMessage user ct' $ XInfo mergedProfile') `catchAllErrors` eToView + p <- presentUserBadge' incognitoProfile user mergedProfile' + void (sendDirectContactMessage user ct' $ XInfo p) `catchAllErrors` eToView lift . when (directOrUsed ct') $ createSndFeatureItems user ct ct' pure $ CRContactPrefsUpdated user ct ct' runUpdateGroupProfile :: User -> GroupInfo -> GroupProfile -> CM ChatResponse @@ -4649,11 +4651,12 @@ createContactsSndFeatureItems user cts = -- attach an issued badge credential to the user's own profile and present it to all current contacts. -- the credential is stored once; every profile send generates a fresh single-use proof (see presentUserBadge). addUserBadge :: User -> Badge 'BCCredential -> CM () -addUserBadge user cred = do +addUserBadge user cred@(BadgeCredential _ _ info) = do key <- asks $ badgePublicKey . config verified <- liftIO $ verifyCredential key cred unless verified $ throwCmdError "badge credential does not verify against configured key" - user' <- withFastStore' $ \db -> setUserBadge db user (Just (OwnBadge cred BSActive)) + now <- liftIO getCurrentTime + user' <- withFastStore' $ \db -> setUserBadge db user (Just (OwnBadge cred (mkBadgeStatus now True info))) asks currentUser >>= atomically . (`writeTVar` Just user') cxt <- asks $ mkStoreCxt . config contacts <- withFastStore' $ \db -> getUserContacts db cxt user' diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index ec9564765c..3689a908eb 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -907,7 +907,7 @@ acceptContactRequest nm user@User {userId} UserContactRequest {agentInvitationId Just conn@Connection {customUserProfileId} -> do incognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId pure (ct, conn, ExistingIncognito <$> incognitoProfile) - let profileToSend = userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True + profileToSend <- presentUserBadge' incognitoProfile user $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend -- TODO [certs rcv] (ct,conn,) . fst <$> withAgent (\a -> acceptContact a nm (aUserId user) (aConnId conn) True invId dm pqSup' subMode) @@ -920,7 +920,7 @@ acceptContactRequestAsync UserContactRequest {agentInvitationId = AgentInvId cReqInvId, cReqChatVRange, xContactId, pqSupport = cReqPQSup} incognitoProfile = do subMode <- chatReadVar subscriptionMode - let profileToSend = userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True + profileToSend <- presentUserBadge' incognitoProfile user $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True cxt <- chatStoreCxt let chatV = vr cxt `peerConnChatVersion` cReqChatVRange (cmdId, acId) <- agentAcceptContactAsync user True cReqInvId (XInfo profileToSend) subMode cReqPQSup chatV @@ -1907,6 +1907,12 @@ presentUserBadge User {profile = LocalProfile {localBadge}} p = case localBadge Left e -> p <$ logError ("presentUserBadge: proof generation failed: " <> T.pack e) _ -> pure p +-- gated on the send's incognito profile: an incognito identity must never carry the user's badge +presentUserBadge' :: Maybe a -> User -> Profile -> CM Profile +presentUserBadge' incognitoProfile user p = case incognitoProfile of + Just _ -> pure p + Nothing -> presentUserBadge user p + sendDirectContactMessage :: MsgEncodingI e => User -> Contact -> ChatMsgEvent e -> CM (SndMessage, Int64) sendDirectContactMessage user ct chatMsgEvent = do conn@Connection {connId} <- liftEither $ contactSendConn_ ct @@ -2114,8 +2120,9 @@ sendGroupMessages user gInfo scope asGroup members events = do sendProfileUpdate = do let members' = filter (`supportsVersion` memberProfileUpdateVersion) members allowSimplexLinks = groupFeatureUserAllowed SGFSimplexLinks gInfo - profileUpdateEvent = XInfo $ redactedMemberProfile allowSimplexLinks $ fromLocalProfile p - void $ sendGroupMessage' user gInfo members' profileUpdateEvent + -- shouldSendProfileUpdate excludes incognito membership, so the badge is presented + profileUpdate <- presentUserBadge user $ redactedMemberProfile allowSimplexLinks $ fromLocalProfile p + void $ sendGroupMessage' user gInfo members' $ XInfo profileUpdate currentTs <- liftIO getCurrentTime withStore' $ \db -> updateUserMemberProfileSentAt db user gInfo currentTs diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index b63d61c6a9..34400f324c 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -437,9 +437,10 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = -- [incognito] send saved profile (conn'', gInfo_) <- saveConnInfo conn' connInfo incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId) - let profileToSend = case gInfo_ of - Just gInfo -> userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile) - Nothing -> userProfileDirect user (fromLocalProfile <$> incognitoProfile) Nothing True + profileToSend <- + presentUserBadge' incognitoProfile user $ case gInfo_ of + Just gInfo -> userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile) + Nothing -> userProfileDirect user (fromLocalProfile <$> incognitoProfile) Nothing True -- [async agent commands] no continuation needed, but command should be asynchronous for stability allowAgentConnectionAsync user conn'' confId $ XInfo profileToSend INFO pqSupport connInfo -> do @@ -555,7 +556,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = ct' <- processContactProfileUpdate ct profile False `catchAllErrors` const (pure ct) -- [incognito] send incognito profile incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId - let p = userProfileDirect user (fromLocalProfile <$> incognitoProfile) (Just ct') True + p <- presentUserBadge' incognitoProfile user $ userProfileDirect user (fromLocalProfile <$> incognitoProfile) (Just ct') True allowAgentConnectionAsync user conn'' confId $ XInfo p void $ withStore' $ \db -> resetMemberContactFields db ct' XGrpLinkInv glInv -> do @@ -566,7 +567,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart) -- [incognito] send saved profile incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId) - let profileToSend = userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile) + profileToSend <- presentUserBadge' incognitoProfile user $ userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile) allowAgentConnectionAsync user conn'' confId $ XInfo profileToSend toView $ CEvtBusinessLinkConnecting user gInfo host ct _ -> messageError "CONF for existing contact must have x.grp.mem.info or x.info" @@ -798,7 +799,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = (gInfo', m') <- withStore $ \db -> updatePreparedUserAndHostMembersInvited db cxt user gInfo m glInv -- [incognito] send saved profile incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId) - let profileToSend = userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile) + profileToSend <- presentUserBadge' incognitoProfile user $ userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile) allowAgentConnectionAsync user conn' confId $ XInfo profileToSend toView $ CEvtGroupLinkConnecting user gInfo' m' | otherwise -> messageError "x.grp.link.inv: publicGroupId mismatch" @@ -813,7 +814,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = | sameMemberId memId m -> do let GroupMember {memberId = membershipMemId} = membership allowSimplexLinks = groupFeatureUserAllowed SGFSimplexLinks gInfo - membershipProfile = redactedMemberProfile allowSimplexLinks $ fromLocalProfile $ memberProfile membership + membershipProfile <- presentUserBadge' (incognitoMembershipProfile gInfo) user $ redactedMemberProfile allowSimplexLinks $ fromLocalProfile $ memberProfile membership -- TODO update member profile -- [async agent commands] no continuation needed, but command should be asynchronous for stability allowAgentConnectionAsync user conn' confId $ XGrpMemInfo membershipMemId membershipProfile @@ -921,7 +922,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = where sendXGrpLinkMem gInfo'' = do let incognitoProfile = ExistingIncognito <$> incognitoMembershipProfile gInfo'' - profileToSend = userProfileInGroup user gInfo (fromIncognitoProfile <$> incognitoProfile) + profileToSend <- presentUserBadge' incognitoProfile user $ userProfileInGroup user gInfo (fromIncognitoProfile <$> incognitoProfile) void $ sendDirectMemberMessage conn (XGrpLinkMem profileToSend) groupId _ -> do unless (memberPending m) $ withStore' $ \db -> updateGroupMemberStatus db userId m GSMemConnected @@ -3085,8 +3086,8 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = pure toMember subMode <- chatReadVar subscriptionMode -- [incognito] send membership incognito profile, create direct connection as incognito - let membershipProfile = redactedMemberProfile allowSimplexLinks $ fromLocalProfile $ memberProfile membership - allowSimplexLinks = groupFeatureUserAllowed SGFSimplexLinks gInfo + let allowSimplexLinks = groupFeatureUserAllowed SGFSimplexLinks gInfo + membershipProfile <- presentUserBadge' (incognitoMembershipProfile gInfo) user $ redactedMemberProfile allowSimplexLinks $ fromLocalProfile $ memberProfile membership dm <- encodeConnInfo $ XGrpMemInfo membershipMemId membershipProfile -- [async agent commands] no continuation needed, but commands should be asynchronous for stability groupConnIds <- joinAgentConnectionAsync user Nothing (chatHasNtfs chatSettings) groupConnReq dm subMode diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs index 07db856847..8430599a70 100644 --- a/src/Simplex/Chat/Store/Direct.hs +++ b/src/Simplex/Chat/Store/Direct.hs @@ -943,8 +943,9 @@ getContact_ db cxt user@User {userId} contactId deleted = do (userId, contactId, BI deleted) getUserByContactRequestId :: DB.Connection -> Int64 -> ExceptT StoreError IO User -getUserByContactRequestId db contactRequestId = - ExceptT . firstRow toUser (SEUserNotFoundByContactRequestId contactRequestId) $ +getUserByContactRequestId db contactRequestId = do + now <- liftIO getCurrentTime + ExceptT . firstRow (toUser now) (SEUserNotFoundByContactRequestId contactRequestId) $ DB.query db (userQuery <> " JOIN contact_requests cr ON cr.user_id = u.user_id WHERE cr.contact_request_id = ?") (Only contactRequestId) getContactConnections :: DB.Connection -> StoreCxt -> UserId -> Contact -> IO [Connection] diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index 07b012835c..53d2e8ec15 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -164,7 +164,7 @@ createUserRecordAt db (AgentUserId auId) Profile {displayName, fullName, shortDe (profileId, displayName, userId, BI True, currentTs, currentTs, currentTs) contactId <- insertedRowId db DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?" (contactId, userId) - pure $ toUser $ (userId, auId, contactId, profileId, BI activeUser, order) :. (displayName, fullName, shortDescr, image, Nothing, peerType, userPreferences) :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, Nothing, Nothing, Nothing, Nothing, BI userChatRelay) + pure $ toUser currentTs $ (userId, auId, contactId, profileId, BI activeUser, order) :. (displayName, fullName, shortDescr, image, Nothing, peerType, userPreferences) :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, Nothing, Nothing, Nothing, Nothing, BI userChatRelay) :. localBadgeToRow Nothing -- TODO [mentions] getUsersInfo :: DB.Connection -> IO [UserInfo] @@ -198,8 +198,9 @@ getUsersInfo db = getUsers db >>= mapM getUserInfo pure UserInfo {user, unreadCount = fromMaybe 0 ctCount + fromMaybe 0 gCount} getUsers :: DB.Connection -> IO [User] -getUsers db = - map toUser <$> DB.query_ db userQuery +getUsers db = do + now <- getCurrentTime + map (toUser now) <$> DB.query_ db userQuery setActiveUser :: DB.Connection -> User -> IO User setActiveUser db user@User {userId} = do @@ -216,13 +217,15 @@ getNextActiveOrder db = do else pure $ order + 1 getUser :: DB.Connection -> UserId -> ExceptT StoreError IO User -getUser db userId = - ExceptT . firstRow toUser (SEUserNotFound userId) $ +getUser db userId = do + now <- liftIO getCurrentTime + ExceptT . firstRow (toUser now) (SEUserNotFound userId) $ DB.query db (userQuery <> " WHERE u.user_id = ?") (Only userId) getRelayUser :: DB.Connection -> ExceptT StoreError IO User -getRelayUser db = - ExceptT . firstRow toUser SERelayUserNotFound $ +getRelayUser db = do + now <- liftIO getCurrentTime + ExceptT . firstRow (toUser now) SERelayUserNotFound $ DB.query_ db (userQuery <> " WHERE u.is_user_chat_relay = 1") getUserIdByName :: DB.Connection -> UserName -> ExceptT StoreError IO Int64 @@ -231,38 +234,45 @@ getUserIdByName db uName = DB.query db "SELECT user_id FROM users WHERE local_display_name = ?" (Only uName) getUserByAConnId :: DB.Connection -> AgentConnId -> IO (Maybe User) -getUserByAConnId db agentConnId = - maybeFirstRow toUser $ +getUserByAConnId db agentConnId = do + now <- getCurrentTime + maybeFirstRow (toUser now) $ DB.query db (userQuery <> " JOIN connections c ON c.user_id = u.user_id WHERE c.agent_conn_id = ?") (Only agentConnId) getUserByASndFileId :: DB.Connection -> AgentSndFileId -> IO (Maybe User) -getUserByASndFileId db aSndFileId = - maybeFirstRow toUser $ +getUserByASndFileId db aSndFileId = do + now <- getCurrentTime + maybeFirstRow (toUser now) $ DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id WHERE f.agent_snd_file_id = ?") (Only aSndFileId) getUserByARcvFileId :: DB.Connection -> AgentRcvFileId -> IO (Maybe User) -getUserByARcvFileId db aRcvFileId = - maybeFirstRow toUser $ +getUserByARcvFileId db aRcvFileId = do + now <- getCurrentTime + maybeFirstRow (toUser now) $ DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id JOIN rcv_files r ON r.file_id = f.file_id WHERE r.agent_rcv_file_id = ?") (Only aRcvFileId) getUserByContactId :: DB.Connection -> ContactId -> ExceptT StoreError IO User -getUserByContactId db contactId = - ExceptT . firstRow toUser (SEUserNotFoundByContactId contactId) $ +getUserByContactId db contactId = do + now <- liftIO getCurrentTime + ExceptT . firstRow (toUser now) (SEUserNotFoundByContactId contactId) $ DB.query db (userQuery <> " JOIN contacts ct ON ct.user_id = u.user_id WHERE ct.contact_id = ? AND ct.deleted = 0") (Only contactId) getUserByGroupId :: DB.Connection -> GroupId -> ExceptT StoreError IO User -getUserByGroupId db groupId = - ExceptT . firstRow toUser (SEUserNotFoundByGroupId groupId) $ +getUserByGroupId db groupId = do + now <- liftIO getCurrentTime + ExceptT . firstRow (toUser now) (SEUserNotFoundByGroupId groupId) $ DB.query db (userQuery <> " JOIN groups g ON g.user_id = u.user_id WHERE g.group_id = ?") (Only groupId) getUserByNoteFolderId :: DB.Connection -> NoteFolderId -> ExceptT StoreError IO User -getUserByNoteFolderId db contactId = - ExceptT . firstRow toUser (SEUserNotFoundByContactId contactId) $ +getUserByNoteFolderId db contactId = do + now <- liftIO getCurrentTime + ExceptT . firstRow (toUser now) (SEUserNotFoundByContactId contactId) $ DB.query db (userQuery <> " JOIN note_folders nf ON nf.user_id = u.user_id WHERE nf.note_folder_id = ?") (Only contactId) getUserByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO User -getUserByFileId db fileId = - ExceptT . firstRow toUser (SEUserNotFoundByFileId fileId) $ +getUserByFileId db fileId = do + now <- liftIO getCurrentTime + ExceptT . firstRow (toUser now) (SEUserNotFoundByFileId fileId) $ DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id WHERE f.file_id = ?") (Only fileId) getUserFileInfo :: DB.Connection -> User -> IO [CIFileInfo] @@ -350,7 +360,8 @@ updateUserProfileFields_' db userId profileId Profile {displayName, fullName, sh |] ((displayName, fullName, shortDescr, image, contactLink, preferences, peerType, updatedAt) :. (userId, profileId)) --- store the user's own badge credential; touches only the badge columns +-- store the user's own badge credential; touches only the badge columns. +-- bumps user_member_profile_updated_at so groups receive the updated profile (with the badge) on the next message. setUserBadge :: DB.Connection -> User -> Maybe LocalBadge -> IO User setUserBadge db user@User {userId, profile = p@LocalProfile {profileId}} localBadge = do ts <- getCurrentTime @@ -362,7 +373,8 @@ setUserBadge db user@User {userId, profile = p@LocalProfile {profileId}} localBa WHERE user_id = ? AND contact_profile_id = ? |] (localBadgeToRow localBadge :. (ts, userId, profileId)) - pure (user :: User) {profile = p {localBadge}} + DB.execute db "UPDATE users SET user_member_profile_updated_at = ? WHERE user_id = ?" (ts, userId) + pure (user :: User) {profile = p {localBadge}, userMemberProfileUpdatedAt = Just ts} setUserProfileContactLink :: DB.Connection -> User -> Maybe UserContactLink -> IO User setUserProfileContactLink db user@User {userId, profile = p@LocalProfile {profileId}} ucl_ = do diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index 7bf65f136e..98f8a81870 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -543,17 +543,18 @@ userQuery :: Query userQuery = [sql| SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.active_order, u.local_display_name, ucp.full_name, ucp.short_descr, ucp.image, ucp.contact_link, ucp.chat_peer_type, ucp.preferences, - u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.ui_themes, u.is_user_chat_relay + u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.ui_themes, u.is_user_chat_relay, + ucp.badge_proof, ucp.badge_pres_header, ucp.badge_expiry, ucp.badge_type, ucp.badge_verified, ucp.badge_extra, ucp.badge_master_key, ucp.badge_signature FROM users u JOIN contacts uct ON uct.contact_id = u.contact_id JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id |] -toUser :: (UserId, UserId, ContactId, ProfileId, BoolInt, Int64) :. (ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences) :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString, Maybe B64UrlByteString, Maybe UTCTime, Maybe UIThemeEntityOverrides, BoolInt) -> User -toUser ((userId, auId, userContactId, profileId, BI activeUser, activeOrder) :. (displayName, fullName, shortDescr, image, contactLink, peerType, userPreferences) :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, viewPwdHash_, viewPwdSalt_, userMemberProfileUpdatedAt, uiThemes, BI userChatRelay)) = +toUser :: UTCTime -> (UserId, UserId, ContactId, ProfileId, BoolInt, Int64) :. (ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences) :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString, Maybe B64UrlByteString, Maybe UTCTime, Maybe UIThemeEntityOverrides, BoolInt) :. BadgeRow -> User +toUser now ((userId, auId, userContactId, profileId, BI activeUser, activeOrder) :. (displayName, fullName, shortDescr, image, contactLink, peerType, userPreferences) :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, viewPwdHash_, viewPwdSalt_, userMemberProfileUpdatedAt, uiThemes, BI userChatRelay) :. badgeRow) = User {userId, agentUserId = AgentUserId auId, userContactId, localDisplayName = displayName, profile, activeUser, activeOrder, fullPreferences, showNtfs, sendRcptsContacts, sendRcptsSmallGroups, autoAcceptMemberContacts = BoolDef autoAcceptMemberContacts, viewPwdHash, userMemberProfileUpdatedAt, uiThemes, userChatRelay = BoolDef userChatRelay} where - profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, localBadge = Nothing, preferences = userPreferences, localAlias = ""} + profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, localBadge = rowToBadge now badgeRow, preferences = userPreferences, localAlias = ""} fullPreferences = fullPreferences' userPreferences viewPwdHash = UserPwdHash <$> viewPwdHash_ <*> viewPwdSalt_ diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index e0023e68ed..f8b258d49e 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -1799,10 +1799,11 @@ viewCustomData :: Maybe CustomData -> [StyledString] viewCustomData = maybe [] (\(CustomData v) -> ["custom data: " <> viewJSON (J.Object v)]) viewGroupMemberInfo :: GroupInfo -> GroupMember -> Maybe ConnectionStats -> [StyledString] -viewGroupMemberInfo GroupInfo {groupId} m@GroupMember {groupMemberId, memberProfile = LocalProfile {localAlias, contactLink}, activeConn} stats = +viewGroupMemberInfo GroupInfo {groupId} m@GroupMember {groupMemberId, memberProfile = LocalProfile {localAlias, contactLink, localBadge}, activeConn} stats = [ "group ID: " <> sShow groupId, "member ID: " <> sShow groupMemberId ] + <> viewContactBadge localBadge <> maybe ["member not connected"] viewConnectionStats stats <> maybe [] (\l -> ["contact address: " <> (plain . strEncode) (simplexChatContact' l)]) contactLink <> ["alias: " <> plain localAlias | localAlias /= ""] diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index d3277aff0c..c9218672e7 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -18,14 +19,16 @@ import Control.Monad.Except import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import qualified Data.Text as T -import Simplex.Chat.Badges (BadgeInfo (..), BadgePurchase (..), BadgeRequest (..), BadgeType (..), generateMasterKey, issueBadge, verifyPayment) +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Simplex.Chat.Badges (Badge, BadgeCrypto (..), BadgeInfo (..), BadgePurchase (..), BadgeRequest (..), BadgeType (..), generateMasterKey, issueBadge, verifyPayment) import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatHooks (..), defaultChatHooks, mkStoreCxt) import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) import Simplex.Chat.Protocol (currentChatVersion) import Simplex.Chat.Store.Shared (createContact) import Simplex.Chat.Types (ConnStatus (..), Profile (..), GroupRejectionReason (..)) import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Crypto.BBS (bbsKeyGen) +import Simplex.Messaging.Crypto.BBS (BBSPublicKey, BBSSecretKey, bbsKeyGen) import Simplex.Chat.Types.Shared (GroupMemberRole (..)) import Simplex.Chat.Types.UITheme import Simplex.Messaging.Agent.Env.SQLite @@ -44,6 +47,10 @@ chatProfileTests = do it "update user profile with image" testUpdateProfileImage it "use multiword profile names" testMultiWordProfileNames it "present supporter badge to contacts" testUserBadgeBroadcast + it "supporter badge sent to contact connecting after attach" testUserBadgeOnConnect + it "supporter badge sent to member joining via group link" testUserBadgeGroupLink + it "expired supporter badge shows as expired" testUserBadgeExpired + it "incognito connection does not carry supporter badge" testUserBadgeIncognito describe "user contact link" $ do it "create and connect via contact link" testUserContactLink it "retry connecting via contact link" testRetryConnectingViaContactLink @@ -189,6 +196,22 @@ testUpdateProfile = bob <## "use @cat to send messages" ] +-- issue a supporter badge credential with the given expiry (test issuer) +issueTestBadge :: BBSSecretKey -> BBSPublicKey -> Maybe UTCTime -> IO (Badge 'BCCredential) +issueTestBadge sk pk badgeExpiry = do + drg <- C.newRandom + mk <- generateMasterKey drg + let info = BadgeInfo {badgeType = BTSupporter, badgeExpiry, badgeExtra = ""} + Just vreq <- verifyPayment (BPRedeemCode "TEST") BadgeRequest {masterKey = mk, badgeInfo = info} + Right cred <- issueBadge sk pk vreq + pure cred + +-- the same single-line JSON `simplex-chat badge sign` prints, pasted into the app +addTestBadge :: HasCallStack => TestCC -> Badge 'BCCredential -> IO () +addTestBadge cc cred = do + cc ##> ("/badge add " <> T.unpack (encodeJSON cred)) + cc <## "ok" + testUserBadgeBroadcast :: HasCallStack => TestParams -> IO () testUserBadgeBroadcast ps = do Right (sk, pk) <- bbsKeyGen @@ -196,10 +219,7 @@ testUserBadgeBroadcast ps = do where test sk pk alice bob = do connectUsers alice bob - cred <- issueSupporterBadge sk pk - -- the same single-line JSON `simplex-chat badge sign` prints, pasted into the app - alice ##> ("/badge add " <> T.unpack (encodeJSON cred)) - alice <## "ok" + addTestBadge alice =<< issueTestBadge sk pk Nothing -- own badge is shown (add succeeded) alice ##> "/p" alice <## "user profile: alice (Alice, * supporter)" @@ -207,13 +227,120 @@ testUserBadgeBroadcast ps = do -- the badge XInfo is delivered in order before this message, so the contact has stored it alice #> "@bob hi" bob <# "alice *> hi" - issueSupporterBadge sk pk = do - drg <- C.newRandom - mk <- generateMasterKey drg - let info = BadgeInfo {badgeType = BTSupporter, badgeExpiry = Nothing, badgeExtra = ""} - Just vreq <- verifyPayment (BPRedeemCode "TEST") BadgeRequest {masterKey = mk, badgeInfo = info} - Right cred <- issueBadge sk pk vreq - pure cred + +testUserBadgeOnConnect :: HasCallStack => TestParams -> IO () +testUserBadgeOnConnect ps = do + Right (sk, pk) <- bbsKeyGen + testChatCfg2 (testCfg {badgePublicKey = pk}) aliceProfile bobProfile (test sk pk) ps + where + test sk pk alice bob = do + addTestBadge alice =<< issueTestBadge sk pk Nothing + -- a contact connecting after the badge is attached receives it in the connection handshake + alice ##> "/c" + inv <- getInvitation alice + bob ##> ("/c " <> inv) + bob <## "confirmation sent!" + concurrently_ + (bob <## "alice (Alice, * supporter): contact is connected") + (alice <## "bob (Bob): contact is connected") + bob ##> "/i alice" + bob <## "contact ID: 2" + bob <## "supporter badge - active" + bob <## "no expiry" + bob <## "receiving messages via: localhost" + bob <## "sending messages via: localhost" + bob <## "you've shared main profile with this contact" + bob <## "connection not verified, use /code command to see security code" + bob <## "quantum resistant end-to-end encryption" + bob <## currentChatVRangeInfo + +testUserBadgeGroupLink :: HasCallStack => TestParams -> IO () +testUserBadgeGroupLink ps = do + Right (sk, pk) <- bbsKeyGen + testChatCfg2 (testCfg {badgePublicKey = pk}) aliceProfile bobProfile (test sk pk) ps + where + test sk pk alice bob = do + addTestBadge alice =<< issueTestBadge sk pk Nothing + alice ##> "/g team" + alice <## "group #team is created" + alice <## "to add members use /a team or /create link #team" + alice ##> "/create link #team" + gLink <- getGroupLink alice "team" GRMember True + bob ##> ("/c " <> gLink) + bob <## "connection request sent!" + alice <## "bob (Bob): accepting request to join group #team..." + concurrentlyN_ + [ alice <## "#team: bob joined the group", + do + bob <## "#team: joining the group..." + bob <## "#team: you joined the group" + ] + -- the host's profile (x.grp.link.mem) is sent over the same connection as group messages, + -- so receiving a message guarantees the badge arrived + alice #> "#team hello" + bob <# "#team alice> hello" + -- no prior contact: the host's badge arrives via the group link handshake + bob ##> "/i #team alice" + bob <## "group ID: 1" + bob <##. "member ID: " + bob <## "supporter badge - active" + bob <## "no expiry" + bob <## "receiving messages via: localhost" + bob <## "sending messages via: localhost" + bob <## "connection not verified, use /code command to see security code" + bob <## currentChatVRangeInfo + +testUserBadgeExpired :: HasCallStack => TestParams -> IO () +testUserBadgeExpired ps = do + Right (sk, pk) <- bbsKeyGen + testChatCfg2 (testCfg {badgePublicKey = pk}) aliceProfile bobProfile (test sk pk) ps + where + test sk pk alice bob = do + addTestBadge alice =<< issueTestBadge sk pk (Just pastDate) + -- expired badge: no star + alice ##> "/p" + alice <## "user profile: alice (Alice)" + alice <## "use /p [] to change it" + connectUsers alice bob + bob ##> "/i alice" + bob <## "contact ID: 2" + bob <## "supporter badge - expired" + bob <## "expires 2020-01-01" + bob <## "receiving messages via: localhost" + bob <## "sending messages via: localhost" + bob <## "you've shared main profile with this contact" + bob <## "connection not verified, use /code command to see security code" + bob <## "quantum resistant end-to-end encryption" + bob <## currentChatVRangeInfo + pastDate = posixSecondsToUTCTime 1577836800 -- 2020-01-01 + +testUserBadgeIncognito :: HasCallStack => TestParams -> IO () +testUserBadgeIncognito ps = do + Right (sk, pk) <- bbsKeyGen + testChatCfg2 (testCfg {badgePublicKey = pk}) aliceProfile bobProfile (test sk pk) ps + where + test sk pk alice bob = do + addTestBadge alice =<< issueTestBadge sk pk Nothing + -- an incognito identity must not carry the badge + bob ##> "/connect" + inv <- getInvitation bob + alice ##> ("/connect incognito " <> inv) + alice <## "confirmation sent!" + aliceIncognito <- getTermLine alice + concurrentlyN_ + [ bob <## (aliceIncognito <> ": contact is connected"), + do + alice <## ("bob (Bob): contact is connected, your incognito profile for this contact is " <> aliceIncognito) + alice <## "use /i bob to print out this incognito profile again" + ] + bob ##> ("/i " <> aliceIncognito) + bob <## "contact ID: 2" + bob <## "receiving messages via: localhost" + bob <## "sending messages via: localhost" + bob <## "you've shared main profile with this contact" + bob <## "connection not verified, use /code command to see security code" + bob <## "quantum resistant end-to-end encryption" + bob <## currentChatVRangeInfo testUpdateProfileImage :: HasCallStack => TestParams -> IO () testUpdateProfileImage =