add badge to profile, test

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

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 $

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

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

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

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)

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

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

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

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
 

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 <message> 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 $