send badges in more cases

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'

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
 

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

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]

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

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_
 

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 /= ""]

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 <message> 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 <name> 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 <name> [<bio>] 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 =