diff --git a/apps/simplex-badge-service/src/BadgeService/Codes.hs b/apps/simplex-badge-service/src/BadgeService/Codes.hs new file mode 100644 index 0000000000..46ade82991 --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Codes.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Pure, database-free primitives for redemption codes (docs/protocol/badges-web.md): the +-- Crockford base32 encoding with its check character, deriving an order's code from the +-- badge service's long-lived secret, generating a batch code, normalizing whatever a user +-- typed back to canonical form, hashing that form for lookup, and classifying the row +-- 'BadgeService.Store.getCodeByHash' returns into a 'RedeemOutcome'. The lookup and every +-- write live in B7; this module supplies only what does not touch the database. +-- +-- A code is a bearer secret to a paid good: its 95 bits of entropy are the load-bearing +-- defence, everything here only shapes honest traffic. Two properties matter more than the +-- rest: a code failing the check character is rejected in 'classifyRedemption' before +-- 'lookupCode' is ever forced, so guessing costs an attacker no database round trip on 31 of +-- every 32 attempts; and 'RedeemInvalid'/'RedeemRevoked' both exist so support tooling can +-- tell an unknown code from a revoked one, but every caller outside this module maps both to +-- the same wire error, so a guesser cannot learn that a code once existed. +module BadgeService.Codes + ( RedeemOutcome (..), + deriveOrderCode, + generateBatchCode, + normalizeCode, + codeHash, + verifyChecksum, + classifyRedemption, + loadCodeSecret, + decodeCodeSecret, + ) +where + +-- 'BadgeService.Store' also defines 'BadgeService.Store.NewBadgeCode' and +-- 'BadgeService.Store.NewIssuance' with overlapping field names ('badgeType', 'months', +-- 'expiresAt', ...): the fields below are only ever used inside a 'BadgeCode { .. }' pattern +-- (NamedFieldPuns), where the named constructor makes the choice unambiguous; none is used as +-- a bare selector function, which is the one form DuplicateRecordFields cannot disambiguate. +import BadgeService.Store (BadgeCode (BadgeCode, badgeType, expiresAt, months, redeemedPurchaseId, revokedAt)) +import Control.Concurrent.STM (TVar, atomically) +import qualified Crypto.MAC.HMAC as HMAC +import Crypto.Hash (SHA256) +import Crypto.Random (ChaChaDRG) +import qualified Data.ByteArray as BA +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as B8 +import Data.Bits (testBit) +import Data.Char (isSpace) +import Data.Int (Int64) +import Data.List (elemIndex, foldl') +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Time.Clock (UTCTime) +import Data.Word (Word8) +import Simplex.Chat.Badges (BadgeType) +import qualified Simplex.Messaging.Crypto as C +import System.Exit (exitFailure) + +-- | The outcome of redeeming a presented code, resolved against the row +-- 'BadgeService.Store.getCodeByHash' returns and the purchase key making the request. +-- 'RedeemInvalid' and 'RedeemRevoked' are kept distinct here for support tooling +-- (@codes status@, H2) but both map to the same @code_invalid@ wire error later — a revoked +-- code must read exactly like one that never existed. 'RedeemUsedByOther' maps to +-- @code_used@, 'RedeemExpired' to @code_expired@. 'RedeemAlreadyRedeemedBySameKey' is not an +-- error: it carries the purchase id whose cached credential B7 replays. 'RedeemOk' carries +-- the badge type and the number of months to credit. +data RedeemOutcome + = RedeemOk BadgeType Int + | RedeemInvalid + | RedeemRevoked + | RedeemUsedByOther + | RedeemAlreadyRedeemedBySameKey Int64 + | RedeemExpired + deriving (Eq, Show) + +-- Crockford base32 ----------------------------------------------------------------------- + +-- | Crockford's base32 alphabet: 32 symbols, excluding 'I', 'L', 'O' and 'U' (easily confused +-- with '1', '1', '0' and 'V'). Index in this list is the 5-bit value. +crockfordAlphabet :: String +crockfordAlphabet = "0123456789ABCDEFGHJKMNPQRSTVWXYZ" + +alphabetSize :: Int +alphabetSize = length crockfordAlphabet + +charValue :: Char -> Maybe Word8 +charValue c = fromIntegral <$> elemIndex c crockfordAlphabet + +valueChar :: Word8 -> Char +valueChar v = crockfordAlphabet !! fromIntegral v + +-- | 19 data characters, carrying exactly 95 bits. +dataChars :: Int +dataChars = 19 + +bitsPerChar :: Int +bitsPerChar = 5 + +dataBits :: Int +dataBits = dataChars * bitsPerChar + +-- | The unweighted sum of the 19 data values, mod 32, encoded in the same alphabet. This is +-- deliberately not Crockford's own mod-37 check symbol, which needs five symbols outside the +-- alphabet: an unweighted sum mod 32 detects every single-character substitution (changing one +-- value changes the sum by a nonzero amount less than 32, so it never wraps back to the same +-- residue) but not transpositions. That is accepted, not a bug to fix. +checksumOf :: [Word8] -> Word8 +checksumOf values = fromIntegral (sum (map fromIntegral values :: [Int]) `mod` alphabetSize) + +-- | Big-endian bits of a byte string, most significant bit first. +bitsOf :: ByteString -> [Bool] +bitsOf = concatMap byteBits . BS.unpack + where + byteBits w = [testBit w i | i <- [7, 6 .. 0]] + +chunksOf :: Int -> [a] -> [[a]] +chunksOf _ [] = [] +chunksOf n xs = let (a, b) = splitAt n xs in a : chunksOf n b + +bitsToValue :: [Bool] -> Word8 +bitsToValue = foldl' (\acc b -> acc * 2 + if b then 1 else 0) 0 + +-- | The first 95 bits of a byte string (at least 12 bytes) as 19 data characters plus the +-- check character: 20 characters total, undashed and unprefixed. +encodeDataBytes :: ByteString -> Text +encodeDataBytes source = + let dataValues = map bitsToValue (chunksOf bitsPerChar (take dataBits (bitsOf source))) + checkValue = checksumOf dataValues + in T.pack (map valueChar (dataValues ++ [checkValue])) + +-- | Display prefix: 'S', 'X' and 'B' are themselves valid data characters, which is exactly +-- why 'normalizeCode' only strips it when doing so leaves a full 20-character code behind. +codePrefix :: Text +codePrefix = "SXB" + +groupSize :: Int +groupSize = 5 + +textChunksOf :: Int -> Text -> [Text] +textChunksOf n t + | T.null t = [] + | otherwise = let (a, b) = T.splitAt n t in a : textChunksOf n b + +-- | @SXB-XXXXX-XXXXX-XXXXX-XXXXX@ from a 20-character undashed code. +formatCode :: Text -> Text +formatCode raw = codePrefix <> "-" <> T.intercalate "-" (textChunksOf groupSize raw) + +-- Order and batch codes ----------------------------------------------------------------------- + +hmacSha256 :: ByteString -> ByteString -> ByteString +hmacSha256 key msg = BA.convert (HMAC.hmacGetDigest (HMAC.hmac key msg :: HMAC.HMAC SHA256)) + +-- | @code = encode (HMAC_SHA256 codeSecret orderId)@, truncated to the 95 bits the format +-- carries plus its check character. Fully recomputable from 'codeSecret' and @orderId@ alone, +-- so a browser reload is answerable with no plaintext code ever at rest, and so rotating +-- 'codeSecret' breaks recomputation for every order minted under the old one (H5). +deriveOrderCode :: ByteString -> Text -> Text +deriveOrderCode secret orderId = formatCode (encodeDataBytes (hmacSha256 secret (encodeUtf8 orderId))) + +-- | Enough entropy for the 95 data bits the format carries, with a byte to spare. +randomCodeBytes :: Int +randomCodeBytes = 12 + +-- | A fresh code from 'C.randomBytes', same encoding as an order code. Printed once by B8 and +-- never recoverable — nothing here persists the plaintext. +generateBatchCode :: TVar ChaChaDRG -> IO Text +generateBatchCode drg = formatCode . encodeDataBytes <$> atomically (C.randomBytes randomCodeBytes drg) + +-- Normalization, hashing and checksum ----------------------------------------------------------------------- + +-- | Upper-cases, strips '-' and whitespace, strips a leading @SXB@ only when doing so leaves +-- exactly 20 characters — 'S', 'X' and 'B' are themselves valid data characters, so an +-- unconditional strip would corrupt a bare 20-character code whose first three happen to spell +-- @SXB@ — and finally folds 'I'/'L' to \'1\' and 'O' to \'0\'. A code is accepted with or +-- without the prefix. +normalizeCode :: Text -> Text +normalizeCode raw = + T.map foldAmbiguous unprefixed + where + stripped = T.filter (\c -> c /= '-' && not (isSpace c)) (T.toUpper raw) + unprefixed + | codePrefix `T.isPrefixOf` stripped && T.length stripped == 3 + dataChars + 1 = T.drop 3 stripped + | otherwise = stripped + foldAmbiguous 'I' = '1' + foldAmbiguous 'L' = '1' + foldAmbiguous 'O' = '0' + foldAmbiguous c = c + +-- | SHA-256 over a normalized code (the output of 'normalizeCode'), used both as the storage +-- key and the lookup key, so every presentation of the same code resolves to the same row. +codeHash :: Text -> ByteString +codeHash = C.sha256Hash . encodeUtf8 + +-- | True when a normalized 20-character code's check character matches the unweighted sum of +-- its 19 data values, mod 32. False for anything the wrong length or containing a character +-- outside the alphabet. +verifyChecksum :: Text -> Bool +verifyChecksum code = case traverse charValue (T.unpack code) of + Just values | length values == dataChars + 1 -> case splitAt dataChars values of + (dataValues, [checkValue]) -> checkValue == checksumOf dataValues + _ -> False + _ -> False + +-- Classification ----------------------------------------------------------------------- + +-- | Normalizes and checksum-verifies a presented code, and only then calls @lookupCode@ — a +-- checksum failure returns 'RedeemInvalid' without @lookupCode@ ever being forced, so 31 of +-- every 32 random guesses cost no database round trip. @lookupCode@ is +-- 'BadgeService.Store.getCodeByHash' partially applied to its connection; the 'Monad' is left +-- abstract so a test can pass a stub that fails if it is ever called. +classifyRedemption :: + Monad m => + UTCTime -> + C.PublicKeyEd25519 -> + (ByteString -> m (Maybe (BadgeCode, Maybe C.PublicKeyEd25519))) -> + Text -> + m RedeemOutcome +classifyRedemption now purchaseKey lookupCode presentedCode + | verifyChecksum normalized = classifyRow now purchaseKey <$> lookupCode (codeHash normalized) + | otherwise = pure RedeemInvalid + where + normalized = normalizeCode presentedCode + +-- | The row-level classification: 'Nothing' (an unknown hash, or the checksum-failure case +-- above) and a revoked row both become 'RedeemInvalid'\/'RedeemRevoked' respectively — kept +-- distinct here, collapsed to the same wire error by every caller outside this module. +classifyRow :: UTCTime -> C.PublicKeyEd25519 -> Maybe (BadgeCode, Maybe C.PublicKeyEd25519) -> RedeemOutcome +classifyRow _ _ Nothing = RedeemInvalid +classifyRow now purchaseKey (Just (BadgeCode {badgeType, months, expiresAt, redeemedPurchaseId, revokedAt}, redeemerKey)) + | isJust revokedAt = RedeemRevoked + | Just pid <- redeemedPurchaseId = + if redeemerKey == Just purchaseKey then RedeemAlreadyRedeemedBySameKey pid else RedeemUsedByOther + | expiresAt < now = RedeemExpired + | otherwise = RedeemOk badgeType (fromIntegral months) + +-- Secret loading ----------------------------------------------------------------------- + +minCodeSecretBytes :: Int +minCodeSecretBytes = 32 + +-- | Standard base64 on one line, trailing whitespace stripped, decoding to at least 32 bytes. +-- Pure so it is testable without a file. +decodeCodeSecret :: ByteString -> Either String ByteString +decodeCodeSecret raw = case B64.decode (B8.dropWhileEnd isSpace raw) of + Left err -> Left ("invalid base64: " <> err) + Right decoded + | BS.length decoded < minCodeSecretBytes -> + Left ("must decode to at least " <> show minCodeSecretBytes <> " bytes, got " <> show (BS.length decoded)) + | otherwise -> Right decoded + +-- | Reads and decodes '[codes] secret_file' (A6), exiting the process on a bad secret: this is +-- the long-lived HMAC key behind every order-derived code, so a misconfigured deploy must fail +-- at startup, not at the first redemption. +loadCodeSecret :: FilePath -> IO ByteString +loadCodeSecret path = do + raw <- B8.readFile path + case decodeCodeSecret raw of + Right secret -> pure secret + Left err -> putStrLn ("codes secret_file " <> path <> ": " <> err) >> exitFailure diff --git a/apps/simplex-badge-service/src/BadgeService/Config.hs b/apps/simplex-badge-service/src/BadgeService/Config.hs index 54fbce4eb8..3a048dd6ec 100644 --- a/apps/simplex-badge-service/src/BadgeService/Config.hs +++ b/apps/simplex-badge-service/src/BadgeService/Config.hs @@ -20,6 +20,8 @@ module BadgeService.Config ) where +import BadgeService.Codes (loadCodeSecret) +import Data.ByteString (ByteString) import Data.Ini (Ini, keys, lookupValue, readIniFile, sections) import Data.Maybe (isJust) import Data.Text (Text) @@ -318,8 +320,14 @@ data BadgeServiceEnv = BadgeServiceEnv store :: DBStore, -- | Every service component reads the clock through this, and none calls -- 'getCurrentTime' directly, so a test can advance service time without sleeping. - now :: IO UTCTime + now :: IO UTCTime, + -- | 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 } newBadgeServiceEnv :: BadgeServiceConfig -> DBStore -> IO BadgeServiceEnv -newBadgeServiceEnv cfg st = pure BadgeServiceEnv {config = cfg, store = st, now = getCurrentTime} +newBadgeServiceEnv cfg st = do + codeSecret <- loadCodeSecret (codesSecretFile (codes cfg)) + pure BadgeServiceEnv {config = cfg, store = st, now = getCurrentTime, codeSecret} diff --git a/plans/2026-08-21-badges-web-checkout.md b/plans/2026-08-21-badges-web-checkout.md index 84756d599b..1b01aecf71 100644 --- a/plans/2026-08-21-badges-web-checkout.md +++ b/plans/2026-08-21-badges-web-checkout.md @@ -135,7 +135,7 @@ The two `-m` filters are needed because the badge tests live under two hspec pat | A6 | `badge_service.ini`: configuration file | A3, A4, A5 | ☑ | | 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 | ☐ | +| B3 | `Codes.hs`: derive, encode, hash, classify | A5, A6, B1 | ☑ | | 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 | ☐ | diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 9181c6dd1c..93510dcf97 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -418,6 +418,7 @@ executable simplex-badge-service StrictData other-modules: BadgeService.Catalog + BadgeService.Codes BadgeService.Config BadgeService.Ledger BadgeService.Options @@ -699,12 +700,14 @@ test-suite simplex-chat-test API.Docs.Types API.TypeInfo BadgeService.Catalog + BadgeService.Codes BadgeService.Config BadgeService.Ledger BadgeService.Options BadgeService.Service BadgeService.Store BadgeService.Store.Migrate + Bots.BadgeCodeTests Bots.BadgeLedgerTests Bots.BadgeServiceTests Broadcast.Bot diff --git a/tests/Bots/BadgeCodeTests.hs b/tests/Bots/BadgeCodeTests.hs new file mode 100644 index 0000000000..7982aa80de --- /dev/null +++ b/tests/Bots/BadgeCodeTests.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Unit tests for the pure, database-free redemption-code primitives (BadgeService.Codes). +-- Registered under the "Supporter badges" hspec path (not "SimpleX Badge service bot"): these +-- tests need no database and must run in CI. The rest of the RedeemOutcome mapping is covered +-- by B10, which drives every outcome through purchaseBadge. +module Bots.BadgeCodeTests (badgeCodeTests) where + +import BadgeService.Codes +import Control.Concurrent.STM (atomically) +import qualified Data.ByteString as BS +import Data.Functor.Identity (Identity (..)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime (..)) +import qualified Simplex.Messaging.Crypto as C +import Test.Hspec + +badgeCodeTests :: Spec +badgeCodeTests = do + describe "deriveOrderCode / normalizeCode" $ do + it "is deterministic for a given secret and orderId" $ + deriveOrderCode secretA "order-1" `shouldBe` deriveOrderCode secretA "order-1" + it "differs across orderIds" $ + deriveOrderCode secretA "order-1" `shouldNotBe` deriveOrderCode secretA "order-2" + it "differs across secrets" $ + deriveOrderCode secretA "order-1" `shouldNotBe` deriveOrderCode secretB "order-1" + it "normalizeCode inverts the display formatting stably across calls" $ do + let code = deriveOrderCode secretA "order-1" + normalizeCode code `shouldBe` normalizeCode code + T.length (normalizeCode code) `shouldBe` 20 + it "a derived code passes its own checksum" $ + verifyChecksum (normalizeCode (deriveOrderCode secretA "order-1")) `shouldBe` True + + describe "normalizeCode" $ do + it "maps a lowercase spaced sxb-prefixed code and a dashed uppercase one to the same canonical value" $ do + let canonical = "01234567890123456789" :: Text + spaced = "sxb Oi23456789oL23456789" :: Text + dashed = "SXB-OI234-56789-OL234-56789" :: Text + bare = "Oi23456789oL23456789" :: Text + normalizeCode spaced `shouldBe` canonical + normalizeCode dashed `shouldBe` canonical + normalizeCode bare `shouldBe` canonical + it "does not truncate a bare 20-character code whose first three characters are SXB" $ do + let bareSxb = "SXB23456789ABCDEFGHJ" :: Text + T.length bareSxb `shouldBe` 20 + normalizeCode bareSxb `shouldBe` bareSxb + + describe "verifyChecksum" $ + it "catches every single-character substitution" $ do + let code = normalizeCode (deriveOrderCode secretA "order-1") + alphabet = "0123456789ABCDEFGHJKMNPQRSTVWXYZ" :: String + substitutions = + [ T.pack (prefix ++ (c' : drop 1 suffix)) + | i <- [0 .. T.length code - 1], + let (prefix, suffix) = splitAt i (T.unpack code), + c' <- alphabet, + c' /= head suffix + ] + verifyChecksum code `shouldBe` True + all (not . verifyChecksum) substitutions `shouldBe` True + + describe "classifyRedemption" $ + it "classifies a checksum-failing code as RedeemInvalid without ever calling the database lookup" $ do + drg <- C.newRandom + (purchaseKey, _priv :: C.PrivateKeyEd25519) <- atomically $ C.generateKeyPair drg + let goodCode = normalizeCode (deriveOrderCode secretA "order-1") + corrupted = T.cons (succ (T.head goodCode)) (T.tail goodCode) + neverLookup :: t -> Identity (Maybe a) + neverLookup _ = error "classifyRedemption must not look up a checksum-failing code" + verifyChecksum corrupted `shouldBe` False + runIdentity (classifyRedemption epoch purchaseKey neverLookup corrupted) `shouldBe` RedeemInvalid + where + secretA = BS.pack [1 .. 32] + secretB = BS.pack (reverse [1 .. 32]) + epoch = UTCTime (fromGregorian 2026 1 1) 0 diff --git a/tests/Test.hs b/tests/Test.hs index 1251d76ee4..f8619817e0 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TupleSections #-} +import Bots.BadgeCodeTests import Bots.BadgeLedgerTests import Bots.BadgeServiceTests import Bots.BroadcastTests @@ -66,6 +67,7 @@ main = do #endif describe "Supporter badges" badgeTests describe "Supporter badges" badgeLedgerTests + describe "Supporter badges" badgeCodeTests describe "SimpleX chat markdown" markdownTests describe "JSON Tests" jsonTests describe "Member relations" memberRelationsTests