dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-07-20 02:41:31 +00:00
Code Issues Packages Projects Releases Wiki Activity

badges in profiles

Browse Source
This commit is contained in:
Evgeny @ SimpleX Chat
2026-06-03 21:24:06 +00:00
parent d43cefaeb9
commit 25bc863676
15 changed files with 59 additions and 35 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/Badges.hs
+25 -7
View File
@@ -6,6 +6,8 @@
module Simplex.Chat.Badges
( BadgeType (..),
BadgeStatus (..),
LocalBadge (..),
BadgePurchase (..),
BadgeMasterKey (..),
BadgeRequest (..),
@@ -19,7 +21,7 @@ module Simplex.Chat.Badges
verifyBadgeSignature,
generateBadgeProof,
verifyBadge,
isBadgeExpired,
mkBadgeStatus,
) where
import Data.Aeson (FromJSON (..), ToJSON (..))
@@ -33,7 +35,7 @@ import Data.Time.Clock (UTCTime)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.BBS
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON)
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
-- Badge type
@@ -66,6 +68,23 @@ instance ToJSON BadgeType where
instance FromJSON BadgeType where
parseJSON = textParseJSON "BadgeType"
-- Badge status and local badge
data BadgeStatus = BSActive | BSExpired | BSFailed
deriving (Eq, Show)
data LocalBadge = LocalBadge
{ badgeStatus :: BadgeStatus,
badge :: SupporterBadge
}
deriving (Eq, Show)
mkBadgeStatus :: UTCTime -> Bool -> SupporterBadge -> BadgeStatus
mkBadgeStatus now verified SupporterBadge {badgeExpiry}
| not verified = BSFailed
| maybe False (now >) badgeExpiry = BSExpired
| otherwise = BSActive
-- Payment proof
data BadgePurchase
@@ -170,11 +189,10 @@ verifyBadge :: BBSPublicKey -> SupporterBadge -> IO Bool
verifyBadge pk SupporterBadge {proof, presHeader, badgeExpiry, badgeType} =
bbsProofVerify pk proof bbsBadgeHeader presHeader bbsBadgeDisclosedIndexes bbsBadgeMessageCount (badgeDisclosedMessages badgeExpiry badgeType)
-- Check if badge has expired
-- JSON
isBadgeExpired :: UTCTime -> SupporterBadge -> Bool
isBadgeExpired now SupporterBadge {badgeExpiry} = maybe False (now >) badgeExpiry
-- JSON for profile transmission
$(JQ.deriveJSON (enumJSON $ dropPrefix "BS") ''BadgeStatus)
$(JQ.deriveJSON defaultJSON ''SupporterBadge)
$(JQ.deriveJSON defaultJSON ''LocalBadge)
src/Simplex/Chat/Core.hs
+1 -1
View File
@@ -138,7 +138,7 @@ createActiveUser cc CoreChatOpts {chatRelay} = \case
loop = do
displayName <- T.pack <$> withPrompt "display name: " getLine
createUser loop $ mkProfile displayName
mkProfile displayName = Profile {displayName, fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing}
mkProfile displayName = Profile {displayName, fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing, badge = Nothing}
createUser onError p =
execChatCommand' (CreateActiveUser NewUser {profile = Just p, pastTimestamp = False, userChatRelay = chatRelay}) 0 `runReaderT` cc >>= \case
Right (CRActiveUser user) -> pure user
src/Simplex/Chat/Library/Commands.hs
+2 -2
View File
@@ -5378,7 +5378,7 @@ chatCommandP =
quoted = A.char '\'' *> A.takeTill (== '\'') <* A.char '\''
newUserP userChatRelay = do
(cName, shortDescr) <- profileNameDescr
let profile = Just Profile {displayName = cName, fullName = "", shortDescr, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing}
let profile = Just Profile {displayName = cName, fullName = "", shortDescr, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing, badge = Nothing}
pure NewUser {profile, pastTimestamp = False, userChatRelay}
newBotUserP = do
files_ <- optional $ "files=" *> onOffP <* A.space
@@ -5386,7 +5386,7 @@ chatCommandP =
let preferences = case files_ of
Just True -> Nothing
_ -> Just (emptyChatPrefs :: Preferences) {files = Just FilesPreference {allow = FANo}}
profile = Just Profile {displayName = cName, fullName = "", shortDescr, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences}
profile = Just Profile {displayName = cName, fullName = "", shortDescr, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences, badge = Nothing}
pure NewUser {profile, pastTimestamp = False, userChatRelay = False}
jsonP :: J.FromJSON a => Parser a
jsonP = J.eitherDecodeStrict' <$?> A.takeByteString
src/Simplex/Chat/Library/Internal.hs
+5 -3
View File
File diff suppressed because one or more lines are too long
src/Simplex/Chat/ProfileGenerator.hs
+1 -1
View File
@@ -10,7 +10,7 @@ generateRandomProfile :: IO Profile
generateRandomProfile = do
adjective <- pick adjectives
noun <- pickNoun adjective 2
pure $ Profile {displayName = adjective <> noun, fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing}
pure $ Profile {displayName = adjective <> noun, fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing, badge = Nothing}
where
pick :: [a] -> IO a
pick xs = (xs !!) <$> randomRIO (0, length xs - 1)
src/Simplex/Chat/Store/Connections.hs
+1 -1
View File
@@ -121,7 +121,7 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
(userId, contactId, CSActive)
toContact' :: Int64 -> Connection -> [ChatTagId] -> ContactRow' -> Contact
toContact' 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)) =
let profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, preferences, localAlias}
let profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, badge = Nothing, preferences, localAlias}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite}
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito conn
activeConn = Just conn
src/Simplex/Chat/Store/Profiles.hs
+1 -1
View File
@@ -366,7 +366,7 @@ getUserContactProfiles db User {userId} =
(Only userId)
where
toContactProfile :: (ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences) -> Profile
toContactProfile (displayName, fullName, shortDescr, image, contactLink, peerType, preferences) = Profile {displayName, fullName, shortDescr, image, contactLink, peerType, preferences}
toContactProfile (displayName, fullName, shortDescr, image, contactLink, peerType, preferences) = Profile {displayName, fullName, shortDescr, image, contactLink, peerType, preferences, badge = Nothing}
createUserContactLink :: DB.Connection -> User -> ConnId -> CreatedLinkContact -> SubscriptionMode -> ExceptT StoreError IO ()
createUserContactLink db User {userId} agentConnId (CCLink cReq shortLink) subMode =
src/Simplex/Chat/Store/Shared.hs
+4 -4
View File
@@ -490,7 +490,7 @@ type ContactRow = Only ContactId :. ContactRow'
toContact :: VersionRangeChat -> User -> [ChatTagId] -> ContactRow :. MaybeConnectionRow -> Contact
toContact 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)) :. connRow) =
let profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, preferences, localAlias}
let profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, badge = Nothing, preferences, localAlias}
activeConn = toMaybeConnection vr connRow
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite}
incognito = maybe False connIncognito activeConn
@@ -531,7 +531,7 @@ type ContactRequestRow = (Int64, ContactName, AgentInvId, Maybe ContactId, Maybe
toContactRequest :: ContactRequestRow -> UserContactRequest
toContactRequest ((contactRequestId, localDisplayName, agentInvitationId, contactId_, businessGroupId_, userContactLinkId_) :. (profileId, displayName, fullName, shortDescr, image, contactLink, peerType) :. (xContactId, pqSupport, welcomeSharedMsgId, requestSharedMsgId, preferences, createdAt, updatedAt, minVer, maxVer)) = do
let profile = Profile {displayName, fullName, shortDescr, image, contactLink, peerType, preferences}
let profile = Profile {displayName, fullName, shortDescr, image, contactLink, peerType, preferences, badge = Nothing}
cReqChatVRange = fromMaybe (versionToRange maxVer) $ safeVersionRange minVer maxVer
in UserContactRequest {contactRequestId, agentInvitationId, contactId_, businessGroupId_, userContactLinkId_, cReqChatVRange, localDisplayName, profileId, profile, xContactId, pqSupport, welcomeSharedMsgId, requestSharedMsgId, createdAt, updatedAt}
@@ -549,7 +549,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, preferences = userPreferences, localAlias = ""}
profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, badge = Nothing, preferences = userPreferences, localAlias = ""}
fullPreferences = fullPreferences' userPreferences
viewPwdHash = UserPwdHash <$> viewPwdHash_ <*> viewPwdSalt_
@@ -762,7 +762,7 @@ toContactMember vr User {userContactId} (memberRow :. connRow) =
rowToLocalProfile :: ProfileRow -> LocalProfile
rowToLocalProfile (profileId, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, preferences) =
LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, preferences}
LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, badge = Nothing, localAlias, preferences}
toBusinessChatInfo :: BusinessChatInfoRow -> Maybe BusinessChatInfo
toBusinessChatInfo (Just chatType, Just businessId, Just customerId) = Just BusinessChatInfo {chatType, businessId, customerId}
src/Simplex/Chat/Types.hs
+7 -4
View File
@@ -47,6 +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.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.Chat.Types.UITheme
@@ -685,7 +686,8 @@ data Profile = Profile
image :: Maybe ImageData,
contactLink :: Maybe ConnLinkContact,
preferences :: Maybe Preferences,
peerType :: Maybe ChatPeerType
peerType :: Maybe ChatPeerType,
badge :: Maybe SupporterBadge
-- fields that should not be read into this data type to prevent sending them as part of profile to contacts:
-- - contact_profile_id
-- - incognito
@@ -718,7 +720,7 @@ instance TextEncoding ChatPeerType where
profileFromName :: ContactName -> Profile
profileFromName displayName =
Profile {displayName, fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, preferences = Nothing, peerType = Nothing}
Profile {displayName, fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, preferences = Nothing, peerType = Nothing, badge = Nothing}
-- check if profiles match ignoring preferences
profilesMatch :: LocalProfile -> LocalProfile -> Bool
@@ -758,6 +760,7 @@ data LocalProfile = LocalProfile
contactLink :: Maybe ConnLinkContact,
preferences :: Maybe Preferences,
peerType :: Maybe ChatPeerType,
badge :: Maybe LocalBadge,
localAlias :: LocalAlias
}
deriving (Eq, Show)
@@ -767,11 +770,11 @@ 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, localAlias}
LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, preferences, peerType, badge = Nothing, localAlias}
fromLocalProfile :: LocalProfile -> Profile
fromLocalProfile LocalProfile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType} =
Profile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType}
Profile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, badge = Nothing}
data GroupType
= GTChannel
tests/BadgeTests.hs
+6 -5
View File
@@ -17,8 +17,8 @@ badgeTests = do
it "should reject badge with tampered type" testTamperedType
it "should reject badge with tampered expiry" testTamperedExpiry
it "should reject badge with wrong server key" testWrongKey
it "should check expiry dates correctly" testExpiryCheck
it "should treat lifetime badges as never expired" testLifetimeBadge
it "should compute badge status correctly" testExpiryCheck
it "should treat lifetime badges as always active" testLifetimeBadge
it "should accept unknown badge types" testUnknownBadgeType
testFullWorkflow :: IO ()
@@ -58,16 +58,17 @@ testExpiryCheck :: IO ()
testExpiryCheck = do
now <- getCurrentTime
(_, past) <- issueBadgeProof BTSupporter (Just pastTime)
isBadgeExpired now past `shouldBe` True
mkBadgeStatus now True past `shouldBe` BSExpired
(_, future) <- issueBadgeProof BTSupporter (Just futureTime)
isBadgeExpired now future `shouldBe` False
mkBadgeStatus now True future `shouldBe` BSActive
mkBadgeStatus now False future `shouldBe` BSFailed
testLifetimeBadge :: IO ()
testLifetimeBadge = do
now <- getCurrentTime
(pk, badge) <- issueBadgeProof BTCFInvestor Nothing
verifyBadge pk badge >>= (`shouldBe` True)
isBadgeExpired now badge `shouldBe` False
mkBadgeStatus now True badge `shouldBe` BSActive
testUnknownBadgeType :: IO ()
testUnknownBadgeType = do
tests/Bots/BroadcastTests.hs
+1 -1
View File
@@ -33,7 +33,7 @@ withBroadcastBot opts test =
bot = simplexChatCore testCfg (mkChatOpts opts) $ broadcastBot opts
broadcastBotProfile :: Profile
broadcastBotProfile = Profile {displayName = "broadcast_bot", fullName = "Broadcast Bot", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing}
broadcastBotProfile = Profile {displayName = "broadcast_bot", fullName = "Broadcast Bot", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing}
mkBotOpts :: TestParams -> [KnownContact] -> BroadcastBotOpts
mkBotOpts ps publishers =
tests/Bots/DirectoryTests.hs
+1 -1
View File
@@ -96,7 +96,7 @@ directoryServiceTests = do
it "should update subscriber count periodically" testLinkCheckUpdatesCount
directoryProfile :: Profile
directoryProfile = Profile {displayName = "SimpleX Directory", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing}
directoryProfile = Profile {displayName = "SimpleX Directory", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing}
mkDirectoryOpts :: TestParams -> [KnownContact] -> Maybe KnownGroup -> Maybe FilePath -> DirectoryOpts
mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup webFolder =
tests/ChatTests/Profiles.hs
+1 -1
View File
@@ -279,7 +279,7 @@ testMultiWordProfileNames =
aliceProfile' = baseProfile {displayName = "Alice Jones"}
bobProfile' = baseProfile {displayName = "Bob James"}
cathProfile' = baseProfile {displayName = "Cath Johnson"}
baseProfile = Profile {displayName = "", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = defaultPrefs}
baseProfile = Profile {displayName = "", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = defaultPrefs, badge = Nothing}
testUserContactLink :: HasCallStack => TestParams -> IO ()
testUserContactLink =
tests/ChatTests/Utils.hs
+1 -1
View File
@@ -85,7 +85,7 @@ chatRelayProfile :: Profile
chatRelayProfile = mkProfile "relay" "Relay" Nothing
mkProfile :: T.Text -> T.Text -> Maybe ImageData -> Profile
mkProfile displayName descr image = Profile {displayName, fullName = "", shortDescr = Just descr, image, contactLink = Nothing, peerType = Nothing, preferences = defaultPrefs}
mkProfile displayName descr image = Profile {displayName, fullName = "", shortDescr = Just descr, image, contactLink = Nothing, peerType = Nothing, preferences = defaultPrefs, badge = Nothing}
it :: HasCallStack => String -> (ps -> Expectation) -> SpecWith (Arg (ps -> Expectation))
it name test =
tests/ProtocolTests.hs
+2 -2
View File
@@ -104,7 +104,7 @@ testGroupPreferences :: Maybe GroupPreferences
testGroupPreferences = Just GroupPreferences {timedMessages = Nothing, directMessages = Nothing, reactions = Just ReactionsGroupPreference {enable = FEOn}, voice = Just VoiceGroupPreference {enable = FEOn, role = Nothing}, files = Nothing, fullDelete = Nothing, simplexLinks = Nothing, history = Nothing, reports = Nothing, support = Nothing, sessions = Nothing, comments = Nothing, commands = Nothing}
testProfile :: Profile
testProfile = Profile {displayName = "alice", fullName = "Alice", shortDescr = Nothing, image = Just (ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII="), peerType = Nothing, contactLink = Nothing, preferences = testChatPreferences}
testProfile = Profile {displayName = "alice", fullName = "Alice", shortDescr = Nothing, image = Just (ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII="), peerType = Nothing, contactLink = Nothing, preferences = testChatPreferences, badge = Nothing}
testGroupProfile :: GroupProfile
testGroupProfile = GroupProfile {displayName = "team", fullName = "Team", description = Nothing, shortDescr = Nothing, image = Nothing, publicGroup = Nothing, groupPreferences = testGroupPreferences, memberAdmission = Nothing}
@@ -218,7 +218,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
#==# XInfo testProfile
it "x.info with empty full name" $
"{\"v\":\"1\",\"event\":\"x.info\",\"params\":{\"profile\":{\"fullName\":\"\",\"displayName\":\"alice\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}"
#==# XInfo Profile {displayName = "alice", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = testChatPreferences}
#==# XInfo Profile {displayName = "alice", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = testChatPreferences, badge = Nothing}
it "x.contact with xContactId" $
"{\"v\":\"1\",\"event\":\"x.contact\",\"params\":{\"contactReqId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}"
#==# XContact testProfile (Just $ XContactId "\1\2\3\4") Nothing Nothing