core: supporter badges using anonymous BBS credentials (#7040)

* core: supporter badges using anonymous BBS credentials * badges in profiles * badge in profiles * process badges * update simplexmq * update simplexmq * change types * fix migration * migration * update simplexmq * fix bot API, schema * fix postgresql build * refactor * postgresql schema * correctly set badges in all cases * badges ffi * plan, bot types * FFI * FFI: export badge symbols * add extra field * refactor badge types to GADT * configurable badge key * add badge to profile, test * ui: badge images * generate badge key and sign badge * badge sign in CLI * fix commands, ui * rename badges * Binary * image size, migration * update badge images, add public key * send badges in more cases * update UI, tests * bot types, schema * postgres schema * tone down badges * revert formula * refactor badges * smaller badges * badge position * better badge position * simpler * position * move position * update simplexmq * show badge after name * badge layout * fix badge * debug badge height * shift badge * fix badge in member name * bigger badge * badge layout * differentiate badge colors * more avatars for the user's profiles * refactor * remove color filter * alerts * multiple keys, old expired * use new BBS api * update badge keys, bot api * presentation header * simplify * parser * update iOS images * update public keys * query plans * update simplexmq * refactor badge types * simplexmq * bot api types * update simplexmq - commoncrypto flag * update simplexmq * pass commoncrypto flag to simplexmq in nix iOS build * ios ui * update core library, fixes * badge layout * badge size * badge gap * remove extensions * simplify * share badge in more events, reverify badge if verification failed * larger files with badges * allow sending larger files * simpler * update simplexmq * better decoder for badge keys * update simplexmq --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com> Co-authored-by: shum <github.shum@liber.li>
2026-10-23 15:03:16 +00:00 · 2026-06-15 22:25:08 +01:00
1 parent f144bf4560
commit ad23da63d0
@@ -0,0 +1,74 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Simplex.Chat.Mobile.Badges
+  ( cChatBadgeKeygen,
+    cChatBadgeIssue,
+    BadgeResult (..),
+    BadgeIssueReq (..),
+    IssuerKeyPair (..),
+  )
+where
+
+import Data.Aeson (FromJSON (..), ToJSON (..))
+import qualified Data.Aeson as J
+import qualified Data.Aeson.TH as JQ
+import qualified Data.ByteString as B
+import Data.Text (Text)
+import qualified Data.Text as T
+import Foreign.C (CString)
+import Simplex.Chat.Badges
+import Simplex.Chat.Mobile.Shared (CJSONString, newCStringFromLazyBS)
+import Simplex.Messaging.Crypto.BBS (BBSPublicKey, BBSSecretKey, bbsKeyGen)
+import Simplex.Messaging.Parsers (defaultJSON)
+
+-- FFI envelope for a generated issuer keypair (the BBS keypair tuple serialized with named fields)
+data IssuerKeyPair = IssuerKeyPair
+  { publicKey :: BBSPublicKey,
+    secretKey :: BBSSecretKey
+  }
+
+data BadgeIssueReq = BadgeIssueReq
+  { badgeKeyIdx :: Int,
+    secretKey :: BBSSecretKey,
+    request :: BadgeRequest
+  }
+
+data BadgeResult r
+  = BadgeResult {result :: r}
+  | BadgeError {error :: Text}
+
+$(JQ.deriveJSON defaultJSON ''IssuerKeyPair)
+
+$(JQ.deriveJSON defaultJSON ''BadgeIssueReq)
+
+$(pure [])
+
+instance ToJSON r => ToJSON (BadgeResult r) where
+  toEncoding = $(JQ.mkToEncoding (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''BadgeResult)
+  toJSON = $(JQ.mkToJSON (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''BadgeResult)
+
+instance FromJSON r => FromJSON (BadgeResult r) where
+  parseJSON = $(JQ.mkParseJSON (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''BadgeResult)
+
+cChatBadgeKeygen :: IO CJSONString
+cChatBadgeKeygen =
+  bbsKeyGen >>= \case
+    Right (pk, sk) -> encodeResult $ BadgeResult (IssuerKeyPair pk sk)
+    Left e -> encodeResult @IssuerKeyPair $ BadgeError (T.pack e)
+
+cChatBadgeIssue :: CString -> IO CJSONString
+cChatBadgeIssue cReq = do
+  bs <- B.packCString cReq
+  encodeResult @BadgeCredential =<< case J.eitherDecodeStrict' bs of
+    Left e -> pure $ BadgeError (T.pack e)
+    Right BadgeIssueReq {badgeKeyIdx, secretKey, request} ->
+      either (BadgeError . T.pack) BadgeResult <$> issueBadge badgeKeyIdx secretKey (VerifiedBadgeRequest request)
+
+encodeResult :: ToJSON r => BadgeResult r -> IO CJSONString
+encodeResult = newCStringFromLazyBS . J.encode