core: redeem badge codes (#7438)

src/Simplex/Chat/Badges/Code.hs

@@ -0,0 +1,118 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Badge redemption codes, shared by the client, the badge service and the checkout site.
+--
+-- A code is @SXB-@ and 20 Crockford base32 characters in four groups of five:
+-- 19 payload characters and a final check character.
+--
+-- Reading folds the characters the alphabet omits so that a code copied by hand still
+-- verifies: it is case-insensitive and maps @I@ and @L@ to @1@ and @O@ to @0@.
+--
+-- The check character is Luhn mod N with N = 32 over the payload values, which keeps it
+-- inside the same 32-character alphabet. It detects every single-character substitution
+-- and every transposition of adjacent characters except '0' next to 'Z' - the values 0 and
+-- N-1, which is Luhn's one blind spot at any base.
+--
+-- 'BadgeCode' is only constructed by 'parseBadgeCode' and 'randomBadgeCode', so a code
+-- whose check character fails cannot be hashed, looked up or sent.
+module Simplex.Chat.Badges.Code
+  ( BadgeCode,
+    parseBadgeCode,
+    randomBadgeCode,
+    badgeCodeText,
+    badgeCodeHash,
+    formatBadgeCode,
+  )
+where
+
+import Control.Concurrent.STM
+import Crypto.Random (ChaChaDRG)
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Char (isAlphaNum, toUpper)
+import Data.List (elemIndex)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import qualified Simplex.Messaging.Crypto as C
+
+-- | A code that has passed its check character, in canonical form: 'codePrefix' followed by
+-- 20 upper-case alphabet characters, without separators.
+newtype BadgeCode = BadgeCode Text
+  deriving (Eq, Show)
+
+-- Crockford base32: the digits and the upper-case letters except I, L, O and U.
+alphabet :: String
+alphabet = "0123456789ABCDEFGHJKMNPQRSTVWXYZ"
+
+base :: Int
+base = 32
+
+codeLength :: Int
+codeLength = 20
+
+groupLength :: Int
+groupLength = 5
+
+codePrefix :: Text
+codePrefix = "SXB"
+
+-- | The Crockford value of a character, folding the omitted characters onto the digits they
+-- are mistaken for.
+charValue :: Char -> Maybe Int
+charValue c = case toUpper c of
+  'I' -> Just 1
+  'L' -> Just 1
+  'O' -> Just 0
+  u -> elemIndex u alphabet
+
+valueChar :: Int -> Char
+valueChar v = alphabet !! v
+
+-- | Luhn mod N (N = 32): the value that makes the whole code sum to zero modulo the base.
+checkValue :: [Int] -> Int
+checkValue payload = (base - total `mod` base) `mod` base
+  where
+    -- doubling every second value from the right, as the check character sits to the right of the payload
+    total = fst $ foldr step (0, 2) payload
+    step v (sum', factor) =
+      let addend = factor * v
+       in (sum' + addend `div` base + addend `mod` base, if factor == 2 then 1 else 2)
+
+-- | Read a code as typed: any case, separators optional, ambiguous characters folded.
+-- 'Nothing' for anything not well-formed, a failed check character included.
+parseBadgeCode :: Text -> Maybe BadgeCode
+parseBadgeCode t = do
+  body <- T.stripPrefix codePrefix $ T.toUpper $ T.filter isAlphaNum t
+  vs <- mapM charValue $ T.unpack body
+  let (payload, checkChar) = splitAt (codeLength - 1) vs
+  if T.length body == codeLength && checkChar == [checkValue payload]
+    -- rebuilt from the values, not from body: that is what folds I/L/O into the canonical form
+    then Just $ BadgeCode $ codePrefix <> T.pack (map valueChar vs)
+    else Nothing
+
+-- | A new code from the CSPRNG. 256 is a multiple of the base, so a byte reduces without bias.
+randomBadgeCode :: TVar ChaChaDRG -> IO BadgeCode
+randomBadgeCode drg = do
+  bs <- atomically $ C.randomBytes (codeLength - 1) drg
+  let payload = map ((`mod` base) . fromEnum) $ B.unpack bs
+      vs = payload <> [checkValue payload]
+  pure $ BadgeCode $ codePrefix <> T.pack (map valueChar vs)
+
+-- | The canonical form: the only representation of a code that is hashed or sent.
+badgeCodeText :: BadgeCode -> Text
+badgeCodeText (BadgeCode t) = t
+
+-- | The only thing about a code stored service-side: SHA-256 over the ASCII bytes of the
+-- canonical form, prefix included.
+badgeCodeHash :: BadgeCode -> ByteString
+badgeCodeHash = C.sha256Hash . encodeUtf8 . badgeCodeText
+
+-- | The code as it is shown and printed, in four groups of five.
+formatBadgeCode :: BadgeCode -> Text
+formatBadgeCode (BadgeCode t) = T.intercalate "-" $ codePrefix : groups (T.drop (T.length codePrefix) t)
+  where
+    groups s
+      | T.null s = []
+      | otherwise = let (g, rest) = T.splitAt groupLength s in g : groups rest

src/Simplex/Chat/Badges/Service.hs

@@ -3,13 +3,18 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.Chat.Badges.Service
   ( BadgeServiceRequest (..),
     BadgeServiceCommand (..),
     BadgeServiceVersion,
     VersionBadgeService,
+    VersionRangeBadgeService,
     pattern VersionBadgeService,
+    initialBadgeServiceVersion,
+    currentBadgeServiceVersion,
+    supportedBadgeServiceVRange,
     BadgeUpgrade (..),
     BadgeServiceResponse (..),
     BadgeServiceErrorCode (..),
@@ -24,9 +29,12 @@ module Simplex.Chat.Badges.Service
     StatementDebitType (..),
   ) where
 
-import Data.Aeson (FromJSON (..), ToJSON (..))
+import Control.Applicative ((<|>))
+import Data.Aeson (FromJSON (..), ToJSON (..), (.:))
 import qualified Data.Aeson as J
-import Data.Int (Int64)
+import qualified Data.Aeson.Encoding as JE
+import qualified Data.Aeson.TH as JQ
+import qualified Data.Aeson.Types as JT
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Data.Word (Word8, Word16, Word32)
@@ -35,7 +43,8 @@ import Simplex.Chat.Badges.Types
 import Simplex.Chat.PaymentService
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Version (VersionScope)
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
+import Simplex.Messaging.Version (VersionRange, VersionScope, mkVersionRange)
 import Simplex.Messaging.Version.Internal (Version (..))
 
 data BadgeServiceVersion
@@ -47,6 +56,18 @@ type VersionBadgeService = Version BadgeServiceVersion
 pattern VersionBadgeService :: Word16 -> VersionBadgeService
 pattern VersionBadgeService v = Version v
 
+type VersionRangeBadgeService = VersionRange BadgeServiceVersion
+
+initialBadgeServiceVersion :: VersionBadgeService
+initialBadgeServiceVersion = VersionBadgeService 1
+
+currentBadgeServiceVersion :: VersionBadgeService
+currentBadgeServiceVersion = VersionBadgeService 1
+
+-- the service is deployed ahead of app releases, so it answers within the client's version
+supportedBadgeServiceVRange :: VersionRangeBadgeService
+supportedBadgeServiceVRange = mkVersionRange initialBadgeServiceVersion currentBadgeServiceVersion
+
 data BadgeServiceRequest = BadgeServiceRequest
   { version :: VersionBadgeService,
     purchaseKey :: Maybe C.PublicKeyEd25519, -- optional for BSCGetBadgeCatalog, required for other commands
@@ -164,7 +185,7 @@ data StatementEntryType = SECredit {credit :: StatementCreditType} | SEDebit {de
 
 data StatementCreditType
   = SCPayment {invoiceId :: Maybe InvoiceId} -- absent for store and code payments
-  | SCCharge {chargeId :: Int64}
+  | SCCharge {chargeId :: Text}
   | SCSupport
   | SCTransferIn {fromPurchaseKey :: C.PublicKeyEd25519}
   | SCOpening
@@ -248,3 +269,57 @@ instance ToJSON BadgeServiceErrorCode where
 
 instance FromJSON BadgeServiceErrorCode where
   parseJSON = textParseJSON "BadgeServiceErrorCode"
+
+$(pure [])
+
+instance FromJSON StatementCreditType where
+  parseJSON v@(J.Object j) =
+    $(JQ.mkParseJSON (taggedObjectJSON $ dropPrefix "SC") ''StatementCreditType) v
+      <|> SCUnknown <$> j .: "type" <*> pure j
+  parseJSON invalid =
+    JT.prependFailure "bad StatementCreditType, " (JT.typeMismatch "Object" invalid)
+
+instance ToJSON StatementCreditType where
+  toJSON = \case
+    SCUnknown _ j -> J.Object j
+    v -> $(JQ.mkToJSON (taggedObjectJSON $ dropPrefix "SC") ''StatementCreditType) v
+  toEncoding = \case
+    SCUnknown _ j -> JE.value $ J.Object j
+    v -> $(JQ.mkToEncoding (taggedObjectJSON $ dropPrefix "SC") ''StatementCreditType) v
+
+instance FromJSON StatementDebitType where
+  parseJSON v@(J.Object j) =
+    $(JQ.mkParseJSON (taggedObjectJSON $ dropPrefix "SD") ''StatementDebitType) v
+      <|> SDUnknown <$> j .: "type" <*> pure j
+  parseJSON invalid =
+    JT.prependFailure "bad StatementDebitType, " (JT.typeMismatch "Object" invalid)
+
+instance ToJSON StatementDebitType where
+  toJSON = \case
+    SDUnknown _ j -> J.Object j
+    v -> $(JQ.mkToJSON (taggedObjectJSON $ dropPrefix "SD") ''StatementDebitType) v
+  toEncoding = \case
+    SDUnknown _ j -> JE.value $ J.Object j
+    v -> $(JQ.mkToEncoding (taggedObjectJSON $ dropPrefix "SD") ''StatementDebitType) v
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SE") ''StatementEntryType)
+
+$(JQ.deriveJSON defaultJSON ''StatementEntry)
+
+$(JQ.deriveJSON defaultJSON ''BadgeStatement)
+
+$(JQ.deriveJSON defaultJSON ''BadgeBalance)
+
+$(JQ.deriveJSON defaultJSON ''BadgeUpgrade)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "BSC") ''BadgeServiceCommand)
+
+$(JQ.deriveJSON defaultJSON ''BadgeServiceRequest)
+
+$(JQ.deriveJSON defaultJSON ''BadgePrice)
+
+$(JQ.deriveJSON defaultJSON ''BadgeOffer)
+
+$(JQ.deriveJSON defaultJSON ''BadgeCatalog)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "BSP") ''BadgeServiceResponse)

src/Simplex/Chat/Badges/Types.hs

@@ -1,6 +1,10 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.Chat.Badges.Types
   ( BadgePriceId (..),
@@ -22,7 +26,9 @@ module Simplex.Chat.Badges.Types
     UserBadgeState (..),
   ) where
 
+import Data.Aeson (FromJSON, ToJSON)
 import qualified Data.Aeson as J
+import qualified Data.Aeson.TH as JQ
 import Data.Int (Int64)
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
@@ -30,15 +36,25 @@ import Data.Word (Word8)
 import Simplex.Chat.Badges hiding (BadgePurchase (..))
 import Simplex.Chat.PaymentService.Types (InvoiceId, StoredPayment)
 import Simplex.Messaging.Agent.Protocol (UserId)
+import Simplex.Messaging.Agent.Store.DB (fromTextField_)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (dropPrefix, enumJSON, taggedObjectJSON)
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple.FromField (FromField (..))
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+#else
+import Database.SQLite.Simple.FromField (FromField (..))
+import Database.SQLite.Simple.ToField (ToField (..))
+#endif
 
 -- confirmed
 newtype BadgePriceId = BadgePriceId Text
-  deriving newtype (Eq, Show)
+  deriving newtype (Eq, Show, ToJSON, FromJSON)
 
 -- confirmed
 newtype BadgeOfferId = BadgeOfferId Text
-  deriving newtype (Eq, Show)
+  deriving newtype (Eq, Show, ToJSON, FromJSON)
 
 -- unconfirmed draft
 data BadgePlan = BPOneTime | BPMonthly | BPAnnual
@@ -172,3 +188,39 @@ data UserBadgeState = UserBadgeState
     willRenew :: Bool,
     alert :: Maybe BadgeAlert
   }
+
+instance TextEncoding BadgePurchaseStatus where
+  textEncode = \case
+    PSAcquiring -> "acquiring"
+    PSIssued -> "issued"
+    PSSuperseded -> "superseded"
+    PSFailed -> "failed"
+  textDecode = \case
+    "acquiring" -> Just PSAcquiring
+    "issued" -> Just PSIssued
+    "superseded" -> Just PSSuperseded
+    "failed" -> Just PSFailed
+    _ -> Nothing
+
+instance FromField BadgePurchaseStatus where fromField = fromTextField_ textDecode
+
+instance ToField BadgePurchaseStatus where toField = toField . textEncode
+
+instance TextEncoding BadgeCodePaymentStatus where
+  textEncode = \case
+    CPSPaid -> "paid"
+    CPSUnpaid -> "unpaid"
+    CPSFree -> "free"
+  textDecode = \case
+    "paid" -> Just CPSPaid
+    "unpaid" -> Just CPSUnpaid
+    "free" -> Just CPSFree
+    _ -> Nothing
+
+instance FromField BadgeCodePaymentStatus where fromField = fromTextField_ textDecode
+
+instance ToField BadgeCodePaymentStatus where toField = toField . textEncode
+
+$(JQ.deriveJSON (enumJSON $ dropPrefix "BIS") ''BadgeItemStatus)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "OD") ''OfferDiscount)