core: supporter badges using anonymous BBS credentials (#7040)

* core: supporter badges using anonymous BBS credentials

* badges in profiles

* badge in profiles

* process badges

* update simplexmq

* update simplexmq

* change types

* fix migration

* migration

* update simplexmq

* fix bot API, schema

* fix postgresql build

* refactor

* postgresql schema

* correctly set badges in all cases

* badges ffi

* plan, bot types

* FFI

* FFI: export badge symbols

* add extra field

* refactor badge types to GADT

* configurable badge key

* add badge to profile, test

* ui: badge images

* generate badge key and sign badge

* badge sign in CLI

* fix commands, ui

* rename badges

* Binary

* image size, migration

* update badge images, add public key

* send badges in more cases

* update UI, tests

* bot types, schema

* postgres schema

* tone down badges

* revert formula

* refactor badges

* smaller badges

* badge position

* better badge position

* simpler

* position

* move position

* update simplexmq

* show badge after name

* badge layout

* fix badge

* debug badge height

* shift badge

* fix badge in member name

* bigger badge

* badge layout

* differentiate badge colors

* more avatars for the user's profiles

* refactor

* remove color filter

* alerts

* multiple keys, old expired

* use new BBS api

* update badge keys, bot api

* presentation header

* simplify

* parser

* update iOS images

* update public keys

* query plans

* update simplexmq

* refactor badge types

* simplexmq

* bot api types

* update simplexmq - commoncrypto flag

* update simplexmq

* pass commoncrypto flag to simplexmq in nix iOS build

* ios ui

* update core library, fixes

* badge layout

* badge size

* badge gap

* remove extensions

* simplify

* share badge in more events, reverify badge if verification failed

* larger files with badges

* allow sending larger files

* simpler

* update simplexmq

* better decoder for badge keys

* update simplexmq

---------

Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
Co-authored-by: shum <github.shum@liber.li>

src/Simplex/Chat/Store/Profiles.hs

@@ -43,6 +43,7 @@ module Simplex.Chat.Store.Profiles
     updateUserGroupReceipts,
     updateUserAutoAcceptMemberContacts,
     updateUserProfile,
+    setUserBadge,
     setUserProfileContactLink,
     getUserContactProfiles,
     createUserContactLink,
@@ -97,6 +98,7 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time.Clock (UTCTime (..), getCurrentTime)
+import Simplex.Chat.Badges (LocalBadge, localBadgeToRow)
 import Simplex.Chat.Call
 import Simplex.Chat.Messages
 import Simplex.Chat.Operators
@@ -162,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]
@@ -196,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
@@ -214,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
@@ -229,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]
@@ -309,10 +321,10 @@ updateUserAutoAcceptMemberContacts db User {userId} autoAccept =
 updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO User
 updateUserProfile db user p'
   | displayName == newName = liftIO $ do
-      updateContactProfile_ db userId profileId p'
       currentTs <- getCurrentTime
+      updateUserProfileFields_' db userId profileId p' currentTs
       userMemberProfileUpdatedAt' <- updateUserMemberProfileUpdatedAt_ currentTs
-      pure user {profile, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'}
+      pure user {profile = (toLocalProfile profileId p' localAlias currentTs (Just False)) {localBadge}, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'}
   | otherwise =
       checkConstraint SEDuplicateName . liftIO $ do
         currentTs <- getCurrentTime
@@ -322,9 +334,9 @@ updateUserProfile db user p'
           db
           "INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
           (newName, newName, userId, currentTs, currentTs)
-        updateContactProfile_' db userId profileId p' currentTs
+        updateUserProfileFields_' db userId profileId p' currentTs
         updateContactLDN_ db user userContactId localDisplayName newName currentTs
-        pure user {localDisplayName = newName, profile, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'}
+        pure user {localDisplayName = newName, profile = (toLocalProfile profileId p' localAlias currentTs (Just False)) {localBadge}, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'}
   where
     updateUserMemberProfileUpdatedAt_ currentTs
       | userMemberProfileChanged = do
@@ -332,11 +344,38 @@ updateUserProfile db user p'
           pure $ Just currentTs
       | otherwise = pure userMemberProfileUpdatedAt
     userMemberProfileChanged = newName /= displayName || fn' /= fullName || d' /= shortDescr || img' /= image
-    User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, localAlias}, userMemberProfileUpdatedAt} = user
+    User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, localBadge, localAlias}, userMemberProfileUpdatedAt} = user
     Profile {displayName = newName, fullName = fn', shortDescr = d', image = img', preferences} = p'
-    profile = toLocalProfile profileId p' localAlias
     fullPreferences = fullPreferences' preferences
 
+-- own profile field update; leaves the badge columns alone (the credential is owned by setUserBadge/addUserBadge)
+updateUserProfileFields_' :: DB.Connection -> UserId -> ProfileId -> Profile -> UTCTime -> IO ()
+updateUserProfileFields_' db userId profileId Profile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType} updatedAt =
+  DB.execute
+    db
+    [sql|
+      UPDATE contact_profiles
+      SET display_name = ?, full_name = ?, short_descr = ?, image = ?, contact_link = ?, preferences = ?, chat_peer_type = ?, updated_at = ?
+      WHERE user_id = ? AND contact_profile_id = ?
+    |]
+    ((displayName, fullName, shortDescr, image, contactLink, preferences, peerType, updatedAt) :. (userId, profileId))
+
+-- 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
+  DB.execute
+    db
+    [sql|
+      UPDATE contact_profiles
+      SET badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?, badge_extra = ?, badge_master_key = ?, badge_signature = ?, badge_key_idx = ?, updated_at = ?
+      WHERE user_id = ? AND contact_profile_id = ?
+    |]
+    (localBadgeToRow localBadge :. (ts, userId, profileId))
+  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
   ts <- getCurrentTime
@@ -366,7 +405,7 @@ getUserContactProfiles db User {userId} =
       (Only userId)
   where
     toContactProfile :: (ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences) -> Profile
-    toContactProfile (displayName, fullName, shortDescr, image, contactLink, peerType, preferences) = Profile {displayName, fullName, shortDescr, image, contactLink, peerType, preferences}
+    toContactProfile (displayName, fullName, shortDescr, image, contactLink, peerType, preferences) = Profile {displayName, fullName, shortDescr, image, contactLink, peerType, preferences, badge = Nothing}
 
 createUserContactLink :: DB.Connection -> User -> ConnId -> CreatedLinkContact -> SubscriptionMode -> ExceptT StoreError IO ()
 createUserContactLink db User {userId} agentConnId (CCLink cReq shortLink) subMode =