From ea4db3ac53d16c0891e86ba6fdb79d2e68b8542a Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Tue, 9 Jun 2026 07:33:31 +0000 Subject: [PATCH] refactor badge types to GADT --- bots/src/API/Docs/Types.hs | 8 +- src/Simplex/Chat/Badges.hs | 251 +++++++++++++----- src/Simplex/Chat/Mobile/Badges.hs | 3 +- src/Simplex/Chat/Store/Connections.hs | 6 +- src/Simplex/Chat/Store/ContactRequest.hs | 10 +- src/Simplex/Chat/Store/Direct.hs | 12 +- src/Simplex/Chat/Store/Groups.hs | 4 +- src/Simplex/Chat/Store/Messages.hs | 10 +- .../Migrations/M20260516_supporter_badges.hs | 4 + .../Migrations/M20260516_supporter_badges.hs | 4 + src/Simplex/Chat/Store/Shared.hs | 8 +- src/Simplex/Chat/Types.hs | 17 +- tests/BadgeTests.hs | 40 +-- tests/MobileTests.hs | 6 +- 14 files changed, 259 insertions(+), 124 deletions(-) diff --git a/bots/src/API/Docs/Types.hs b/bots/src/API/Docs/Types.hs index 946eaf7b6b..0381d2c67f 100644 --- a/bots/src/API/Docs/Types.hs +++ b/bots/src/API/Docs/Types.hs @@ -34,7 +34,7 @@ import Simplex.Chat.Store.Profiles import Simplex.Chat.Store.Shared import Simplex.Chat.Operators import Simplex.Messaging.Agent.Store.Entity (DBStored (..)) -import Simplex.Chat.Badges (LocalBadge (..), BadgeStatus (..), SupporterBadge (..), BadgeType (..)) +import Simplex.Chat.Badges (BadgeInfo (..), BadgeStatus (..), BadgeType (..)) import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared @@ -306,7 +306,7 @@ chatTypesDocsData = (sti @LinkContent, STUnion, "LC", [], "", ""), (sti @LinkOwnerSig, STRecord, "", [], "", ""), (sti @LinkPreview, STRecord, "", [], "", ""), - (sti @LocalBadge, STRecord, "", [], "", ""), + (sti @BadgeInfo, STRecord, "", [], "", ""), (sti @LocalProfile, STRecord, "", [], "", ""), (sti @MemberCriteria, STEnum1, "MC", [], "", ""), (sti @MsgChatLink, STUnion, "MCL", [], "", "Connection link sent in a message - only short links are allowed."), @@ -364,7 +364,6 @@ chatTypesDocsData = (sti @SrvError, STUnion, "SrvErr", [], "", ""), (sti @StoreError, STUnion, "SE", [], "", ""), (sti @SubscriptionStatus, STUnion, "SS", [], "", ""), - (sti @SupporterBadge, STRecord, "", [], "", ""), (sti @SupportGroupPreference, STRecord, "", [], "", ""), (sti @SwitchPhase, STEnum, "SP", [], "", ""), (sti @TimedMessagesGroupPreference, STRecord, "", [], "", ""), @@ -531,7 +530,7 @@ deriving instance Generic JSONCIStatus deriving instance Generic LinkContent deriving instance Generic LinkOwnerSig deriving instance Generic LinkPreview -deriving instance Generic LocalBadge +deriving instance Generic BadgeInfo deriving instance Generic LocalProfile deriving instance Generic MemberCriteria deriving instance Generic MsgChatLink @@ -558,7 +557,6 @@ deriving instance Generic ProxyClientError deriving instance Generic ProxyError deriving instance Generic PublicGroupAccess deriving instance Generic PublicGroupData -deriving instance Generic SupporterBadge deriving instance Generic PublicGroupProfile deriving instance Generic RatchetSyncState deriving instance Generic RCErrorType diff --git a/src/Simplex/Chat/Badges.hs b/src/Simplex/Chat/Badges.hs index f0ebdf6dcf..a060ec6b3b 100644 --- a/src/Simplex/Chat/Badges.hs +++ b/src/Simplex/Chat/Badges.hs @@ -1,27 +1,39 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} module Simplex.Chat.Badges ( BadgeType (..), BadgeStatus (..), + BadgeInfo (..), + BadgeCrypto (..), + Badge (..), LocalBadge (..), + localBadgeInfo, + localBadgeStatus, + BadgePresHeader (..), + badgePresHeaderBytes, + toBadgePresHeader, BadgePurchase (..), BadgeMasterKey (..), BadgeRequest (..), VerifiedBadgeRequest (..), - BadgeCredential (..), - SupporterBadge (..), bbsBadgeHeader, generateMasterKey, verifyPayment, issueBadge, - verifyBadgeSignature, + verifyCredential, generateBadgeProof, verifyBadge, verifyBadge_, @@ -30,22 +42,28 @@ module Simplex.Chat.Badges srvBadgePublicKey, BadgeRow, badgeToRow, + localBadgeToRow, rowToBadge, ) where +import Control.Applicative ((<|>)) import Control.Concurrent.STM import Crypto.Random (ChaChaDRG) -import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=)) +import qualified Data.Aeson as J import qualified Data.Aeson.TH as JQ +import Data.Aeson.Types (Parser) import Data.ByteString (ByteString) +import qualified Data.ByteString as B import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock (UTCTime) +import Data.Word (Word8) 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) +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON) #if defined(dbPostgres) import Database.PostgreSQL.Simple.FromField (FromField (..)) import Database.PostgreSQL.Simple.ToField (ToField (..)) @@ -85,23 +103,90 @@ instance ToJSON BadgeType where instance FromJSON BadgeType where parseJSON = textParseJSON "BadgeType" --- Badge status and local badge +-- Badge status data BadgeStatus = BSActive | BSExpired | BSFailed deriving (Eq, Show) -data LocalBadge = LocalBadge - { badgeStatus :: BadgeStatus, - badge :: SupporterBadge +-- Disclosed badge content (BBS messages 1, 2, 3) + +data BadgeInfo = BadgeInfo + { badgeType :: BadgeType, + badgeExpiry :: Maybe UTCTime, + badgeExtra :: Text } deriving (Eq, Show) -mkBadgeStatus :: UTCTime -> Bool -> SupporterBadge -> BadgeStatus -mkBadgeStatus now verified SupporterBadge {badgeExpiry} +mkBadgeStatus :: UTCTime -> Bool -> BadgeInfo -> BadgeStatus +mkBadgeStatus now verified BadgeInfo {badgeExpiry} | not verified = BSFailed | maybe False (now >) badgeExpiry = BSExpired | otherwise = BSActive +-- Badge crypto: a credential (own, secret) or a proof (wire, a presentation). +-- Positional GADT - a record field cannot be shared across constructors with different result types. + +data BadgeCrypto = BCCredential | BCProof + +data Badge (b :: BadgeCrypto) where + BadgeCredential :: BadgeMasterKey -> BBSSignature -> BadgeInfo -> Badge 'BCCredential + BadgeProof :: BBSPresHeader -> BBSProof -> BadgeInfo -> Badge 'BCProof + +deriving instance Show (Badge b) + +deriving instance Eq (Badge 'BCCredential) + +deriving instance Eq (Badge 'BCProof) + +-- Local badge: a stored badge (own credential or peer proof) plus its display status. +-- Existential - the inner Badge constructor is the discriminator. +data LocalBadge = forall b. LocalBadge (Badge b) BadgeStatus + +sameBadgeCrypto :: Badge x -> Badge y -> Bool +sameBadgeCrypto (BadgeCredential mk1 sg1 i1) (BadgeCredential mk2 sg2 i2) = mk1 == mk2 && sg1 == sg2 && i1 == i2 +sameBadgeCrypto (BadgeProof ph1 p1 i1) (BadgeProof ph2 p2 i2) = ph1 == ph2 && p1 == p2 && i1 == i2 +sameBadgeCrypto _ _ = False + +instance Show LocalBadge where + show (LocalBadge b st) = "LocalBadge (" <> show b <> ") " <> show st + +instance Eq LocalBadge where + LocalBadge b1 s1 == LocalBadge b2 s2 = s1 == s2 && sameBadgeCrypto b1 b2 + +localBadgeInfo :: LocalBadge -> BadgeInfo +localBadgeInfo (LocalBadge b _) = case b of + BadgeCredential _ _ i -> i + BadgeProof _ _ i -> i + +localBadgeStatus :: LocalBadge -> BadgeStatus +localBadgeStatus (LocalBadge _ st) = st + +localBadgeVerified :: Maybe LocalBadge -> Maybe Bool +localBadgeVerified = fmap $ \lb -> localBadgeStatus lb /= BSFailed + +-- Presentation header: unbound test marker (stable) or forward-compat catch-all (master variants) + +data BadgePresHeader + = PHTest + | PHUnknown Word8 ByteString + +badgePresHeaderBytes :: BadgePresHeader -> ByteString +badgePresHeaderBytes = \case + PHTest -> B.singleton 0 + PHUnknown t b -> B.cons t b + +toBadgePresHeader :: ByteString -> BadgePresHeader +toBadgePresHeader bs = case B.uncons bs of + Just (0, _) -> PHTest + Just (t, b) -> PHUnknown t b + Nothing -> PHUnknown 0 "" + +-- stable accepts both; master rejects PHTest +badgePresHeaderAccepted :: BadgePresHeader -> Bool +badgePresHeaderAccepted = \case + PHTest -> True + PHUnknown _ _ -> True + -- Payment proof data BadgePurchase @@ -130,32 +215,13 @@ generateMasterKey drg = BadgeMasterKey <$> atomically (C.randomBytes 32 drg) data BadgeRequest = BadgeRequest { masterKey :: BadgeMasterKey, - badgeType :: BadgeType, - expiry :: Maybe UTCTime + badgeInfo :: BadgeInfo } deriving (Show) newtype VerifiedBadgeRequest = VerifiedBadgeRequest BadgeRequest deriving (Show) -data BadgeCredential = BadgeCredential - { masterKey :: BadgeMasterKey, - signature :: BBSSignature, - badgeExpiry :: Maybe UTCTime, - badgeType :: BadgeType, - badgeExtra :: Text - } - deriving (Eq, Show) - -data SupporterBadge = SupporterBadge - { proof :: BBSProof, - presHeader :: BBSPresHeader, - badgeExpiry :: Maybe UTCTime, - badgeType :: BadgeType, - badgeExtra :: Text - } - deriving (Eq, Show) - -- Constants bbsBadgeHeader :: BBSHeader @@ -172,11 +238,12 @@ bbsBadgeDisclosedIndexes = [1, 2, 3] encodeExpiry :: Maybe UTCTime -> ByteString encodeExpiry = maybe "lifetime" strEncode -badgeMessages :: BadgeMasterKey -> Maybe UTCTime -> BadgeType -> Text -> [ByteString] -badgeMessages (BadgeMasterKey ms) expiry bt extra = [ms, encodeExpiry expiry, encodeUtf8 (textEncode bt), encodeUtf8 extra] +badgeMessages :: BadgeMasterKey -> BadgeInfo -> [ByteString] +badgeMessages (BadgeMasterKey ms) info = ms : badgeInfoMessages info -badgeDisclosedMessages :: Maybe UTCTime -> BadgeType -> Text -> [ByteString] -badgeDisclosedMessages expiry bt extra = [encodeExpiry expiry, encodeUtf8 (textEncode bt), encodeUtf8 extra] +badgeInfoMessages :: BadgeInfo -> [ByteString] +badgeInfoMessages BadgeInfo {badgeType, badgeExpiry, badgeExtra} = + [encodeExpiry badgeExpiry, encodeUtf8 (textEncode badgeType), encodeUtf8 badgeExtra] -- Payment verification (stub - always passes) @@ -185,39 +252,34 @@ verifyPayment _payment req = pure $ Just (VerifiedBadgeRequest req) -- Server-side: issue a badge credential -issueBadge :: BBSSecretKey -> BBSPublicKey -> VerifiedBadgeRequest -> IO (Either String BadgeCredential) -issueBadge sk pk (VerifiedBadgeRequest BadgeRequest {masterKey, badgeType, expiry}) = - fmap mkCred <$> bbsSign sk pk bbsBadgeHeader (badgeMessages masterKey expiry badgeType badgeExtra) - where - badgeExtra = "" -- reserved, empty for now - mkCred sig = BadgeCredential {masterKey, signature = sig, badgeExpiry = expiry, badgeType, badgeExtra} +issueBadge :: BBSSecretKey -> BBSPublicKey -> VerifiedBadgeRequest -> IO (Either String (Badge 'BCCredential)) +issueBadge sk pk (VerifiedBadgeRequest BadgeRequest {masterKey, badgeInfo}) + | badgeExtra badgeInfo /= "" = pure $ Left "badgeExtra must be empty (reserved)" + | otherwise = fmap (\sig -> BadgeCredential masterKey sig badgeInfo) <$> bbsSign sk pk bbsBadgeHeader (badgeMessages masterKey badgeInfo) -- Client-side: verify the credential received from server -verifyBadgeSignature :: BBSPublicKey -> BadgeCredential -> IO Bool -verifyBadgeSignature pk BadgeCredential {masterKey, signature, badgeExpiry, badgeType, badgeExtra} = - bbsVerify pk signature bbsBadgeHeader (badgeMessages masterKey badgeExpiry badgeType badgeExtra) +verifyCredential :: BBSPublicKey -> Badge 'BCCredential -> IO Bool +verifyCredential pk (BadgeCredential masterKey signature badgeInfo) = + bbsVerify pk signature bbsBadgeHeader (badgeMessages masterKey badgeInfo) -- Client-side: generate a proof for a contact/group -generateBadgeProof :: BBSPublicKey -> BadgeCredential -> BBSPresHeader -> IO (Either String SupporterBadge) -generateBadgeProof pk BadgeCredential {masterKey, signature, badgeExpiry, badgeType, badgeExtra} ph = - fmap mkBadge <$> bbsProofGen pk signature bbsBadgeHeader ph bbsBadgeDisclosedIndexes (badgeMessages masterKey badgeExpiry badgeType badgeExtra) - where - mkBadge p = SupporterBadge {proof = p, presHeader = ph, badgeExpiry, badgeType, badgeExtra} +generateBadgeProof :: BBSPublicKey -> Badge 'BCCredential -> BBSPresHeader -> IO (Either String (Badge 'BCProof)) +generateBadgeProof pk (BadgeCredential masterKey signature badgeInfo) ph = + fmap (\p -> BadgeProof ph p badgeInfo) <$> bbsProofGen pk signature bbsBadgeHeader ph bbsBadgeDisclosedIndexes (badgeMessages masterKey badgeInfo) -- Recipient-side: verify a badge proof -verifyBadge :: BBSPublicKey -> SupporterBadge -> IO Bool -verifyBadge pk SupporterBadge {proof, presHeader, badgeExpiry, badgeType, badgeExtra} = - bbsProofVerify pk proof bbsBadgeHeader presHeader bbsBadgeDisclosedIndexes bbsBadgeMessageCount (badgeDisclosedMessages badgeExpiry badgeType badgeExtra) +verifyBadge :: BBSPublicKey -> Badge 'BCProof -> IO Bool +verifyBadge pk (BadgeProof ph@(BBSPresHeader phBytes) proof badgeInfo) + | badgePresHeaderAccepted (toBadgePresHeader phBytes) = + bbsProofVerify pk proof bbsBadgeHeader ph bbsBadgeDisclosedIndexes bbsBadgeMessageCount (badgeInfoMessages badgeInfo) + | otherwise = pure False -verifyBadge_ :: BBSPublicKey -> Maybe SupporterBadge -> IO Bool +verifyBadge_ :: BBSPublicKey -> Maybe (Badge 'BCProof) -> IO Bool verifyBadge_ = maybe (pure False) . verifyBadge -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 @@ -229,29 +291,80 @@ 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, Maybe Text) +-- (proof, pres_header, expiry, type, verified, extra, master_key, signature) +type BadgeRow = (Maybe ByteString, Maybe ByteString, Maybe UTCTime, Maybe Text, Maybe BoolInt, Maybe Text, Maybe ByteString, Maybe ByteString) -badgeToRow :: Maybe SupporterBadge -> Bool -> BadgeRow -badgeToRow (Just SupporterBadge {proof = BBSProof p, presHeader = BBSPresHeader ph, badgeExpiry, badgeType, badgeExtra}) verified = - (Just p, Just ph, badgeExpiry, Just (textEncode badgeType), Just (BI verified), Just badgeExtra) -badgeToRow _ _ = (Nothing, Nothing, Nothing, Nothing, Just (BI False), Nothing) +-- receive/store sites have a wire proof + a computed verified flag +badgeToRow :: Maybe (Badge 'BCProof) -> Bool -> BadgeRow +badgeToRow badge verified = localBadgeToRow $ (\b -> LocalBadge b (if verified then BSActive else BSFailed)) <$> badge + +localBadgeToRow :: Maybe LocalBadge -> BadgeRow +localBadgeToRow (Just (LocalBadge b st)) = case b of + BadgeCredential (BadgeMasterKey mk) (BBSSignature sg) BadgeInfo {badgeType, badgeExpiry, badgeExtra} -> + (Nothing, Nothing, badgeExpiry, Just (textEncode badgeType), Just (BI verified), Just badgeExtra, Just mk, Just sg) + BadgeProof (BBSPresHeader ph) (BBSProof p) BadgeInfo {badgeType, badgeExpiry, badgeExtra} -> + (Just p, Just ph, badgeExpiry, Just (textEncode badgeType), Just (BI verified), Just badgeExtra, Nothing, Nothing) + where + verified = st /= BSFailed +localBadgeToRow Nothing = (Nothing, Nothing, Nothing, Nothing, Just (BI False), Nothing, Nothing, Nothing) rowToBadge :: UTCTime -> BadgeRow -> Maybe LocalBadge -rowToBadge now (Just p, Just ph, badgeExpiry, Just btText, verified_, extra_) = do +rowToBadge now (p_, ph_, badgeExpiry, type_, verified_, extra_, mk_, sg_) = do + btText <- type_ bt <- textDecode btText - let b = SupporterBadge {proof = BBSProof p, presHeader = BBSPresHeader ph, badgeExpiry, badgeType = bt, badgeExtra = maybe "" id extra_} + let info = BadgeInfo {badgeType = bt, badgeExpiry, badgeExtra = maybe "" id extra_} verified = maybe False unBI verified_ - Just LocalBadge {badgeStatus = mkBadgeStatus now verified b, badge = b} -rowToBadge _ _ = Nothing + st = mkBadgeStatus now verified info + case (mk_, sg_, p_, ph_) of + (Just mk, Just sg, _, _) -> Just $ LocalBadge (BadgeCredential (BadgeMasterKey mk) (BBSSignature sg) info) st + (_, _, Just p, Just ph) -> Just $ LocalBadge (BadgeProof (BBSPresHeader ph) (BBSProof p) info) st + _ -> Nothing -- JSON $(JQ.deriveJSON (enumJSON $ dropPrefix "BS") ''BadgeStatus) -$(JQ.deriveJSON defaultJSON ''SupporterBadge) - -$(JQ.deriveJSON defaultJSON ''LocalBadge) +$(JQ.deriveJSON defaultJSON ''BadgeInfo) $(JQ.deriveJSON defaultJSON ''BadgeRequest) -$(JQ.deriveJSON defaultJSON ''BadgeCredential) +-- The Badge GADT (multi-constructor, different result types) is JSON-encoded via a plain mirror, +-- the codebase pattern for GADTs (see Messages/CIContent CIDeleted/CIStatus). deriveJSON does the work. + +data JBadge + = JBadgeCredential {masterKey :: BadgeMasterKey, signature :: BBSSignature, badgeInfo :: BadgeInfo} + | JBadgeProof {presHeader :: BBSPresHeader, proof :: BBSProof, badgeInfo :: BadgeInfo} + +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "JBadge") ''JBadge) + +jBadge :: Badge b -> JBadge +jBadge = \case + BadgeCredential mk sg i -> JBadgeCredential mk sg i + BadgeProof ph p i -> JBadgeProof ph p i + +instance ToJSON (Badge b) where + toJSON = toJSON . jBadge + toEncoding = toEncoding . jBadge + +instance FromJSON (Badge 'BCProof) where + parseJSON v = + parseJSON v >>= \case + JBadgeProof ph p i -> pure (BadgeProof ph p i) + _ -> fail "expected badge proof" + +instance FromJSON (Badge 'BCCredential) where + parseJSON v = + parseJSON v >>= \case + JBadgeCredential mk sg i -> pure (BadgeCredential mk sg i) + _ -> fail "expected badge credential" + +-- LocalBadge round-trips (the inner Badge tags which crypto it is). +instance ToJSON LocalBadge where + toJSON (LocalBadge b st) = J.object ["badge" .= b, "status" .= st] + +instance FromJSON LocalBadge where + parseJSON = J.withObject "LocalBadge" $ \o -> do + st <- o .: "status" + bv <- o .: "badge" + (flip LocalBadge st <$> (parseJSON bv :: Parser (Badge 'BCProof))) + <|> (flip LocalBadge st <$> (parseJSON bv :: Parser (Badge 'BCCredential))) diff --git a/src/Simplex/Chat/Mobile/Badges.hs b/src/Simplex/Chat/Mobile/Badges.hs index b509401ffa..26c0cbd7f0 100644 --- a/src/Simplex/Chat/Mobile/Badges.hs +++ b/src/Simplex/Chat/Mobile/Badges.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -62,7 +63,7 @@ cChatBadgeKeygen = cChatBadgeIssue :: CString -> IO CJSONString cChatBadgeIssue cReq = do bs <- B.packCString cReq - encodeResult @BadgeCredential =<< case J.eitherDecodeStrict' bs of + encodeResult @(Badge 'BCCredential) =<< case J.eitherDecodeStrict' bs of Left e -> pure $ BadgeError (T.pack e) Right BadgeIssueReq {keyPair = BBSKeyPair {secretKey, publicKey}, request} -> either (BadgeError . T.pack) BadgeResult <$> issueBadge secretKey publicKey (VerifiedBadgeRequest request) diff --git a/src/Simplex/Chat/Store/Connections.hs b/src/Simplex/Chat/Store/Connections.hs index 1b1f00866e..3c7aaaa419 100644 --- a/src/Simplex/Chat/Store/Connections.hs +++ b/src/Simplex/Chat/Store/Connections.hs @@ -116,7 +116,7 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do p.preferences, c.user_preferences, c.created_at, c.updated_at, c.chat_ts, c.conn_full_link_to_connect, c.conn_short_link_to_connect, c.welcome_shared_msg_id, c.request_shared_msg_id, c.contact_request_id, c.contact_group_member_id, c.contact_grp_inv_sent, c.grp_direct_inv_link, c.grp_direct_inv_from_group_id, c.grp_direct_inv_from_group_member_id, c.grp_direct_inv_from_member_conn_id, c.grp_direct_inv_started_connection, c.ui_themes, c.chat_deleted, c.custom_data, c.chat_item_ttl, - p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra + p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature FROM contacts c JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id WHERE c.user_id = ? AND c.contact_id = ? AND c.contact_status = ? AND c.deleted = 0 @@ -156,13 +156,13 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do mu.member_status, mu.show_messages, mu.member_restriction, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, -- GroupInfo {membership = GroupMember {memberProfile}} pu.display_name, pu.full_name, pu.short_descr, pu.image, pu.contact_link, pu.chat_peer_type, pu.local_alias, pu.preferences, - pu.badge_proof, pu.badge_pres_header, pu.badge_expiry, pu.badge_type, pu.badge_verified, pu.badge_extra, + pu.badge_proof, pu.badge_pres_header, pu.badge_expiry, pu.badge_type, pu.badge_verified, pu.badge_extra, pu.badge_master_key, pu.badge_signature, mu.created_at, mu.updated_at, mu.support_chat_ts, mu.support_chat_items_unread, mu.support_chat_items_member_attention, mu.support_chat_items_mentions, mu.support_chat_last_msg_from_member_ts, mu.member_pub_key, mu.relay_link, -- from GroupMember m.group_member_id, m.group_id, m.index_in_group, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, m.member_restriction, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences, - p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, + p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, m.created_at, m.updated_at, m.support_chat_ts, m.support_chat_items_unread, m.support_chat_items_member_attention, m.support_chat_items_mentions, m.support_chat_last_msg_from_member_ts, m.member_pub_key, m.relay_link FROM group_members m diff --git a/src/Simplex/Chat/Store/ContactRequest.hs b/src/Simplex/Chat/Store/ContactRequest.hs index 3d084acb4d..1963b5f837 100644 --- a/src/Simplex/Chat/Store/ContactRequest.hs +++ b/src/Simplex/Chat/Store/ContactRequest.hs @@ -116,7 +116,7 @@ createOrUpdateContactRequest cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, ct.conn_full_link_to_connect, ct.conn_short_link_to_connect, ct.welcome_shared_msg_id, ct.request_shared_msg_id, ct.contact_request_id, ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.grp_direct_inv_link, ct.grp_direct_inv_from_group_id, ct.grp_direct_inv_from_group_member_id, ct.grp_direct_inv_from_member_conn_id, ct.grp_direct_inv_started_connection, ct.ui_themes, ct.chat_deleted, ct.custom_data, ct.chat_item_ttl, - cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, + cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, cp.badge_master_key, cp.badge_signature, -- Connection c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.xcontact_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, c.quota_err_counter, @@ -152,7 +152,7 @@ createOrUpdateContactRequest cr.pq_support, cr.welcome_shared_msg_id, cr.request_shared_msg_id, p.preferences, cr.created_at, cr.updated_at, cr.peer_chat_min_version, cr.peer_chat_max_version, - p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra + p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature FROM contact_requests cr JOIN contact_profiles p USING (contact_profile_id) WHERE cr.user_id = ? @@ -168,7 +168,7 @@ createOrUpdateContactRequest liftIO $ DB.execute db - "INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, user_id, local_alias, preferences, created_at, updated_at, badge_proof, badge_pres_header, badge_expiry, badge_type, badge_verified, badge_extra) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" + "INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, user_id, local_alias, preferences, created_at, updated_at, badge_proof, badge_pres_header, badge_expiry, badge_type, badge_verified, badge_extra, badge_master_key, badge_signature) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" ((displayName, fullName, shortDescr, image, contactLink, userId) :. ("" :: LocalAlias, preferences, currentTs, currentTs) :. badgeToRow badge badgeVerified) profileId <- liftIO $ insertedRowId db liftIO $ @@ -246,7 +246,9 @@ createOrUpdateContactRequest badge_expiry = ?, badge_type = ?, badge_verified = ?, - badge_extra = ? + badge_extra = ?, + badge_master_key = ?, + badge_signature = ? WHERE contact_profile_id IN ( SELECT contact_profile_id FROM contact_requests diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs index 7bca2e34ce..381fd5ab8d 100644 --- a/src/Simplex/Chat/Store/Direct.hs +++ b/src/Simplex/Chat/Store/Direct.hs @@ -320,7 +320,7 @@ getContactByConnReqHash db cxt user@User {userId} cReqHash1 cReqHash2 = do cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, ct.conn_full_link_to_connect, ct.conn_short_link_to_connect, ct.welcome_shared_msg_id, ct.request_shared_msg_id, ct.contact_request_id, ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.grp_direct_inv_link, ct.grp_direct_inv_from_group_id, ct.grp_direct_inv_from_group_member_id, ct.grp_direct_inv_from_member_conn_id, ct.grp_direct_inv_started_connection, ct.ui_themes, ct.chat_deleted, ct.custom_data, ct.chat_item_ttl, - cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, + cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, cp.badge_master_key, cp.badge_signature, -- Connection c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.xcontact_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, c.quota_err_counter, @@ -712,7 +712,7 @@ updateContactProfile_' db userId profileId Profile {displayName, fullName, short [sql| UPDATE contact_profiles SET display_name = ?, full_name = ?, short_descr = ?, image = ?, contact_link = ?, preferences = ?, chat_peer_type = ?, updated_at = ?, - badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?, badge_extra = ? + badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?, badge_extra = ?, badge_master_key = ?, badge_signature = ? WHERE user_id = ? AND contact_profile_id = ? |] ((displayName, fullName, shortDescr, image, contactLink, preferences, peerType, updatedAt) :. badgeToRow badge badgeVerified :. (userId, profileId)) @@ -730,7 +730,7 @@ updateMemberContactProfileReset_' db userId profileId Profile {displayName, full [sql| UPDATE contact_profiles SET display_name = ?, full_name = ?, short_descr = ?, image = ?, contact_link = NULL, preferences = NULL, updated_at = ?, - badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?, badge_extra = ? + badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?, badge_extra = ?, badge_master_key = ?, badge_signature = ? WHERE user_id = ? AND contact_profile_id = ? |] ((displayName, fullName, shortDescr, image, updatedAt) :. badgeToRow badge badgeVerified :. (userId, profileId)) @@ -748,7 +748,7 @@ updateMemberContactProfile_' db userId profileId Profile {displayName, fullName, [sql| UPDATE contact_profiles SET display_name = ?, full_name = ?, short_descr = ?, image = ?, updated_at = ?, - badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?, badge_extra = ? + badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?, badge_extra = ?, badge_master_key = ?, badge_signature = ? WHERE user_id = ? AND contact_profile_id = ? |] ((displayName, fullName, shortDescr, image, updatedAt) :. badgeToRow badge badgeVerified :. (userId, profileId)) @@ -809,7 +809,7 @@ contactRequestQuery = cr.pq_support, cr.welcome_shared_msg_id, cr.request_shared_msg_id, p.preferences, cr.created_at, cr.updated_at, cr.peer_chat_min_version, cr.peer_chat_max_version, - p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra + p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature FROM contact_requests cr JOIN contact_profiles p USING (contact_profile_id) |] @@ -929,7 +929,7 @@ getContact_ db cxt user@User {userId} contactId deleted = do cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, ct.conn_full_link_to_connect, ct.conn_short_link_to_connect, ct.welcome_shared_msg_id, ct.request_shared_msg_id, ct.contact_request_id, ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.grp_direct_inv_link, ct.grp_direct_inv_from_group_id, ct.grp_direct_inv_from_group_member_id, ct.grp_direct_inv_from_member_conn_id, ct.grp_direct_inv_started_connection, ct.ui_themes, ct.chat_deleted, ct.custom_data, ct.chat_item_ttl, - cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, + cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, cp.badge_master_key, cp.badge_signature, -- Connection c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.xcontact_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, c.quota_err_counter, diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 3bce76b87a..811bd80846 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -1734,7 +1734,7 @@ createJoiningMember liftIO $ DB.execute db - "INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, user_id, preferences, created_at, updated_at, badge_proof, badge_pres_header, badge_expiry, badge_type, badge_verified, badge_extra) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" + "INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, user_id, preferences, created_at, updated_at, badge_proof, badge_pres_header, badge_expiry, badge_type, badge_verified, badge_extra, badge_master_key, badge_signature) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" ((displayName, fullName, shortDescr, image, contactLink, userId, preferences, currentTs, currentTs) :. badgeToRow badge badgeVerified) profileId <- liftIO $ insertedRowId db case cReqMemberId_ of @@ -2095,7 +2095,7 @@ createNewMemberProfile_ db User {userId} Profile {displayName, fullName, shortDe badgeVerified <- verifyBadge_ srvBadgePublicKey badge DB.execute db - "INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, user_id, preferences, created_at, updated_at, badge_proof, badge_pres_header, badge_expiry, badge_type, badge_verified, badge_extra) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" + "INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, user_id, preferences, created_at, updated_at, badge_proof, badge_pres_header, badge_expiry, badge_type, badge_verified, badge_extra, badge_master_key, badge_signature) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" ((displayName, fullName, shortDescr, image, contactLink, userId, preferences, createdAt, createdAt) :. badgeToRow badge badgeVerified) profileId <- insertedRowId db pure $ Right (ldn, profileId, badgeVerified) diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 8927ef2ec0..b6866045fd 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -707,7 +707,7 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe m.group_member_id, m.group_id, m.index_in_group, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, m.member_restriction, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences, - p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, + p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, m.created_at, m.updated_at, m.support_chat_ts, m.support_chat_items_unread, m.support_chat_items_member_attention, m.support_chat_items_mentions, m.support_chat_last_msg_from_member_ts, m.member_pub_key, m.relay_link FROM group_members m @@ -1131,7 +1131,7 @@ getContactRequestChatPreviews_ db User {userId} pagination clq = do cr.pq_support, cr.welcome_shared_msg_id, cr.request_shared_msg_id, p.preferences, cr.created_at, cr.updated_at, cr.peer_chat_min_version, cr.peer_chat_max_version, - p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra + p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature FROM contact_requests cr JOIN contact_profiles p ON p.contact_profile_id = cr.contact_profile_id JOIN user_contact_links uc ON uc.user_contact_link_id = cr.user_contact_link_id @@ -3041,7 +3041,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do m.group_member_id, m.group_id, m.index_in_group, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, m.member_restriction, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences, - p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, + p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, m.created_at, m.updated_at, m.support_chat_ts, m.support_chat_items_unread, m.support_chat_items_member_attention, m.support_chat_items_mentions, m.support_chat_last_msg_from_member_ts, m.member_pub_key, m.relay_link, -- quoted ChatItem @@ -3050,14 +3050,14 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do rm.group_member_id, rm.group_id, rm.index_in_group, rm.member_id, rm.peer_chat_min_version, rm.peer_chat_max_version, rm.member_role, rm.member_category, rm.member_status, rm.show_messages, rm.member_restriction, rm.invited_by, rm.invited_by_group_member_id, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id, rp.display_name, rp.full_name, rp.short_descr, rp.image, rp.contact_link, rp.chat_peer_type, rp.local_alias, rp.preferences, - rp.badge_proof, rp.badge_pres_header, rp.badge_expiry, rp.badge_type, rp.badge_verified, rp.badge_extra, + rp.badge_proof, rp.badge_pres_header, rp.badge_expiry, rp.badge_type, rp.badge_verified, rp.badge_extra, rp.badge_master_key, rp.badge_signature, rm.created_at, rm.updated_at, rm.support_chat_ts, rm.support_chat_items_unread, rm.support_chat_items_member_attention, rm.support_chat_items_mentions, rm.support_chat_last_msg_from_member_ts, rm.member_pub_key, rm.relay_link, -- deleted by GroupMember dbm.group_member_id, dbm.group_id, dbm.index_in_group, dbm.member_id, dbm.peer_chat_min_version, dbm.peer_chat_max_version, dbm.member_role, dbm.member_category, dbm.member_status, dbm.show_messages, dbm.member_restriction, dbm.invited_by, dbm.invited_by_group_member_id, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id, dbp.display_name, dbp.full_name, dbp.short_descr, dbp.image, dbp.contact_link, dbp.chat_peer_type, dbp.local_alias, dbp.preferences, - dbp.badge_proof, dbp.badge_pres_header, dbp.badge_expiry, dbp.badge_type, dbp.badge_verified, dbp.badge_extra, + dbp.badge_proof, dbp.badge_pres_header, dbp.badge_expiry, dbp.badge_type, dbp.badge_verified, dbp.badge_extra, dbp.badge_master_key, dbp.badge_signature, dbm.created_at, dbm.updated_at, dbm.support_chat_ts, dbm.support_chat_items_unread, dbm.support_chat_items_member_attention, dbm.support_chat_items_mentions, dbm.support_chat_last_msg_from_member_ts, dbm.member_pub_key, dbm.relay_link FROM chat_items i 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 bacf3eb482..25bf07a66a 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/M20260516_supporter_badges.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20260516_supporter_badges.hs @@ -15,11 +15,15 @@ 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 SMALLINT NOT NULL DEFAULT 0; ALTER TABLE contact_profiles ADD COLUMN badge_extra TEXT; +ALTER TABLE contact_profiles ADD COLUMN badge_master_key BYTEA; +ALTER TABLE contact_profiles ADD COLUMN badge_signature BYTEA; |] down_m20260516_supporter_badges :: Text down_m20260516_supporter_badges = [r| +ALTER TABLE contact_profiles DROP COLUMN badge_signature; +ALTER TABLE contact_profiles DROP COLUMN badge_master_key; ALTER TABLE contact_profiles DROP COLUMN badge_extra; ALTER TABLE contact_profiles DROP COLUMN badge_verified; ALTER TABLE contact_profiles DROP COLUMN badge_type; 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 05d46c8a34..d60c0037ee 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/M20260516_supporter_badges.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20260516_supporter_badges.hs @@ -14,11 +14,15 @@ 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 NOT NULL DEFAULT 0; ALTER TABLE contact_profiles ADD COLUMN badge_extra TEXT; +ALTER TABLE contact_profiles ADD COLUMN badge_master_key BLOB; +ALTER TABLE contact_profiles ADD COLUMN badge_signature BLOB; |] down_m20260516_supporter_badges :: Query down_m20260516_supporter_badges = [sql| +ALTER TABLE contact_profiles DROP COLUMN badge_signature; +ALTER TABLE contact_profiles DROP COLUMN badge_master_key; ALTER TABLE contact_profiles DROP COLUMN badge_extra; ALTER TABLE contact_profiles DROP COLUMN badge_verified; ALTER TABLE contact_profiles DROP COLUMN badge_type; diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index 579261e9ba..bbf48a31e8 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -418,7 +418,7 @@ createContact_ db User {userId} Profile {displayName, fullName, shortDescr, imag badgeVerified <- verifyBadge_ srvBadgePublicKey badge DB.execute db - "INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, chat_peer_type, user_id, local_alias, preferences, created_at, updated_at, badge_proof, badge_pres_header, badge_expiry, badge_type, badge_verified, badge_extra) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" + "INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, chat_peer_type, user_id, local_alias, preferences, created_at, updated_at, badge_proof, badge_pres_header, badge_expiry, badge_type, badge_verified, badge_extra, badge_master_key, badge_signature) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" ((displayName, fullName, shortDescr, image, contactLink, peerType) :. (userId, localAlias, preferences, currentTs, currentTs) :. badgeToRow badge badgeVerified) profileId <- insertedRowId db DB.execute @@ -525,7 +525,7 @@ getProfileById db userId profileId = do db [sql| SELECT cp.contact_profile_id, cp.display_name, cp.full_name, cp.short_descr, cp.image, cp.contact_link, cp.chat_peer_type, cp.local_alias, cp.preferences, - cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra + cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, cp.badge_master_key, cp.badge_signature FROM contact_profiles cp WHERE cp.user_id = ? AND cp.contact_profile_id = ? |] @@ -749,7 +749,7 @@ groupMemberQuery = SELECT m.group_member_id, m.group_id, m.index_in_group, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, m.member_restriction, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences, - p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, + p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, m.created_at, m.updated_at, m.support_chat_ts, m.support_chat_items_unread, m.support_chat_items_member_attention, m.support_chat_items_mentions, m.support_chat_last_msg_from_member_ts, m.member_pub_key, m.relay_link, c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.xcontact_id, c.custom_user_profile_id, @@ -794,7 +794,7 @@ groupInfoQueryFields = mu.group_member_id, mu.group_id, mu.index_in_group, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category, mu.member_status, mu.show_messages, mu.member_restriction, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, pu.display_name, pu.full_name, pu.short_descr, pu.image, pu.contact_link, pu.chat_peer_type, pu.local_alias, pu.preferences, - pu.badge_proof, pu.badge_pres_header, pu.badge_expiry, pu.badge_type, pu.badge_verified, pu.badge_extra, + pu.badge_proof, pu.badge_pres_header, pu.badge_expiry, pu.badge_type, pu.badge_verified, pu.badge_extra, pu.badge_master_key, pu.badge_signature, mu.created_at, mu.updated_at, mu.support_chat_ts, mu.support_chat_items_unread, mu.support_chat_items_member_attention, mu.support_chat_items_mentions, mu.support_chat_last_msg_from_member_ts, mu.member_pub_key, mu.relay_link |] diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index beb9cb31a0..43a1dab873 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 (BadgeStatus (..), LocalBadge (..), SupporterBadge, mkBadgeStatus, srvBadgePublicKey, verifyBadge) +import Simplex.Chat.Badges (Badge (..), BadgeCrypto (..), BadgeInfo (..), BadgeStatus (..), LocalBadge (..), localBadgeInfo, localBadgeStatus, mkBadgeStatus, srvBadgePublicKey, verifyBadge) import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared import Simplex.Chat.Types.UITheme @@ -687,7 +687,7 @@ data Profile = Profile contactLink :: Maybe ConnLinkContact, preferences :: Maybe Preferences, peerType :: Maybe ChatPeerType, - badge :: Maybe SupporterBadge + badge :: Maybe (Badge 'BCProof) -- fields that should not be read into this data type to prevent sending them as part of profile to contacts: -- - contact_profile_id -- - incognito @@ -772,18 +772,23 @@ toLocalProfile :: ProfileId -> Profile -> LocalAlias -> UTCTime -> Bool -> Local 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 - localBadge = (\b -> LocalBadge {badgeStatus = mkBadgeStatus now verified b, badge = b}) <$> badge + localBadge = (\b@(BadgeProof _ _ info) -> LocalBadge b (mkBadgeStatus now verified info)) <$> badge fromLocalProfile :: LocalProfile -> Profile fromLocalProfile LocalProfile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, localBadge} = - Profile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, badge = (\LocalBadge {badge} -> badge) <$> localBadge} + Profile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, badge = localBadge >>= wireBadge} + where + wireBadge :: LocalBadge -> Maybe (Badge 'BCProof) + wireBadge (LocalBadge b _) = case b of + BadgeProof {} -> Just b + BadgeCredential {} -> 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 (badgeStatus /= BSFailed) + (Just lb, Just (BadgeProof _ _ newInfo)) + | localBadgeInfo lb == newInfo -> pure (localBadgeStatus lb /= BSFailed) (_, Just newB) -> verifyBadge srvBadgePublicKey newB data GroupType diff --git a/tests/BadgeTests.hs b/tests/BadgeTests.hs index 085125afe4..75c1ac0628 100644 --- a/tests/BadgeTests.hs +++ b/tests/BadgeTests.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -21,32 +23,38 @@ badgeTests = do it "should treat lifetime badges as always active" testLifetimeBadge it "should accept unknown badge types" testUnknownBadgeType +proofOf :: Badge 'BCProof -> BBSProof +proofOf (BadgeProof _ p _) = p + +proofInfo :: Badge 'BCProof -> BadgeInfo +proofInfo (BadgeProof _ _ i) = i + testFullWorkflow :: IO () testFullWorkflow = do Right (sk, pk) <- bbsKeyGen drg <- C.newRandom mk <- generateMasterKey drg - let req = BadgeRequest {masterKey = mk, badgeType = BTSupporter, expiry = Just futureTime} + let req = BadgeRequest {masterKey = mk, badgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = Just futureTime, badgeExtra = ""}} Just vreq <- verifyPayment (BPRedeemCode "TEST") req Right cred <- issueBadge sk pk vreq - let BadgeCredential {masterKey = mk'} = cred + let BadgeCredential mk' _ _ = cred mk' `shouldBe` mk - verifyBadgeSignature pk cred >>= (`shouldBe` True) + verifyCredential pk cred >>= (`shouldBe` True) Right badge <- generateBadgeProof pk cred (BBSPresHeader "nonce-1") verifyBadge pk badge >>= (`shouldBe` True) Right badge2 <- generateBadgeProof pk cred (BBSPresHeader "nonce-2") verifyBadge pk badge2 >>= (`shouldBe` True) - proof badge `shouldNotBe` proof badge2 + proofOf badge `shouldNotBe` proofOf badge2 testTamperedType :: IO () testTamperedType = do - (pk, SupporterBadge {proof, presHeader, badgeExpiry}) <- issueBadgeProof BTSupporter (Just futureTime) - verifyBadge pk (SupporterBadge {proof, presHeader, badgeExpiry, badgeType = BTBusiness, badgeExtra = ""}) >>= (`shouldBe` False) + (pk, BadgeProof ph p info) <- issueBadgeProof BTSupporter (Just futureTime) + verifyBadge pk (BadgeProof ph p info {badgeType = BTBusiness}) >>= (`shouldBe` False) testTamperedExpiry :: IO () testTamperedExpiry = do - (pk, SupporterBadge {proof, presHeader, badgeType}) <- issueBadgeProof BTSupporter (Just futureTime) - verifyBadge pk (SupporterBadge {proof, presHeader, badgeExpiry = Just pastTime, badgeType, badgeExtra = ""}) >>= (`shouldBe` False) + (pk, BadgeProof ph p info) <- issueBadgeProof BTSupporter (Just futureTime) + verifyBadge pk (BadgeProof ph p info {badgeExpiry = Just pastTime}) >>= (`shouldBe` False) testWrongKey :: IO () testWrongKey = do @@ -57,18 +65,18 @@ testWrongKey = do testExpiryCheck :: IO () testExpiryCheck = do now <- getCurrentTime - (_, past) <- issueBadgeProof BTSupporter (Just pastTime) - mkBadgeStatus now True past `shouldBe` BSExpired - (_, future) <- issueBadgeProof BTSupporter (Just futureTime) - mkBadgeStatus now True future `shouldBe` BSActive - mkBadgeStatus now False future `shouldBe` BSFailed + let pastInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = Just pastTime, badgeExtra = ""} + futureInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = Just futureTime, badgeExtra = ""} + mkBadgeStatus now True pastInfo `shouldBe` BSExpired + mkBadgeStatus now True futureInfo `shouldBe` BSActive + mkBadgeStatus now False futureInfo `shouldBe` BSFailed testLifetimeBadge :: IO () testLifetimeBadge = do now <- getCurrentTime (pk, badge) <- issueBadgeProof BTInvestor Nothing verifyBadge pk badge >>= (`shouldBe` True) - mkBadgeStatus now True badge `shouldBe` BSActive + mkBadgeStatus now True (proofInfo badge) `shouldBe` BSActive testUnknownBadgeType :: IO () testUnknownBadgeType = do @@ -83,12 +91,12 @@ futureTime = posixSecondsToUTCTime 4102444800 -- 2099-12-31 pastTime :: UTCTime pastTime = posixSecondsToUTCTime 1577836800 -- 2020-01-01 -issueBadgeProof :: BadgeType -> Maybe UTCTime -> IO (BBSPublicKey, SupporterBadge) +issueBadgeProof :: BadgeType -> Maybe UTCTime -> IO (BBSPublicKey, Badge 'BCProof) issueBadgeProof bt expiry = do Right (sk, pk) <- bbsKeyGen drg <- C.newRandom mk <- generateMasterKey drg - let vreq = VerifiedBadgeRequest BadgeRequest {masterKey = mk, badgeType = bt, expiry} + let vreq = VerifiedBadgeRequest BadgeRequest {masterKey = mk, badgeInfo = BadgeInfo {badgeType = bt, badgeExpiry = expiry, badgeExtra = ""}} Right cred <- issueBadge sk pk vreq Right badge <- generateBadgeProof pk cred (BBSPresHeader "test-nonce") pure (pk, badge) diff --git a/tests/MobileTests.hs b/tests/MobileTests.hs index 46fc17c3c8..fcff60e3bc 100644 --- a/tests/MobileTests.hs +++ b/tests/MobileTests.hs @@ -32,7 +32,7 @@ import Foreign.Storable (peek) import GHC.IO.Encoding (setLocaleEncoding, setFileSystemEncoding, setForeignEncoding) import JSONFixtures import Simplex.Chat -import Simplex.Chat.Badges (BadgeRequest (..), BadgeType (..), generateMasterKey, verifyBadgeSignature) +import Simplex.Chat.Badges (BadgeInfo (..), BadgeRequest (..), BadgeType (..), generateMasterKey, verifyCredential) import Simplex.Chat.Controller (ChatController (..), ChatDatabase (..)) import Simplex.Chat.Mobile hiding (error) import Simplex.Chat.Mobile.Badges hiding (error) @@ -321,9 +321,9 @@ testBadgeKeygenIssueCApi _ = do keyPair <- ffiResult =<< (peekCString =<< cChatBadgeKeygen) let BBSKeyPair {publicKey} = keyPair mk <- generateMasterKey g - let req = BadgeIssueReq {keyPair, request = BadgeRequest {masterKey = mk, badgeType = BTSupporter, expiry = Nothing}} + let req = BadgeIssueReq {keyPair, request = BadgeRequest {masterKey = mk, badgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = Nothing, badgeExtra = ""}}} cred <- ffiResult =<< (peekCString =<< cChatBadgeIssue =<< newCString (LB.unpack (J.encode req))) - verifyBadgeSignature publicKey cred `shouldReturn` True + verifyCredential publicKey cred `shouldReturn` True -- Decode an FFI `BadgeResult` envelope, returning the result or failing on error. ffiResult :: FromJSON r => String -> IO r