core: badge issuer key and signing

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}

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 <base64url>@ and @public <base64url>@; 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 <base64url>' 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

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 | ☐ |

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

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