From fb68bc2e8ace4a6c38b55875fd57347866106da2 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Tue, 9 Jun 2026 15:43:48 +0000 Subject: [PATCH] add badge to profile, test --- src/Simplex/Chat/Badges.hs | 11 ++++--- src/Simplex/Chat/Library/Commands.hs | 21 +++++++++++++ src/Simplex/Chat/Library/Internal.hs | 12 ++++++++ src/Simplex/Chat/Library/Subscriber.hs | 4 +-- src/Simplex/Chat/Store/ContactRequest.hs | 2 +- src/Simplex/Chat/Store/Groups.hs | 2 +- src/Simplex/Chat/Store/Profiles.hs | 38 ++++++++++++++++++++---- src/Simplex/Chat/Store/Shared.hs | 2 +- src/Simplex/Chat/Types.hs | 9 ++++++ tests/ChatClient.hs | 9 +++++- tests/ChatTests/Profiles.hs | 37 +++++++++++++++++++++-- 11 files changed, 128 insertions(+), 19 deletions(-) diff --git a/src/Simplex/Chat/Badges.hs b/src/Simplex/Chat/Badges.hs index a060ec6b3b..e8437574bb 100644 --- a/src/Simplex/Chat/Badges.hs +++ b/src/Simplex/Chat/Badges.hs @@ -35,11 +35,11 @@ module Simplex.Chat.Badges issueBadge, verifyCredential, generateBadgeProof, + badgeProof, verifyBadge, verifyBadge_, mkBadgeStatus, localBadgeVerified, - srvBadgePublicKey, BadgeRow, badgeToRow, localBadgeToRow, @@ -269,6 +269,10 @@ generateBadgeProof :: BBSPublicKey -> Badge 'BCCredential -> BBSPresHeader -> IO generateBadgeProof pk (BadgeCredential masterKey signature badgeInfo) ph = fmap (\p -> BadgeProof ph p badgeInfo) <$> bbsProofGen pk signature bbsBadgeHeader ph bbsBadgeDisclosedIndexes (badgeMessages masterKey badgeInfo) +-- application-level proof generation with a semantic presentation header +badgeProof :: BBSPublicKey -> Badge 'BCCredential -> BadgePresHeader -> IO (Either String (Badge 'BCProof)) +badgeProof pk cred ph = generateBadgeProof pk cred (BBSPresHeader $ badgePresHeaderBytes ph) + -- Recipient-side: verify a badge proof verifyBadge :: BBSPublicKey -> Badge 'BCProof -> IO Bool @@ -280,11 +284,6 @@ verifyBadge pk (BadgeProof ph@(BBSPresHeader phBytes) proof badgeInfo) verifyBadge_ :: BBSPublicKey -> Maybe (Badge 'BCProof) -> IO Bool verifyBadge_ = maybe (pure False) . verifyBadge --- Server public key (test key - replace with real key when badge service is deployed) - -srvBadgePublicKey :: BBSPublicKey -srvBadgePublicKey = BBSPublicKey "" -- TODO generate real keypair - -- DB instance FromField BadgeType where fromField = fromTextField_ textDecode diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 0b2bf80186..a2593c0db5 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -55,6 +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.Call import Simplex.Chat.Controller import Simplex.Chat.Delivery (DeliveryJobScope (..), DeliveryJobSpec (..), DeliveryWorkerScope (..)) @@ -4641,6 +4642,26 @@ createContactsSndFeatureItems user cts = CUPContact {preference} -> preference CUPUser {preference} -> preference +-- 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 + 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 (LocalBadge cred BSActive)) + asks currentUser >>= atomically . (`writeTVar` Just user') + cxt <- asks $ mkStoreCxt . config + contacts <- withFastStore' $ \db -> getUserContacts db cxt user' + withChatLock "addUserBadge" $ forM_ contacts $ \ct -> + case contactSendConn_ ct of + Right conn + | not (connIncognito conn) -> do + let ct' = updateMergedPreferences user' ct + p <- presentUserBadge user' $ userProfileDirect user' Nothing (Just ct') False + void (sendDirectContactMessage user' ct' (XInfo p)) `catchAllErrors` eToView + _ -> pure () + assertDirectAllowed :: User -> MsgDirection -> Contact -> CMEventTag e -> CM () assertDirectAllowed user dir ct event = unless (allowedChatEvent || anyDirectOrUsed ct) . unlessM directMessagesAllowed $ diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index d448eabf5a..f5ff24b5c2 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -53,6 +53,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Time (addUTCTime) import Data.Time.Calendar (fromGregorian) import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds, secondsToDiffTime) +import Simplex.Chat.Badges (Badge (..), BadgePresHeader (..), LocalBadge (..), badgeProof) import Simplex.Chat.Call import Simplex.Chat.Controller import Simplex.Chat.Files @@ -1895,6 +1896,17 @@ sendDirectContactMessages' user ct events = do forM_ pqEnc_ $ \pqEnc' -> void $ createContactPQSndItem user ct conn pqEnc' pure sndMsgs' +-- present the user's own badge on an outgoing profile: a fresh, single-use proof from the stored credential. +-- only own credentials present (peers carry proofs, which are not re-presented). callers must not present on incognito sends. +presentUserBadge :: User -> Profile -> CM Profile +presentUserBadge User {profile = LocalProfile {localBadge}} p = case localBadge of + Just (LocalBadge cred@BadgeCredential {} _) -> do + key <- asks $ badgePublicKey . config + liftIO (badgeProof key cred PHTest) >>= \case + Right proof -> pure p {badge = Just proof} + Left e -> p <$ logError ("presentUserBadge: proof generation failed: " <> T.pack e) + _ -> pure p + sendDirectContactMessage :: MsgEncodingI e => User -> Contact -> ChatMsgEvent e -> CM (SndMessage, Int64) sendDirectContactMessage user ct chatMsgEvent = do conn@Connection {connId} <- liftEither $ contactSendConn_ ct diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index be41dad654..b63d61c6a9 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -2550,7 +2550,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = processContactProfileUpdate :: Contact -> Profile -> Bool -> CM Contact processContactProfileUpdate c@Contact {profile = lp} p' createItems - | p /= p' = do + | not (sameProfileContent p p') = do c' <- withStore $ \db -> if userTTL == rcvTTL then updateContactProfile db cxt user c p' @@ -2667,7 +2667,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = processMemberProfileUpdate :: GroupInfo -> GroupMember -> Profile -> Maybe (RcvMessage, UTCTime) -> CM GroupMember processMemberProfileUpdate gInfo m@GroupMember {memberProfile = p, memberContactId} p' msgTs_ - | redactedMemberProfile allowSimplexLinks (fromLocalProfile p) /= redactedMemberProfile allowSimplexLinks p' = do + | not (sameProfileContent (redactedMemberProfile allowSimplexLinks (fromLocalProfile p)) (redactedMemberProfile allowSimplexLinks p')) = do updateBusinessChatProfile gInfo case memberContactId of Nothing -> do diff --git a/src/Simplex/Chat/Store/ContactRequest.hs b/src/Simplex/Chat/Store/ContactRequest.hs index adac1b455f..8538b60592 100644 --- a/src/Simplex/Chat/Store/ContactRequest.hs +++ b/src/Simplex/Chat/Store/ContactRequest.hs @@ -24,7 +24,7 @@ import Control.Monad.IO.Class import Crypto.Random (ChaChaDRG) import Data.Int (Int64) import Data.Time.Clock (getCurrentTime) -import Simplex.Chat.Badges (badgeToRow, srvBadgePublicKey, verifyBadge_) +import Simplex.Chat.Badges (badgeToRow, verifyBadge_) import Simplex.Chat.Protocol (MsgContent, businessChatsVersion) import Simplex.Chat.Store.Direct import Simplex.Chat.Store.Groups diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index e4ef35bc8f..f6f0366a34 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -196,7 +196,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, getCurrentTime) import Data.Text.Encoding (encodeUtf8) -import Simplex.Chat.Badges (BadgeRow, badgeToRow, srvBadgePublicKey, verifyBadge_) +import Simplex.Chat.Badges (BadgeRow, badgeToRow, verifyBadge_) import Simplex.Chat.Messages import Simplex.Chat.Operators import Simplex.Chat.Protocol hiding (Binary) diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index bbb9406251..07b012835c 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/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 @@ -310,9 +312,9 @@ updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO U updateUserProfile db user p' | displayName == newName = liftIO $ do currentTs <- getCurrentTime - updateContactProfile_' db userId profileId p' False currentTs + updateUserProfileFields_' db userId profileId p' currentTs userMemberProfileUpdatedAt' <- updateUserMemberProfileUpdatedAt_ currentTs - pure user {profile = toLocalProfile profileId p' localAlias currentTs False, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'} + pure user {profile = (toLocalProfile profileId p' localAlias currentTs False) {localBadge}, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'} | otherwise = checkConstraint SEDuplicateName . liftIO $ do currentTs <- getCurrentTime @@ -322,9 +324,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' False currentTs + updateUserProfileFields_' db userId profileId p' currentTs updateContactLDN_ db user userContactId localDisplayName newName currentTs - pure user {localDisplayName = newName, profile = toLocalProfile profileId p' localAlias currentTs False, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'} + pure user {localDisplayName = newName, profile = (toLocalProfile profileId p' localAlias currentTs False) {localBadge}, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'} where updateUserMemberProfileUpdatedAt_ currentTs | userMemberProfileChanged = do @@ -332,10 +334,36 @@ 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' 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 +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 = ?, updated_at = ? + WHERE user_id = ? AND contact_profile_id = ? + |] + (localBadgeToRow localBadge :. (ts, userId, profileId)) + pure (user :: User) {profile = p {localBadge}} + setUserProfileContactLink :: DB.Connection -> User -> Maybe UserContactLink -> IO User setUserProfileContactLink db user@User {userId, profile = p@LocalProfile {profileId}} ucl_ = do ts <- getCurrentTime diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index bbc8182330..7bf65f136e 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -32,7 +32,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime (..), getCurrentTime) import Data.Type.Equality -import Simplex.Chat.Badges (BadgeRow, badgeToRow, rowToBadge, srvBadgePublicKey, verifyBadge_) +import Simplex.Chat.Badges (BadgeRow, badgeToRow, rowToBadge, verifyBadge_) import Simplex.Chat.Messages import Simplex.Chat.Remote.Types import Simplex.Chat.Types diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index a905effb4e..a3ed1d7782 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -730,6 +730,15 @@ profilesMatch LocalProfile {displayName = n2, fullName = fn2, image = i2} = n1 == n2 && fn1 == fn2 && i1 == i2 +-- equal for profile-update detection: badge proofs are re-generated for every presentation, +-- so compare badges by disclosed info (not proof bytes) - a re-presentation of the same badge is a no-op +sameProfileContent :: Profile -> Profile -> Bool +sameProfileContent p@Profile {badge = b} p'@Profile {badge = b'} = + p {badge = Nothing} == p' {badge = Nothing} && (proofInfo <$> b) == (proofInfo <$> b') + where + proofInfo :: Badge 'BCProof -> BadgeInfo + proofInfo (BadgeProof _ _ info) = info + data IncognitoProfile = NewIncognito Profile | ExistingIncognito LocalProfile fromIncognitoProfile :: IncognitoProfile -> Profile diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 279a09e718..bb68baaeec 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -27,7 +27,7 @@ import Data.Maybe (isNothing) import qualified Data.Text as T import Network.Socket import Simplex.Chat -import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), defaultSimpleNetCfg) +import Simplex.Chat.Controller (CM, ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), defaultSimpleNetCfg) import Simplex.Chat.Core import Simplex.Chat.Library.Commands import Simplex.Chat.Options @@ -454,6 +454,13 @@ userName :: TestCC -> IO [Char] userName (TestCC ChatController {currentUser} _ _ _ _ _) = maybe "no current user" (\User {localDisplayName} -> T.unpack localDisplayName) <$> readTVarIO currentUser +-- run an internal CM action against a test client's controller and active user (for functions with no command surface) +runCCUser :: HasCallStack => TestCC -> (User -> CM a) -> IO a +runCCUser TestCC {chatController = cc@ChatController {currentUser}} action = + readTVarIO currentUser >>= \case + Just user -> runReaderT (runExceptT (action user)) cc >>= either (error . show) pure + Nothing -> error "withCCUser: no current user" + testChat :: HasCallStack => Profile -> (HasCallStack => TestCC -> IO ()) -> TestParams -> IO () testChat = testChatCfgOpts testCfg testOpts diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index c22cf39b51..83e5629c1b 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -17,12 +17,19 @@ import Control.Monad import Control.Monad.Except import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B +import Data.Maybe (listToMaybe) import qualified Data.Text as T -import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatHooks (..), defaultChatHooks, mkStoreCxt) +import Simplex.Chat.Badges (BadgeInfo (..), BadgePurchase (..), BadgeRequest (..), BadgeStatus (..), BadgeType (..), generateMasterKey, issueBadge, localBadgeStatus, verifyPayment) +import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatHooks (..), defaultChatHooks, mkStoreCxt, withFastStore') +import Simplex.Chat.Library.Commands (addUserBadge) +import Simplex.Chat.Library.Internal (chatStoreCxt) import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) import Simplex.Chat.Protocol (currentChatVersion) +import Simplex.Chat.Store.Direct (getUserContacts) import Simplex.Chat.Store.Shared (createContact) -import Simplex.Chat.Types (ConnStatus (..), Profile (..), GroupRejectionReason (..)) +import Simplex.Chat.Types (ConnStatus (..), Contact (Contact, localDisplayName, profile), LocalProfile (LocalProfile, localBadge), Profile (..), GroupRejectionReason (..)) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.BBS (bbsKeyGen) import Simplex.Chat.Types.Shared (GroupMemberRole (..)) import Simplex.Chat.Types.UITheme import Simplex.Messaging.Agent.Env.SQLite @@ -40,6 +47,7 @@ chatProfileTests = do it "update user profile and notify contacts" testUpdateProfile it "update user profile with image" testUpdateProfileImage it "use multiword profile names" testMultiWordProfileNames + it "present supporter badge to contacts" testUserBadgeBroadcast describe "user contact link" $ do it "create and connect via contact link" testUserContactLink it "retry connecting via contact link" testRetryConnectingViaContactLink @@ -185,6 +193,31 @@ testUpdateProfile = bob <## "use @cat to send messages" ] +testUserBadgeBroadcast :: HasCallStack => TestParams -> IO () +testUserBadgeBroadcast ps = do + Right (sk, pk) <- bbsKeyGen + testChatCfg2 (testCfg {badgePublicKey = pk}) aliceProfile bobProfile (test sk pk) ps + where + test sk pk alice bob = do + connectUsers alice bob + cred <- issueSupporterBadge sk pk + runCCUser alice (`addUserBadge` cred) + -- the badge XInfo is delivered in order before this message, so by the time bob shows it the badge is stored + alice #> "@bob hi" + bob <# "alice> hi" + contactBadgeStatus bob "alice" `shouldReturn` Just BSActive + 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 + contactBadgeStatus cc name = runCCUser cc $ \user -> do + cxt <- chatStoreCxt + cts <- withFastStore' $ \db -> getUserContacts db cxt user + pure $ listToMaybe [localBadgeStatus lb | Contact {localDisplayName, profile = LocalProfile {localBadge = Just lb}} <- cts, localDisplayName == name] + testUpdateProfileImage :: HasCallStack => TestParams -> IO () testUpdateProfileImage = testChat2 aliceProfile bobProfile $