diff --git a/src/Simplex/Chat/Badges.hs b/src/Simplex/Chat/Badges.hs index 1e5e818530..9fb7b301e3 100644 --- a/src/Simplex/Chat/Badges.hs +++ b/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) diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs index 60f898e52e..c19e68a79f 100644 --- a/src/Simplex/Chat/Store/Direct.hs +++ b/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, diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 8c207d99a7..824a111193 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/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 = diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index 3eff9cf4f2..eeb856f718 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/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 diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index b911e58360..4de9f66947 100644 --- a/src/Simplex/Chat/Types.hs +++ b/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