From aeb3162de0048e4b5804f3f46cf353f80c757aa0 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Thu, 4 Jun 2026 23:12:15 +0100 Subject: [PATCH] change types --- src/Simplex/Chat/Badges.hs | 16 +++++----- src/Simplex/Chat/Store/Connections.hs | 2 +- src/Simplex/Chat/Store/ContactRequest.hs | 8 ++--- src/Simplex/Chat/Store/Direct.hs | 14 ++++----- src/Simplex/Chat/Store/Groups.hs | 8 ++--- .../Migrations/M20260516_supporter_badges.hs | 2 +- src/Simplex/Chat/Store/Profiles.hs | 8 ++--- .../Migrations/M20260516_supporter_badges.hs | 2 +- src/Simplex/Chat/Store/Shared.hs | 12 ++++---- src/Simplex/Chat/Types.hs | 29 +++++++++---------- 10 files changed, 50 insertions(+), 51 deletions(-) diff --git a/src/Simplex/Chat/Badges.hs b/src/Simplex/Chat/Badges.hs index 9fb7b301e3..e636f931af 100644 --- a/src/Simplex/Chat/Badges.hs +++ b/src/Simplex/Chat/Badges.hs @@ -22,6 +22,7 @@ module Simplex.Chat.Badges verifyBadgeSignature, generateBadgeProof, verifyBadge, + verifyBadge_, mkBadgeStatus, localBadgeVerified, srvBadgePublicKey, @@ -203,6 +204,9 @@ verifyBadge :: BBSPublicKey -> SupporterBadge -> IO Bool verifyBadge pk SupporterBadge {proof, presHeader, badgeExpiry, badgeType} = bbsProofVerify pk proof bbsBadgeHeader presHeader bbsBadgeDisclosedIndexes bbsBadgeMessageCount (badgeDisclosedMessages badgeExpiry badgeType) +verifyBadge_ :: BBSPublicKey -> Maybe SupporterBadge -> IO Bool +verifyBadge_ = maybe (pure False) . verifyBadge + localBadgeVerified :: Maybe LocalBadge -> Maybe Bool localBadgeVerified = fmap $ \LocalBadge {badgeStatus} -> badgeStatus /= BSFailed @@ -217,19 +221,17 @@ 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) +type BadgeRow = (Maybe ByteString, Maybe ByteString, Maybe UTCTime, Maybe Text, BoolInt) -badgeToRow :: Maybe SupporterBadge -> Maybe Bool -> BadgeRow -badgeToRow Nothing _ = (Nothing, Nothing, Nothing, Nothing, Nothing) +badgeToRow :: Maybe SupporterBadge -> Bool -> BadgeRow badgeToRow (Just SupporterBadge {proof = BBSProof p, presHeader = BBSPresHeader ph, badgeExpiry, badgeType}) verified = - (Just p, Just ph, badgeExpiry, Just (textEncode badgeType), BI <$> verified) + (Just p, Just ph, badgeExpiry, Just (textEncode badgeType), BI verified) +badgeToRow _ _ = (Nothing, Nothing, Nothing, Nothing, BI False) rowToBadge :: UTCTime -> BadgeRow -> Maybe LocalBadge -rowToBadge _ (Nothing, _, _, _, _) = Nothing -rowToBadge now (Just p, Just ph, badgeExpiry, Just btText, verified_) = do +rowToBadge now (Just p, Just ph, badgeExpiry, Just btText, (BI 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 diff --git a/src/Simplex/Chat/Store/Connections.hs b/src/Simplex/Chat/Store/Connections.hs index 13b8bd2dec..f02c60cdc1 100644 --- a/src/Simplex/Chat/Store/Connections.hs +++ b/src/Simplex/Chat/Store/Connections.hs @@ -124,7 +124,7 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do (userId, contactId, CSActive) toContact' :: UTCTime -> Int64 -> Connection -> [ChatTagId] -> ContactRow' -> Contact toContact' currentTs contactId conn chatTags ((profileId, localDisplayName, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, BI contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, BI favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. preparedContactRow :. (contactRequestId, contactGroupMemberId, BI contactGrpInvSent) :. groupDirectInvRow :. (uiThemes, BI chatDeleted, customData, chatItemTTL) :. badgeRow) = - let profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, badge = rowToBadge currentTs badgeRow, preferences, localAlias} + let profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, localBadge = rowToBadge currentTs badgeRow, preferences, localAlias} chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite} mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito conn activeConn = Just conn diff --git a/src/Simplex/Chat/Store/ContactRequest.hs b/src/Simplex/Chat/Store/ContactRequest.hs index b4f522fa19..a416855cc2 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, srvBadgePublicKey, verifyBadge_) import Simplex.Chat.Protocol (MsgContent, businessChatsVersion) import Simplex.Chat.Store.Direct import Simplex.Chat.Store.Groups @@ -161,7 +161,7 @@ createOrUpdateContactRequest createContactRequest :: ExceptT StoreError IO RequestStage createContactRequest = do currentTs <- liftIO $ getCurrentTime - badgeVerified <- liftIO $ forM badge $ verifyBadge srvBadgePublicKey + badgeVerified <- liftIO $ verifyBadge_ srvBadgePublicKey badge let (bProof, bPresHeader, bExpiry, bType, bVerified) = badgeToRow badge badgeVerified ExceptT $ withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do liftIO $ @@ -222,8 +222,8 @@ createOrUpdateContactRequest updateContactRequest :: UserContactRequest -> ExceptT StoreError IO RequestStage updateContactRequest ucr@UserContactRequest {contactRequestId, contactId_, localDisplayName = oldLdn, profile = Profile {displayName = oldDisplayName}} = do currentTs <- liftIO getCurrentTime - badgeVerified <- liftIO $ forM badge $ verifyBadge srvBadgePublicKey - let badgeRow@(bProof, bPresHeader, bExpiry, bType, bVerified) = badgeToRow badge badgeVerified + badgeVerified <- liftIO $ verifyBadge_ srvBadgePublicKey badge + let badgeRow = badgeToRow badge badgeVerified liftIO $ updateProfile currentTs badgeRow updateRequest currentTs ucr' <- getContactRequest db user contactRequestId diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs index 00734548d9..d628fcef8b 100644 --- a/src/Simplex/Chat/Store/Direct.hs +++ b/src/Simplex/Chat/Store/Direct.hs @@ -700,12 +700,12 @@ 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 -> Maybe Bool -> IO () +updateContactProfile_ :: DB.Connection -> UserId -> ProfileId -> Profile -> Bool -> IO () updateContactProfile_ db userId profileId profile badgeVerified = do currentTs <- getCurrentTime updateContactProfile_' db userId profileId profile badgeVerified currentTs -updateContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> UTCTime -> IO () +updateContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> 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 @@ -719,12 +719,12 @@ updateContactProfile_' db userId profileId Profile {displayName, fullName, short ((displayName, fullName, shortDescr, image, contactLink, preferences, peerType, updatedAt) :. (bProof, bPresHeader, bExpiry, bType, bVerified) :. (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 -> Maybe Bool -> IO () +updateMemberContactProfileReset_ :: DB.Connection -> UserId -> ProfileId -> Profile -> Bool -> IO () updateMemberContactProfileReset_ db userId profileId profile badgeVerified = do currentTs <- getCurrentTime updateMemberContactProfileReset_' db userId profileId profile badgeVerified currentTs -updateMemberContactProfileReset_' :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> UTCTime -> IO () +updateMemberContactProfileReset_' :: DB.Connection -> UserId -> ProfileId -> Profile -> 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 @@ -738,12 +738,12 @@ updateMemberContactProfileReset_' db userId profileId Profile {displayName, full ((displayName, fullName, shortDescr, image, updatedAt) :. (bProof, bPresHeader, bExpiry, bType, bVerified) :. (userId, profileId)) -- update only member profile fields (when member has associated contact - we keep contactLink and prefs) -updateMemberContactProfile_ :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> IO () +updateMemberContactProfile_ :: DB.Connection -> UserId -> ProfileId -> Profile -> Bool -> IO () updateMemberContactProfile_ db userId profileId profile badgeVerified = do currentTs <- getCurrentTime updateMemberContactProfile_' db userId profileId profile badgeVerified currentTs -updateMemberContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> UTCTime -> IO () +updateMemberContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> 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 @@ -860,7 +860,7 @@ createContactFromRequest db user@User {userId, profile = LocalProfile {preferenc Contact { contactId, localDisplayName, - profile = toLocalProfile profileId profile "" currentTs Nothing, + profile = toLocalProfile profileId profile "" currentTs False, activeConn = Just conn, contactUsed, contactStatus = CSActive, diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 5037eedc42..da6a693a54 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, srvBadgePublicKey, verifyBadge_) import Simplex.Chat.Messages import Simplex.Chat.Operators import Simplex.Chat.Protocol hiding (Binary) @@ -1727,7 +1727,7 @@ createJoiningMember memberStatus memberKey_ = do currentTs <- liftIO getCurrentTime - badgeVerified <- liftIO $ forM badge $ verifyBadge srvBadgePublicKey + badgeVerified <- liftIO $ verifyBadge_ srvBadgePublicKey badge let (bProof, bPresHeader, bExpiry, bType, bVerified) = badgeToRow badge badgeVerified ExceptT . withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do liftIO $ @@ -2091,7 +2091,7 @@ createNewGroupMember db user gInfo invitingMember memInfo@MemberInfo {profile} m createNewMemberProfile_ :: DB.Connection -> User -> Profile -> UTCTime -> ExceptT StoreError IO (Text, ProfileId) createNewMemberProfile_ db User {userId} Profile {displayName, fullName, shortDescr, image, contactLink, badge, preferences} createdAt = ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do - badgeVerified <- forM badge $ verifyBadge srvBadgePublicKey + badgeVerified <- verifyBadge_ srvBadgePublicKey badge let (bProof, bPresHeader, bExpiry, bType, bVerified) = badgeToRow badge badgeVerified DB.execute db @@ -2153,7 +2153,7 @@ createNewMember_ invitedBy, invitedByGroupMemberId = memInvitedByGroupMemberId, localDisplayName, - memberProfile = toLocalProfile memberContactProfileId memberProfile "" createdAt Nothing, + memberProfile = toLocalProfile memberContactProfileId memberProfile "" createdAt False, memberContactId, memberContactProfileId, activeConn, diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20260516_supporter_badges.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20260516_supporter_badges.hs index e196e49062..014d99af35 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/M20260516_supporter_badges.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20260516_supporter_badges.hs @@ -12,7 +12,7 @@ ALTER TABLE contact_profiles ADD COLUMN badge_proof BYTEA; ALTER TABLE contact_profiles ADD COLUMN badge_pres_header BYTEA; ALTER TABLE contact_profiles ADD COLUMN badge_expiry TEXT; ALTER TABLE contact_profiles ADD COLUMN badge_type TEXT; -ALTER TABLE contact_profiles ADD COLUMN badge_verified BOOLEAN; +ALTER TABLE contact_profiles ADD COLUMN badge_verified SMALLINT NOT NULL DEFAULT ; |] down_m20260516_supporter_badges :: Query diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index eeb856f718..8aaffc47c4 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -310,9 +310,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' Nothing currentTs + updateContactProfile_' db userId profileId p' False currentTs userMemberProfileUpdatedAt' <- updateUserMemberProfileUpdatedAt_ currentTs - pure user {profile = toLocalProfile profileId p' localAlias currentTs Nothing, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'} + pure user {profile = toLocalProfile profileId p' localAlias currentTs False, 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' Nothing currentTs + updateContactProfile_' db userId profileId p' False currentTs updateContactLDN_ db user userContactId localDisplayName newName currentTs - pure user {localDisplayName = newName, profile = toLocalProfile profileId p' localAlias currentTs Nothing, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'} + pure user {localDisplayName = newName, profile = toLocalProfile profileId p' localAlias currentTs False, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'} where updateUserMemberProfileUpdatedAt_ currentTs | userMemberProfileChanged = do diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20260516_supporter_badges.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20260516_supporter_badges.hs index 907dad968e..b783d9bc58 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/M20260516_supporter_badges.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20260516_supporter_badges.hs @@ -12,7 +12,7 @@ ALTER TABLE contact_profiles ADD COLUMN badge_proof BLOB; ALTER TABLE contact_profiles ADD COLUMN badge_pres_header BLOB; ALTER TABLE contact_profiles ADD COLUMN badge_expiry TEXT; ALTER TABLE contact_profiles ADD COLUMN badge_type TEXT; -ALTER TABLE contact_profiles ADD COLUMN badge_verified INTEGER; +ALTER TABLE contact_profiles ADD COLUMN badge_verified INTEGER NOT NULL DEFAULT 0; |] down_m20260516_supporter_badges :: Query diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index 5a4f6d8818..d61724e59a 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, srvBadgePublicKey, verifyBadge_) import Simplex.Chat.Messages import Simplex.Chat.Remote.Types import Simplex.Chat.Types @@ -413,9 +413,9 @@ createContact db user profile = do void $ createContact_ db user profile emptyChatPrefs Nothing "" currentTs createContact_ :: DB.Connection -> User -> Profile -> Preferences -> Maybe (ACreatedConnLink, Maybe SharedMsgId) -> LocalAlias -> UTCTime -> ExceptT StoreError IO ContactId -createContact_ db User {userId} p@Profile {displayName, fullName, shortDescr, image, contactLink, peerType, badge, preferences} ctUserPreferences prepared localAlias currentTs = +createContact_ db User {userId} Profile {displayName, fullName, shortDescr, image, contactLink, peerType, badge, preferences} ctUserPreferences prepared localAlias currentTs = ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do - badgeVerified <- forM badge $ verifyBadge srvBadgePublicKey + badgeVerified <- verifyBadge_ srvBadgePublicKey badge let (bProof, bPresHeader, bExpiry, bType, bVerified) = badgeToRow badge badgeVerified DB.execute db @@ -493,7 +493,7 @@ type ContactRow = Only ContactId :. ContactRow' toContact :: UTCTime -> VersionRangeChat -> User -> [ChatTagId] -> ContactRow :. MaybeConnectionRow -> Contact toContact now vr user chatTags ((Only contactId :. (profileId, localDisplayName, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, BI contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, BI favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. preparedContactRow :. (contactRequestId, contactGroupMemberId, BI contactGrpInvSent) :. groupDirectInvRow :. (uiThemes, BI chatDeleted, customData, chatItemTTL) :. badgeRow) :. connRow) = - let profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, badge = rowToBadge now badgeRow, preferences, localAlias} + let profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, localBadge = rowToBadge now badgeRow, preferences, localAlias} activeConn = toMaybeConnection vr connRow chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite} incognito = maybe False connIncognito activeConn @@ -554,7 +554,7 @@ toUser :: (UserId, UserId, ContactId, ProfileId, BoolInt, Int64) :. (ContactName toUser ((userId, auId, userContactId, profileId, BI activeUser, activeOrder) :. (displayName, fullName, shortDescr, image, contactLink, peerType, userPreferences) :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, viewPwdHash_, viewPwdSalt_, userMemberProfileUpdatedAt, uiThemes, BI userChatRelay)) = User {userId, agentUserId = AgentUserId auId, userContactId, localDisplayName = displayName, profile, activeUser, activeOrder, fullPreferences, showNtfs, sendRcptsContacts, sendRcptsSmallGroups, autoAcceptMemberContacts = BoolDef autoAcceptMemberContacts, viewPwdHash, userMemberProfileUpdatedAt, uiThemes, userChatRelay = BoolDef userChatRelay} where - profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, badge = Nothing, preferences = userPreferences, localAlias = ""} + profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, localBadge = Nothing, preferences = userPreferences, localAlias = ""} fullPreferences = fullPreferences' userPreferences viewPwdHash = UserPwdHash <$> viewPwdHash_ <*> viewPwdSalt_ @@ -768,7 +768,7 @@ toContactMember now vr User {userContactId} (memberRow :. connRow) = rowToLocalProfile :: UTCTime -> ProfileRow -> LocalProfile rowToLocalProfile now ((profileId, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, preferences) :. badgeRow) = - LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, badge = rowToBadge now badgeRow, localAlias, preferences} + LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, localBadge = rowToBadge now badgeRow, localAlias, preferences} toBusinessChatInfo :: BusinessChatInfoRow -> Maybe BusinessChatInfo toBusinessChatInfo (Just chatType, Just businessId, Just customerId) = Just BusinessChatInfo {chatType, businessId, customerId} diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 4de9f66947..1b40e60c43 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -760,7 +760,7 @@ data LocalProfile = LocalProfile contactLink :: Maybe ConnLinkContact, preferences :: Maybe Preferences, peerType :: Maybe ChatPeerType, - badge :: Maybe LocalBadge, + localBadge :: Maybe LocalBadge, localAlias :: LocalAlias } deriving (Eq, Show) @@ -768,26 +768,23 @@ data LocalProfile = LocalProfile localProfileId :: LocalProfile -> ProfileId localProfileId LocalProfile {profileId} = profileId -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} +toLocalProfile :: ProfileId -> Profile -> LocalAlias -> UTCTime -> 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, localBadge, localAlias} where - mkLocalBadge = do - b <- badge - verified <- verified_ - pure LocalBadge {badgeStatus = mkBadgeStatus now verified b, badge = b} + localBadge = (\b -> LocalBadge {badgeStatus = mkBadgeStatus now verified b, badge = b}) <$> badge fromLocalProfile :: LocalProfile -> Profile -fromLocalProfile LocalProfile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, badge} = - Profile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, badge = (\LocalBadge {badge = b} -> b) <$> badge} +fromLocalProfile LocalProfile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, localBadge} = + Profile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, badge = (\LocalBadge {badge} -> badge) <$> localBadge} -profileBadgeVerified :: LocalProfile -> Profile -> IO (Maybe Bool) -profileBadgeVerified LocalProfile {badge = oldBadge} Profile {badge = newBadge} = - case (oldBadge, newBadge) of - (_, Nothing) -> pure Nothing +profileBadgeVerified :: LocalProfile -> Profile -> IO Bool +profileBadgeVerified LocalProfile {localBadge} Profile {badge = newBadge} = + case (localBadge, newBadge) of + (_, Nothing) -> pure False (Just LocalBadge {badge = oldB, badgeStatus}, Just newB) - | oldB == newB -> pure $ Just (badgeStatus /= BSFailed) - (_, Just newB) -> Just <$> verifyBadge srvBadgePublicKey newB + | oldB == newB -> pure (badgeStatus /= BSFailed) + (_, Just newB) -> verifyBadge srvBadgePublicKey newB data GroupType = GTChannel