From 412e5dfb4898b10a30da53951182458afdcb66ed Mon Sep 17 00:00:00 2001 From: shum Date: Mon, 24 Aug 2026 11:09:25 +0000 Subject: [PATCH] core: badge issuer key and signing --- .../src/BadgeService/Config.hs | 10 +- .../src/BadgeService/Credentials.hs | 63 ++++++++++ plans/2026-08-21-badges-web-checkout.md | 2 +- simplex-chat.cabal | 2 + tests/Bots/BadgeServiceTests.hs | 112 +++++++++++++++++- 5 files changed, 183 insertions(+), 6 deletions(-) create mode 100644 apps/simplex-badge-service/src/BadgeService/Credentials.hs diff --git a/apps/simplex-badge-service/src/BadgeService/Config.hs b/apps/simplex-badge-service/src/BadgeService/Config.hs index 3a048dd6ec..120c19f258 100644 --- a/apps/simplex-badge-service/src/BadgeService/Config.hs +++ b/apps/simplex-badge-service/src/BadgeService/Config.hs @@ -21,6 +21,7 @@ module BadgeService.Config where import BadgeService.Codes (loadCodeSecret) +import BadgeService.Credentials (loadIssuerKey) import Data.ByteString (ByteString) import Data.Ini (Ini, keys, lookupValue, readIniFile, sections) import Data.Maybe (isJust) @@ -28,6 +29,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime, getCurrentTime) import Simplex.Messaging.Agent.Store.Common (DBStore) +import Simplex.Messaging.Crypto.BBS (BBSSecretKey) import Simplex.Messaging.Util (eitherToMaybe) import System.Directory (doesFileExist) import Text.Read (readMaybe) @@ -324,10 +326,14 @@ data BadgeServiceEnv = BadgeServiceEnv -- | Decoded once at startup from '[codes] secret_file' (rejected there if it fails to -- decode to at least 32 bytes): the long-lived HMAC key behind every order-derived -- redemption code. See 'BadgeService.Codes.deriveOrderCode' and 'loadCodeSecret'. - codeSecret :: ByteString + codeSecret :: ByteString, + -- | The issuer BBS secret key loaded from '[issuer] key_file' (B4): loaded once at + -- startup, alongside 'config', so a malformed or absent key file fails fast. + issuerKey :: BBSSecretKey } newBadgeServiceEnv :: BadgeServiceConfig -> DBStore -> IO BadgeServiceEnv newBadgeServiceEnv cfg st = do codeSecret <- loadCodeSecret (codesSecretFile (codes cfg)) - pure BadgeServiceEnv {config = cfg, store = st, now = getCurrentTime, codeSecret} + issuerKey <- loadIssuerKey (issuerKeyFile (issuer cfg)) (issuerKeyIdx (issuer cfg)) + pure BadgeServiceEnv {config = cfg, store = st, now = getCurrentTime, codeSecret, issuerKey} diff --git a/apps/simplex-badge-service/src/BadgeService/Credentials.hs b/apps/simplex-badge-service/src/BadgeService/Credentials.hs new file mode 100644 index 0000000000..adb770bdb9 --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Credentials.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Issuer key loading and credential signing (decision 4, B4). Signing itself is never +-- reimplemented here -- 'Simplex.Chat.Badges.issueBadge' does the BBS signing; this module +-- only loads the issuer secret from its config file and computes the expiry that goes into +-- the signed 'BadgeInfo'. +module BadgeService.Credentials + ( loadIssuerKey, + issueSignedBadge, + ) +where + +import qualified Data.ByteString.Char8 as B +import Data.Maybe (mapMaybe) +import Data.Time.Clock (UTCTime) +import Simplex.Chat.Badges (BadgeCredential, BadgeInfo (..), BadgeRequest (..), VerifiedBadgeRequest (..), issueBadge) +import Simplex.Chat.Badges.Months (sundayAfter) +import Simplex.Chat.Badges.Service (BadgeServiceErrorCode (..)) +import Simplex.Messaging.Crypto.BBS (BBSSecretKey) +import Simplex.Messaging.Encoding.String (strDecode) +import System.Directory (doesFileExist) +import System.Exit (die) + +-- | Load and validate the '[issuer] key_file' / 'key_idx' pair (A6 reads the ini; this loads +-- what it points to). 'key_file' is the output of @simplex-chat badge keygen@ +-- (Badges/CLI.hs), two labelled lines: @secret @ and @public @; only +-- the 'secret' line is read. Fails fast, naming the file, when it is absent, unreadable, or +-- missing/malformed 'secret' line; fails fast on a non-positive 'key_idx'. +loadIssuerKey :: FilePath -> Int -> IO BBSSecretKey +loadIssuerKey path keyIdx + | keyIdx < 1 = die $ "issuer key_idx must be a positive integer, got " <> show keyIdx + | otherwise = do + exists <- doesFileExist path + if not exists + then die $ path <> ": file not found" + else do + contents <- B.readFile path + case parseIssuerSecret contents of + Left e -> die $ path <> ": " <> e + Right sk -> pure sk + +issuerSecretLinePrefix :: B.ByteString +issuerSecretLinePrefix = "secret " + +parseIssuerSecret :: B.ByteString -> Either String BBSSecretKey +parseIssuerSecret contents = case mapMaybe (B.stripPrefix issuerSecretLinePrefix) (B.lines contents) of + (b64 : _) -> strDecode b64 + [] -> Left "missing 'secret ' line (expected `simplex-chat badge keygen` output)" + +-- | Sign a badge request into a credential (server side). 'badgeExpiry' is always +-- 'sundayAfter periodEnd' -- the authoritative, server-computed expiry -- overriding +-- whatever 'badgeInfo' the caller passed in; 'issue' (BadgeService.Ledger) never yields a +-- period beyond the funded balance, so no further cap applies here. A non-empty +-- 'badgeExtra' is rejected by 'issueBadge' itself; that failure is surfaced as +-- 'BSEBadRequest'. +issueSignedBadge :: Int -> BBSSecretKey -> BadgeRequest -> UTCTime -> IO (Either BadgeServiceErrorCode BadgeCredential) +issueSignedBadge keyIdx sk req@BadgeRequest {badgeInfo} periodEnd = do + let req' = req {badgeInfo = badgeInfo {badgeExpiry = Just (sundayAfter periodEnd)}} + issueBadge keyIdx sk (VerifiedBadgeRequest req') >>= \case + Left _ -> pure $ Left BSEBadRequest + Right cred -> pure $ Right cred diff --git a/plans/2026-08-21-badges-web-checkout.md b/plans/2026-08-21-badges-web-checkout.md index 1b01aecf71..2236f6f059 100644 --- a/plans/2026-08-21-badges-web-checkout.md +++ b/plans/2026-08-21-badges-web-checkout.md @@ -136,7 +136,7 @@ The two `-m` filters are needed because the badge tests live under two hspec pat | B1 | Store layer: purchases, ledger, issuances, codes, catalog | A2, A3, A4, A5 | ☑ | | B2 | `Ledger.hs`: pure transitions and property tests | A5 | ☑ | | B3 | `Codes.hs`: derive, encode, hash, classify | A5, A6, B1 | ☑ | -| B4 | Issuer key loading and credential signing | A5, A6, B2 | ☐ | +| B4 | Issuer key loading and credential signing | A5, A6, B2 | ☑ | | B5 | RPC dispatcher: envelope, version, signer, throttle | A2, A6, B1 | ☐ | | B6 | `getBadgeCatalog` | A4, B1, B2, B5 | ☐ | | B7 | `purchaseBadge{code}` and `issueBadge` | B1, B2, B3, B4, B5 | ☐ | diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 93510dcf97..fb4c081aaa 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -420,6 +420,7 @@ executable simplex-badge-service BadgeService.Catalog BadgeService.Codes BadgeService.Config + BadgeService.Credentials BadgeService.Ledger BadgeService.Options BadgeService.Service @@ -702,6 +703,7 @@ test-suite simplex-chat-test BadgeService.Catalog BadgeService.Codes BadgeService.Config + BadgeService.Credentials BadgeService.Ledger BadgeService.Options BadgeService.Service diff --git a/tests/Bots/BadgeServiceTests.hs b/tests/Bots/BadgeServiceTests.hs index 4b1774e7fb..34e97aef7f 100644 --- a/tests/Bots/BadgeServiceTests.hs +++ b/tests/Bots/BadgeServiceTests.hs @@ -9,6 +9,7 @@ module Bots.BadgeServiceTests where import BadgeService.Catalog (catalogTotals, defaultCatalog, offerTotal, seedCatalog) import BadgeService.Config (BadgeServiceConfig (..), readBadgeServiceConfig) +import BadgeService.Credentials (issueSignedBadge, loadIssuerKey) import BadgeService.Options import BadgeService.Service import BadgeService.Store @@ -26,10 +27,12 @@ import Data.List (find, isInfixOf) import Data.Maybe (fromJust, isJust) import Data.String (fromString) import Data.Text (Text) -import Data.Time.Clock (addUTCTime, diffUTCTime, getCurrentTime, nominalDay) +import Data.Time.Calendar (fromGregorian) +import Data.Time.Calendar.WeekDate (toWeekDate) +import Data.Time.Clock (DiffTime, UTCTime (..), addUTCTime, diffUTCTime, getCurrentTime, nominalDay, secondsToDiffTime) import Data.Word (Word32) -import Simplex.Chat.Badges (BadgeMasterKey (..), BadgeType (..)) -import Simplex.Chat.Badges.Service (BadgeCatalog (..), BadgeOffer (..), BadgePrice (..)) +import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey (..), BadgeRequest (..), BadgeType (..), verifyCredential) +import Simplex.Chat.Badges.Service (BadgeCatalog (..), BadgeOffer (..), BadgePrice (..), BadgeServiceErrorCode (..)) import Simplex.Chat.Badges.Types ( BadgeItemStatus (..), BadgeLedgerEntry (..), @@ -52,6 +55,7 @@ import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (.. import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.BBS (BBSPublicKey (..), BBSSecretKey (..), bbsKeyGen) import Simplex.Messaging.Encoding.String (strEncode) +import System.Exit (ExitCode (..)) import System.FilePath (()) import Test.Hspec hiding (it) #if defined(dbPostgres) @@ -87,6 +91,14 @@ badgeServiceTests = do it "should disable a price out of the active catalog while both stay reachable by id" testBadgeStoreSetPriceStatusDisabled it "should return the redeeming purchase key from getCodeByHash" testBadgeStoreGetCodeByHashRedeemer it "should clear both redemption columns and set unredeemed_at" testBadgeStoreUnredeemCode + it "should sign a credential that verifies with the matching public key, and fail with a different one" testBadgeCredentialSignAndVerify + it "should set badgeExpiry to the next Sunday at 23:59:59 UTC" testBadgeCredentialExpiryIsSundayEndOfDay + it "should roll a periodEnd already on a Sunday to the following Sunday" testBadgeCredentialExpirySundayRollsToFollowingSunday + it "should reject a badgeRequest with non-empty badgeExtra as bad_request" testBadgeCredentialRejectsNonEmptyBadgeExtra + it "should load a valid issuer key file" testBadgeIssuerKeyLoadsValidFile + it "should fail fast on a missing issuer key file" testBadgeIssuerKeyMissingFile + it "should fail fast on an issuer key file without a 'secret' line" testBadgeIssuerKeyMalformedFile + it "should fail fast on a non-positive key_idx" testBadgeIssuerKeyNonPositiveIdx badgeProfile :: Profile badgeProfile = Profile {displayName = "SimpleX Badges", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing} @@ -622,6 +634,100 @@ testBadgeStoreUnredeemCode ps = Nothing -> expectationFailure "unredeemed_at should be set after unredeemCode" redeemer `shouldBe` Nothing +-- B4 issuer key + credential signing ----------------------------------------- + +sundayEndOfDay :: DiffTime +sundayEndOfDay = secondsToDiffTime (23 * 3600 + 59 * 60 + 59) + +testBadgeRequest :: BadgeMasterKey -> BadgeRequest +testBadgeRequest masterKey = BadgeRequest {masterKey, badgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = Nothing, badgeExtra = ""}} + +-- Signs a real credential (via issueSignedBadge, never reimplementing BBS) and checks it +-- verifies with the matching public key -- and, the other side of the same property, fails +-- with an unrelated one. +testBadgeCredentialSignAndVerify :: HasCallStack => TestParams -> IO () +testBadgeCredentialSignAndVerify _ps = do + Right (pk, sk) <- bbsKeyGen + Right (otherPk, _) <- bbsKeyGen + masterKey <- BadgeMasterKey <$> getRandomBytes 32 + now <- getCurrentTime + result <- issueSignedBadge 1 sk (testBadgeRequest masterKey) now + case result of + Left e -> expectationFailure $ "expected a signed credential, got: " <> show e + Right cred -> do + verifyCredential pk cred `shouldReturn` True + verifyCredential otherPk cred `shouldReturn` False + +-- A periodEnd that is NOT already a Sunday must still land on a Sunday at 23:59:59 UTC. +testBadgeCredentialExpiryIsSundayEndOfDay :: HasCallStack => TestParams -> IO () +testBadgeCredentialExpiryIsSundayEndOfDay _ps = do + Right (_, sk) <- bbsKeyGen + masterKey <- BadgeMasterKey <$> getRandomBytes 32 + let periodEnd = UTCTime (fromGregorian 2026 8 20) 0 -- a Thursday + Right BadgeCredential {badgeInfo = BadgeInfo {badgeExpiry}} <- issueSignedBadge 1 sk (testBadgeRequest masterKey) periodEnd + case badgeExpiry of + Nothing -> expectationFailure "expected badgeExpiry to be set" + Just (UTCTime day tod) -> do + let (_, _, dow) = toWeekDate day -- 1 = Monday .. 7 = Sunday + dow `shouldBe` 7 + tod `shouldBe` sundayEndOfDay + +-- The boundary case: a periodEnd already on a Sunday must expire on the FOLLOWING Sunday, not +-- the same day -- a non-strict implementation would silently cost every such badge a week of +-- validity. +testBadgeCredentialExpirySundayRollsToFollowingSunday :: HasCallStack => TestParams -> IO () +testBadgeCredentialExpirySundayRollsToFollowingSunday _ps = do + Right (_, sk) <- bbsKeyGen + masterKey <- BadgeMasterKey <$> getRandomBytes 32 + let periodEnd = UTCTime (fromGregorian 2026 8 23) 0 -- already a Sunday + expectedExpiry = UTCTime (fromGregorian 2026 8 30) sundayEndOfDay -- the following Sunday + Right BadgeCredential {badgeInfo = BadgeInfo {badgeExpiry}} <- issueSignedBadge 1 sk (testBadgeRequest masterKey) periodEnd + badgeExpiry `shouldBe` Just expectedExpiry + +-- issueBadge itself rejects a non-empty badgeExtra; issueSignedBadge must surface that as +-- BSEBadRequest rather than letting the raw BBS error leak. +testBadgeCredentialRejectsNonEmptyBadgeExtra :: HasCallStack => TestParams -> IO () +testBadgeCredentialRejectsNonEmptyBadgeExtra _ps = do + Right (_, sk) <- bbsKeyGen + masterKey <- BadgeMasterKey <$> getRandomBytes 32 + now <- getCurrentTime + let req = BadgeRequest {masterKey, badgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = Nothing, badgeExtra = "reserved"}} + result <- issueSignedBadge 1 sk req now + result `shouldBe` Left BSEBadRequest + +-- Round-trips a real `simplex-chat badge keygen`-shaped file (the format written by +-- writeTestBadgeServiceSecrets) through loadIssuerKey and checks the loaded secret matches. +testBadgeIssuerKeyLoadsValidFile :: HasCallStack => TestParams -> IO () +testBadgeIssuerKeyLoadsValidFile TestParams {tmpPath} = do + Right (BBSPublicKey pk, sk@(BBSSecretKey skBytes)) <- bbsKeyGen + let path = tmpPath "valid-issuer.keys" + writeFile path $ "secret " <> BC.unpack (strEncode skBytes) <> "\npublic " <> BC.unpack (strEncode pk) <> "\n" + loaded <- loadIssuerKey path 1 + loaded `shouldBe` sk + +expectDies :: forall a. HasCallStack => IO a -> IO () +expectDies action = do + r <- try action :: IO (Either ExitCode a) + case r of + Left (ExitFailure _) -> pure () + Left ExitSuccess -> expectationFailure "expected a failing exit, got ExitSuccess" + Right _ -> expectationFailure "expected loadIssuerKey to fail fast, but it returned" + +testBadgeIssuerKeyMissingFile :: HasCallStack => TestParams -> IO () +testBadgeIssuerKeyMissingFile TestParams {tmpPath} = + expectDies $ loadIssuerKey (tmpPath "missing-issuer.keys") 1 + +testBadgeIssuerKeyMalformedFile :: HasCallStack => TestParams -> IO () +testBadgeIssuerKeyMalformedFile TestParams {tmpPath} = do + let path = tmpPath "malformed-issuer.keys" + writeFile path "not the expected keygen output\n" + expectDies $ loadIssuerKey path 1 + +testBadgeIssuerKeyNonPositiveIdx :: HasCallStack => TestParams -> IO () +testBadgeIssuerKeyNonPositiveIdx TestParams {tmpPath} = do + (issuerKeyFile, _) <- writeTestBadgeServiceSecrets tmpPath + expectDies $ loadIssuerKey issuerKeyFile 0 + #if defined(dbPostgres) runMigrationsToRun :: DBStore -> MigrationsToRun -> IO () runMigrationsToRun st = Migrations.run st Nothing