badge in profiles

src/Simplex/Chat/Badges.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -22,20 +23,33 @@ module Simplex.Chat.Badges
     generateBadgeProof,
     verifyBadge,
     mkBadgeStatus,
+    localBadgeVerified,
+    srvBadgePublicKey,
+    BadgeRow,
+    badgeToRow,
+    rowToBadge,
   ) where
 
-import Data.Aeson (FromJSON (..), ToJSON (..))
-import qualified Data.Aeson.TH as JQ
 import Control.Concurrent.STM
 import Crypto.Random (ChaChaDRG)
+import Data.Aeson (FromJSON (..), ToJSON (..))
+import qualified Data.Aeson.TH as JQ
 import Data.ByteString (ByteString)
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock (UTCTime)
+import Simplex.Messaging.Agent.Store.DB (BoolInt (..), fromTextField_)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.BBS
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple.FromField (FromField (..))
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+#else
+import Database.SQLite.Simple.FromField (FromField (..))
+import Database.SQLite.Simple.ToField (ToField (..))
+#endif
 
 -- Badge type
 
@@ -189,6 +203,36 @@ verifyBadge :: BBSPublicKey -> SupporterBadge -> IO Bool
 verifyBadge pk SupporterBadge {proof, presHeader, badgeExpiry, badgeType} =
   bbsProofVerify pk proof bbsBadgeHeader presHeader bbsBadgeDisclosedIndexes bbsBadgeMessageCount (badgeDisclosedMessages badgeExpiry badgeType)
 
+localBadgeVerified :: Maybe LocalBadge -> Maybe Bool
+localBadgeVerified = fmap $ \LocalBadge {badgeStatus} -> badgeStatus /= BSFailed
+
+-- 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
+
+instance ToField BadgeType where toField = toField . textEncode
+
+type BadgeRow = (Maybe ByteString, Maybe ByteString, Maybe UTCTime, Maybe Text, Maybe BoolInt)
+
+badgeToRow :: Maybe SupporterBadge -> Maybe Bool -> BadgeRow
+badgeToRow Nothing _ = (Nothing, Nothing, Nothing, Nothing, Nothing)
+badgeToRow (Just SupporterBadge {proof = BBSProof p, presHeader = BBSPresHeader ph, badgeExpiry, badgeType}) verified =
+  (Just p, Just ph, badgeExpiry, Just (textEncode badgeType), BI <$> verified)
+
+rowToBadge :: UTCTime -> BadgeRow -> Maybe LocalBadge
+rowToBadge _ (Nothing, _, _, _, _) = Nothing
+rowToBadge now (Just p, Just ph, badgeExpiry, Just btText, verified_) = do
+  bt <- textDecode btText
+  let b = SupporterBadge {proof = BBSProof p, presHeader = BBSPresHeader ph, badgeExpiry, badgeType = bt}
+      verified = maybe False unBI verified_
+  Just LocalBadge {badgeStatus = mkBadgeStatus now verified b, badge = b}
+rowToBadge _ _ = Nothing
+
 -- JSON
 
 $(JQ.deriveJSON (enumJSON $ dropPrefix "BS") ''BadgeStatus)

src/Simplex/Chat/Store/Direct.hs

@@ -105,6 +105,7 @@ import Data.Maybe (fromMaybe, isJust, isNothing)
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime (..), getCurrentTime)
 import Data.Type.Equality
+import Simplex.Chat.Badges (badgeToRow)
 import Simplex.Chat.Messages
 import Simplex.Chat.Store.Shared
 import Simplex.Chat.Types
@@ -555,18 +556,20 @@ deleteUnusedProfile_ db userId profileId =
 updateContactProfile :: DB.Connection -> User -> Contact -> Profile -> ExceptT StoreError IO Contact
 updateContactProfile db user@User {userId} c p'
   | displayName == newName = do
-      liftIO $ updateContactProfile_ db userId profileId p'
-      pure c {profile, mergedPreferences}
+      currentTs <- liftIO getCurrentTime
+      badgeVerified <- liftIO $ profileBadgeVerified lp p'
+      liftIO $ updateContactProfile_' db userId profileId p' badgeVerified currentTs
+      pure c {profile = toLocalProfile profileId p' localAlias currentTs badgeVerified, mergedPreferences}
   | otherwise =
       ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
         currentTs <- getCurrentTime
-        updateContactProfile_' db userId profileId p' currentTs
+        badgeVerified <- profileBadgeVerified lp p'
+        updateContactProfile_' db userId profileId p' badgeVerified currentTs
         updateContactLDN_ db user contactId localDisplayName ldn currentTs
-        pure $ Right c {localDisplayName = ldn, profile, mergedPreferences}
+        pure $ Right c {localDisplayName = ldn, profile = toLocalProfile profileId p' localAlias currentTs badgeVerified, mergedPreferences}
   where
-    Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}, userPreferences} = c
+    Contact {contactId, localDisplayName, profile = lp@LocalProfile {profileId, displayName, localAlias}, userPreferences} = c
     Profile {displayName = newName, preferences} = p'
-    profile = toLocalProfile profileId p' localAlias
     mergedPreferences = contactUserPreferences user userPreferences preferences $ contactConnIncognito c
 
 updateContactUserPreferences :: DB.Connection -> User -> Contact -> Preferences -> IO Contact
@@ -694,55 +697,64 @@ setQuotaErrCounter db User {userId} Connection {connId} counter = do
   updatedAt <- getCurrentTime
   DB.execute db "UPDATE connections SET quota_err_counter = ?, updated_at = ? WHERE user_id = ? AND connection_id = ?" (counter, updatedAt, userId, connId)
 
-updateContactProfile_ :: DB.Connection -> UserId -> ProfileId -> Profile -> IO ()
-updateContactProfile_ db userId profileId profile = do
+updateContactProfile_ :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> IO ()
+updateContactProfile_ db userId profileId profile badgeVerified = do
   currentTs <- getCurrentTime
-  updateContactProfile_' db userId profileId profile currentTs
+  updateContactProfile_' db userId profileId profile badgeVerified currentTs
 
-updateContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> UTCTime -> IO ()
-updateContactProfile_' db userId profileId Profile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType} updatedAt = do
+updateContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> UTCTime -> IO ()
+updateContactProfile_' db userId profileId Profile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, badge} badgeVerified updatedAt = do
+  let (bProof, bPresHeader, bExpiry, bType, bVerified) = badgeToRow badge badgeVerified
   DB.execute
     db
     [sql|
       UPDATE contact_profiles
-      SET display_name = ?, full_name = ?, short_descr = ?, image = ?, contact_link = ?, preferences = ?, chat_peer_type = ?, updated_at = ?
+      SET display_name = ?, full_name = ?, short_descr = ?, image = ?, contact_link = ?, preferences = ?, chat_peer_type = ?,
+          badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?,
+          updated_at = ?
       WHERE user_id = ? AND contact_profile_id = ?
     |]
-    (displayName, fullName, shortDescr, image, contactLink, preferences, peerType, updatedAt, userId, profileId)
+    ((displayName, fullName, shortDescr, image, contactLink, preferences, peerType) :. (bProof, bPresHeader, bExpiry, bType, bVerified, updatedAt, userId, profileId))
 
 -- update only member profile fields (when member doesn't have associated contact - we can reset contactLink and prefs)
-updateMemberContactProfileReset_ :: DB.Connection -> UserId -> ProfileId -> Profile -> IO ()
-updateMemberContactProfileReset_ db userId profileId profile = do
+updateMemberContactProfileReset_ :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> IO ()
+updateMemberContactProfileReset_ db userId profileId profile badgeVerified = do
   currentTs <- getCurrentTime
-  updateMemberContactProfileReset_' db userId profileId profile currentTs
+  updateMemberContactProfileReset_' db userId profileId profile badgeVerified currentTs
 
-updateMemberContactProfileReset_' :: DB.Connection -> UserId -> ProfileId -> Profile -> UTCTime -> IO ()
-updateMemberContactProfileReset_' db userId profileId Profile {displayName, fullName, shortDescr, image} updatedAt = do
+updateMemberContactProfileReset_' :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> UTCTime -> IO ()
+updateMemberContactProfileReset_' db userId profileId Profile {displayName, fullName, shortDescr, image, badge} badgeVerified updatedAt = do
+  let (bProof, bPresHeader, bExpiry, bType, bVerified) = badgeToRow badge badgeVerified
   DB.execute
     db
     [sql|
       UPDATE contact_profiles
-      SET display_name = ?, full_name = ?, short_descr = ?, image = ?, contact_link = NULL, preferences = NULL, updated_at = ?
+      SET display_name = ?, full_name = ?, short_descr = ?, image = ?, contact_link = NULL, preferences = NULL,
+          badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?,
+          updated_at = ?
       WHERE user_id = ? AND contact_profile_id = ?
     |]
-    (displayName, fullName, shortDescr, image, updatedAt, userId, profileId)
+    ((displayName, fullName, shortDescr, image) :. (bProof, bPresHeader, bExpiry, bType, bVerified, updatedAt, userId, profileId))
 
 -- update only member profile fields (when member has associated contact - we keep contactLink and prefs)
-updateMemberContactProfile_ :: DB.Connection -> UserId -> ProfileId -> Profile -> IO ()
-updateMemberContactProfile_ db userId profileId profile = do
+updateMemberContactProfile_ :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> IO ()
+updateMemberContactProfile_ db userId profileId profile badgeVerified = do
   currentTs <- getCurrentTime
-  updateMemberContactProfile_' db userId profileId profile currentTs
+  updateMemberContactProfile_' db userId profileId profile badgeVerified currentTs
 
-updateMemberContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> UTCTime -> IO ()
-updateMemberContactProfile_' db userId profileId Profile {displayName, fullName, shortDescr, image} updatedAt = do
+updateMemberContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> UTCTime -> IO ()
+updateMemberContactProfile_' db userId profileId Profile {displayName, fullName, shortDescr, image, badge} badgeVerified updatedAt = do
+  let (bProof, bPresHeader, bExpiry, bType, bVerified) = badgeToRow badge badgeVerified
   DB.execute
     db
     [sql|
       UPDATE contact_profiles
-      SET display_name = ?, full_name = ?, short_descr = ?, image = ?, updated_at = ?
+      SET display_name = ?, full_name = ?, short_descr = ?, image = ?,
+          badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?,
+          updated_at = ?
       WHERE user_id = ? AND contact_profile_id = ?
     |]
-    (displayName, fullName, shortDescr, image, updatedAt, userId, profileId)
+    ((displayName, fullName, shortDescr, image) :. (bProof, bPresHeader, bExpiry, bType, bVerified, updatedAt, userId, profileId))
 
 updateContactLDN_ :: DB.Connection -> User -> Int64 -> ContactName -> ContactName -> UTCTime -> IO ()
 updateContactLDN_ db user@User {userId} contactId displayName newName updatedAt = do
@@ -848,7 +860,7 @@ createContactFromRequest db user@User {userId, profile = LocalProfile {preferenc
         Contact
           { contactId,
             localDisplayName,
-            profile = toLocalProfile profileId profile "",
+            profile = toLocalProfile profileId profile "" currentTs Nothing,
             activeConn = Just conn,
             contactUsed,
             contactStatus = CSActive,

src/Simplex/Chat/Store/Groups.hs

@@ -2134,7 +2134,7 @@ createNewMember_
           invitedBy,
           invitedByGroupMemberId = memInvitedByGroupMemberId,
           localDisplayName,
-          memberProfile = toLocalProfile memberContactProfileId memberProfile "",
+          memberProfile = toLocalProfile memberContactProfileId memberProfile "" createdAt Nothing,
           memberContactId,
           memberContactProfileId,
           activeConn,
@@ -2986,38 +2986,44 @@ setMemberContactStartedConnection db Contact {contactId} = do
 updateMemberProfile :: DB.Connection -> User -> GroupMember -> Profile -> ExceptT StoreError IO GroupMember
 updateMemberProfile db user@User {userId} m p'
   | displayName == newName = do
-      liftIO $ updateMemberContactProfileReset_ db userId profileId p'
-      pure m {memberProfile = profile}
+      currentTs <- liftIO getCurrentTime
+      badgeVerified <- liftIO $ profileBadgeVerified (memberProfile m) p'
+      liftIO $ updateMemberContactProfileReset_' db userId profileId p' badgeVerified currentTs
+      pure m {memberProfile = toLocalProfile profileId p' localAlias currentTs badgeVerified}
   | otherwise =
       ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
         currentTs <- getCurrentTime
-        updateMemberContactProfileReset_' db userId profileId p' currentTs
+        badgeVerified <- profileBadgeVerified (memberProfile m) p'
+        updateMemberContactProfileReset_' db userId profileId p' badgeVerified currentTs
         DB.execute
           db
           "UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND group_member_id = ?"
           (ldn, currentTs, userId, groupMemberId)
         safeDeleteLDN db user localDisplayName
-        pure $ Right m {localDisplayName = ldn, memberProfile = profile}
+        pure $ Right m {localDisplayName = ldn, memberProfile = toLocalProfile profileId p' localAlias currentTs badgeVerified}
   where
     GroupMember {groupMemberId, localDisplayName, memberProfile = LocalProfile {profileId, displayName, localAlias}} = m
     Profile {displayName = newName} = p'
-    profile = toLocalProfile profileId p' localAlias
 
 updateContactMemberProfile :: DB.Connection -> User -> GroupMember -> Contact -> Profile -> ExceptT StoreError IO (GroupMember, Contact)
 updateContactMemberProfile db user@User {userId} m ct@Contact {contactId} p'
   | displayName == newName = do
-      liftIO $ updateMemberContactProfile_ db userId profileId p'
+      currentTs <- liftIO getCurrentTime
+      badgeVerified <- liftIO $ profileBadgeVerified (memberProfile m) p'
+      liftIO $ updateMemberContactProfile_' db userId profileId p' badgeVerified currentTs
+      let profile = toLocalProfile profileId p' localAlias currentTs badgeVerified
       pure (m {memberProfile = profile}, ct {profile} :: Contact)
   | otherwise =
       ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
         currentTs <- getCurrentTime
-        updateMemberContactProfile_' db userId profileId p' currentTs
+        badgeVerified <- profileBadgeVerified (memberProfile m) p'
+        updateMemberContactProfile_' db userId profileId p' badgeVerified currentTs
         updateContactLDN_ db user contactId localDisplayName ldn currentTs
+        let profile = toLocalProfile profileId p' localAlias currentTs badgeVerified
         pure $ Right (m {localDisplayName = ldn, memberProfile = profile}, ct {localDisplayName = ldn, profile} :: Contact)
   where
     GroupMember {localDisplayName, memberProfile = LocalProfile {profileId, displayName, localAlias}} = m
     Profile {displayName = newName} = p'
-    profile = toLocalProfile profileId p' localAlias
 
 getXGrpLinkMemReceived :: DB.Connection -> GroupMemberId -> ExceptT StoreError IO Bool
 getXGrpLinkMemReceived db mId =

src/Simplex/Chat/Store/Profiles.hs

@@ -309,10 +309,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
+      updateContactProfile_' db userId profileId p' Nothing currentTs
       userMemberProfileUpdatedAt' <- updateUserMemberProfileUpdatedAt_ currentTs
-      pure user {profile, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'}
+      pure user {profile = toLocalProfile profileId p' localAlias currentTs Nothing, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'}
   | otherwise =
       checkConstraint SEDuplicateName . liftIO $ do
         currentTs <- getCurrentTime
@@ -322,9 +322,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
+        updateContactProfile_' db userId profileId p' Nothing 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 Nothing, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'}
   where
     updateUserMemberProfileUpdatedAt_ currentTs
       | userMemberProfileChanged = do
@@ -334,7 +334,6 @@ updateUserProfile db user p'
     userMemberProfileChanged = newName /= displayName || fn' /= fullName || d' /= shortDescr || img' /= image
     User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, localAlias}, userMemberProfileUpdatedAt} = user
     Profile {displayName = newName, fullName = fn', shortDescr = d', image = img', preferences} = p'
-    profile = toLocalProfile profileId p' localAlias
     fullPreferences = fullPreferences' preferences
 
 setUserProfileContactLink :: DB.Connection -> User -> Maybe UserContactLink -> IO User

src/Simplex/Chat/Types.hs

@@ -47,7 +47,7 @@ import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock (UTCTime)
 import Data.Typeable (Typeable)
 import Data.Word (Word16)
-import Simplex.Chat.Badges (LocalBadge, SupporterBadge)
+import Simplex.Chat.Badges (BadgeStatus (..), LocalBadge (..), SupporterBadge, mkBadgeStatus, srvBadgePublicKey, verifyBadge)
 import Simplex.Chat.Types.Preferences
 import Simplex.Chat.Types.Shared
 import Simplex.Chat.Types.UITheme
@@ -768,13 +768,26 @@ data LocalProfile = LocalProfile
 localProfileId :: LocalProfile -> ProfileId
 localProfileId LocalProfile {profileId} = profileId
 
-toLocalProfile :: ProfileId -> Profile -> LocalAlias -> LocalProfile
-toLocalProfile profileId Profile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType} localAlias =
-  LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, preferences, peerType, badge = Nothing, localAlias}
+toLocalProfile :: ProfileId -> Profile -> LocalAlias -> UTCTime -> Maybe Bool -> LocalProfile
+toLocalProfile profileId Profile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, badge} localAlias now verified_ =
+  LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, preferences, peerType, badge = mkLocalBadge, localAlias}
+  where
+    mkLocalBadge = do
+      b <- badge
+      verified <- verified_
+      pure LocalBadge {badgeStatus = mkBadgeStatus now verified b, badge = b}
 
 fromLocalProfile :: LocalProfile -> Profile
-fromLocalProfile LocalProfile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType} =
-  Profile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, badge = Nothing}
+fromLocalProfile LocalProfile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, badge} =
+  Profile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, badge = (\LocalBadge {badge = b} -> b) <$> badge}
+
+profileBadgeVerified :: LocalProfile -> Profile -> IO (Maybe Bool)
+profileBadgeVerified LocalProfile {badge = oldBadge} Profile {badge = newBadge} =
+  case (oldBadge, newBadge) of
+    (_, Nothing) -> pure Nothing
+    (Just LocalBadge {badge = oldB, badgeStatus}, Just newB)
+      | oldB == newB -> pure $ Just (badgeStatus /= BSFailed)
+    (_, Just newB) -> Just <$> verifyBadge srvBadgePublicKey newB
 
 data GroupType
   = GTChannel