core: redeem badge codes (#7438)

src/Simplex/Chat/Store/Badges.hs

@@ -0,0 +1,133 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Store.Badges
+  ( BadgeCodeRedemption (..),
+    getBadgeCodeRedemption,
+    createBadgeCodeRedemption,
+    deleteBadgeCodeRedemption,
+    createCodeBadgePurchase,
+  )
+where
+
+import Control.Concurrent.STM (TVar, atomically)
+import Crypto.Random (ChaChaDRG)
+import qualified Data.Aeson as J
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Int (Int64)
+import Data.Text (Text)
+import Data.Time.Clock (UTCTime)
+import Simplex.Chat.Badges
+import Simplex.Chat.Badges.Types (BadgePurchaseStatus (..))
+import Simplex.Chat.Store.Shared (insertedRowId)
+import Simplex.Chat.Types
+import Simplex.Messaging.Agent.Store.DB (Binary (..))
+import qualified Simplex.Messaging.Agent.Store.DB as DB
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String (strEncode)
+import Simplex.Messaging.Util (maybeFirstRow, safeDecodeUtf8)
+
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple (Only (..))
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+#else
+import Database.SQLite.Simple (Only (..))
+import Database.SQLite.Simple.QQ (sql)
+#endif
+
+-- | The keys one redemption attempt is signed with, stashed before the request is sent so that a
+-- retry reaches the service as the same signer and is answered with the credential already issued.
+data BadgeCodeRedemption = BadgeCodeRedemption
+  { redemptionId :: Int64,
+    purchaseKey :: C.PublicKeyEd25519,
+    purchasePrivKey :: C.PrivateKeyEd25519,
+    masterKey :: BadgeMasterKey
+  }
+
+getBadgeCodeRedemption :: DB.Connection -> User -> Text -> IO (Maybe BadgeCodeRedemption)
+getBadgeCodeRedemption db User {userId} code =
+  maybeFirstRow toRedemption $
+    DB.query
+      db
+      [sql|
+        SELECT badge_code_redemption_id, purchase_key, purchase_priv_key, master_key
+        FROM badge_code_redemptions
+        WHERE user_id = ? AND code = ?
+      |]
+      (userId, code)
+  where
+    toRedemption (redemptionId, purchaseKey, purchasePrivKey, Binary mk) =
+      BadgeCodeRedemption {redemptionId, purchaseKey, purchasePrivKey, masterKey = BadgeMasterKey mk}
+
+createBadgeCodeRedemption :: DB.Connection -> TVar ChaChaDRG -> User -> Text -> UTCTime -> IO BadgeCodeRedemption
+createBadgeCodeRedemption db g User {userId} code now = do
+  (purchaseKey, purchasePrivKey) <- atomically $ C.generateKeyPair g
+  masterKey@(BadgeMasterKey mk) <- generateMasterKey g
+  DB.execute
+    db
+    [sql|
+      INSERT INTO badge_code_redemptions (user_id, code, purchase_key, purchase_priv_key, master_key, created_at)
+      VALUES (?,?,?,?,?,?)
+    |]
+    (userId, code, purchaseKey, purchasePrivKey, Binary mk, now)
+  redemptionId <- insertedRowId db
+  pure BadgeCodeRedemption {redemptionId, purchaseKey, purchasePrivKey, masterKey}
+
+-- | Drop a stashed attempt whose code the service refused for good, unless a purchase already
+-- came from it - badge_purchases references this row.
+deleteBadgeCodeRedemption :: DB.Connection -> Int64 -> IO ()
+deleteBadgeCodeRedemption db redemptionId =
+  DB.execute
+    db
+    [sql|
+      DELETE FROM badge_code_redemptions
+      WHERE badge_code_redemption_id = ?
+        AND NOT EXISTS (SELECT 1 FROM badge_purchases WHERE badge_code_redemption_id = ?)
+    |]
+    (redemptionId, redemptionId)
+
+-- | The purchase a redeemed code created, its issuance, and the profile's pointer to it.
+-- False when the code was already redeemed here: the service replays the credential it issued,
+-- and that must add no purchase and leave the shown badge alone. The expiry is passed in because
+-- badge_issuances requires one and the caller has already resolved it.
+createCodeBadgePurchase :: DB.Connection -> TVar ChaChaDRG -> User -> BadgeCodeRedemption -> BadgeCredential -> UTCTime -> UTCTime -> IO Bool
+createCodeBadgePurchase db g User {userId} redemption credential expiry now =
+  getCodeBadgePurchase db redemption >>= \case
+    Just _ -> pure False
+    Nothing -> do
+      purchaseId <- insertPurchase
+      DB.execute db "UPDATE users SET shown_badge_id = ? WHERE user_id = ?" (purchaseId, userId)
+      pure True
+  where
+    BadgeCodeRedemption {redemptionId, purchaseKey, purchasePrivKey, masterKey = BadgeMasterKey mk} = redemption
+    BadgeCredential {badgeInfo = BadgeInfo {badgeType}} = credential
+    insertPurchase = do
+      DB.execute
+        db
+        [sql|
+          INSERT INTO badge_purchases
+            (user_id, purchase_key, purchase_priv_key, master_key, initial_badge_type, current_badge_type, status, badge_code_redemption_id, created_at, updated_at)
+          VALUES (?,?,?,?,?,?,?,?,?,?)
+        |]
+        (userId, purchaseKey, purchasePrivKey, Binary mk, badgeType, badgeType, PSIssued, redemptionId, now, now)
+      purchaseId <- insertedRowId db
+      issuanceId <- safeDecodeUtf8 . strEncode <$> atomically (C.randomBytes 16 g)
+      -- TODO [badges] the credential's expiry stands in for the period end, which is up to a
+      -- week later, until the statement carries the real period
+      DB.execute
+        db
+        [sql|
+          INSERT INTO badge_issuances (issuance_id, badge_purchase_id, badge_type, period_start, period_end, expiry, credential, created_at)
+          VALUES (?,?,?,?,?,?,?,?)
+        |]
+        (issuanceId, purchaseId, badgeType, now, expiry, expiry, Binary (LB.toStrict $ J.encode credential), now)
+      pure purchaseId
+
+getCodeBadgePurchase :: DB.Connection -> BadgeCodeRedemption -> IO (Maybe Int64)
+getCodeBadgePurchase db BadgeCodeRedemption {redemptionId} =
+  maybeFirstRow fromOnly $
+    DB.query db "SELECT badge_purchase_id FROM badge_purchases WHERE badge_code_redemption_id = ?" (Only redemptionId)

src/Simplex/Chat/Store/Postgres/Migrations/M20261001_user_badges.hs

@@ -251,7 +251,7 @@ CREATE TABLE badge_code_redemptions(
   purchase_priv_key BYTEA NOT NULL,
   master_key BYTEA NOT NULL,
   created_at TIMESTAMPTZ NOT NULL,
-  UNIQUE(code)
+  UNIQUE(user_id, code)
 );
 
 CREATE INDEX idx_badge_code_redemptions_user ON badge_code_redemptions(user_id);

src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql

@@ -1763,12 +1763,12 @@ ALTER TABLE test_chat_schema.xftp_file_descriptions ALTER COLUMN file_descr_id A
 
 
 ALTER TABLE ONLY test_chat_schema.badge_code_redemptions
-    ADD CONSTRAINT badge_code_redemptions_code_key UNIQUE (code);
+    ADD CONSTRAINT badge_code_redemptions_pkey PRIMARY KEY (badge_code_redemption_id);
 
 
 
 ALTER TABLE ONLY test_chat_schema.badge_code_redemptions
-    ADD CONSTRAINT badge_code_redemptions_pkey PRIMARY KEY (badge_code_redemption_id);
+    ADD CONSTRAINT badge_code_redemptions_user_id_code_key UNIQUE (user_id, code);
 
 
 

src/Simplex/Chat/Store/SQLite/Migrations/M20261001_user_badges.hs

@@ -252,7 +252,7 @@ CREATE TABLE badge_code_redemptions(
   purchase_priv_key BLOB NOT NULL,
   master_key BLOB NOT NULL,
   created_at TEXT NOT NULL,
-  UNIQUE(code)
+  UNIQUE(user_id, code)
 ) STRICT;
 
 CREATE INDEX idx_badge_code_redemptions_user ON badge_code_redemptions(user_id);

src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt

@@ -1203,6 +1203,19 @@ Query:
 Plan:
 SEARCH chat_item_reactions USING INDEX idx_chat_item_reactions_group (group_id=? AND shared_msg_id=?)
 
+Query: 
+          INSERT INTO badge_issuances (issuance_id, badge_purchase_id, badge_type, period_start, period_end, expiry, credential, created_at)
+          VALUES (?,?,?,?,?,?,?,?)
+        
+Plan:
+
+Query: 
+          INSERT INTO badge_purchases
+            (user_id, purchase_key, purchase_priv_key, master_key, initial_badge_type, current_badge_type, status, badge_code_redemption_id, created_at, updated_at)
+          VALUES (?,?,?,?,?,?,?,?,?,?)
+        
+Plan:
+
 Query: 
           INSERT INTO chat_item_reactions
             (contact_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts)
@@ -3463,6 +3476,14 @@ Query:
 Plan:
 SEARCH connections USING INDEX idx_connections_to_subscribe (user_id=?)
 
+Query: 
+        SELECT badge_code_redemption_id, purchase_key, purchase_priv_key, master_key
+        FROM badge_code_redemptions
+        WHERE user_id = ? AND code = ?
+      
+Plan:
+SEARCH badge_code_redemptions USING INDEX sqlite_autoindex_badge_code_redemptions_1 (user_id=? AND code=?)
+
 Query: 
         SELECT c.agent_conn_id
         FROM connections c
@@ -4297,6 +4318,17 @@ SEARCH c USING INDEX idx_connections_to_subscribe (user_id=?)
 SEARCH m USING INTEGER PRIMARY KEY (rowid=?)
 SEARCH ug USING AUTOMATIC COVERING INDEX (group_id=?)
 
+Query: 
+      DELETE FROM badge_code_redemptions
+      WHERE badge_code_redemption_id = ?
+        AND NOT EXISTS (SELECT 1 FROM badge_purchases WHERE badge_code_redemption_id = ?)
+    
+Plan:
+SEARCH badge_code_redemptions USING INTEGER PRIMARY KEY (rowid=?)
+SCALAR SUBQUERY 1
+SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_code_redemption (badge_code_redemption_id=?)
+SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_code_redemption (badge_code_redemption_id=?)
+
 Query: 
       DELETE FROM chat_items
       WHERE group_scope_group_member_id = ?
@@ -4782,6 +4814,12 @@ LIST SUBQUERY 1
 SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
 SEARCH groups USING COVERING INDEX idx_groups_group_profile_id (group_profile_id=?)
 
+Query: 
+      INSERT INTO badge_code_redemptions (user_id, code, purchase_key, purchase_priv_key, master_key, created_at)
+      VALUES (?,?,?,?,?,?)
+    
+Plan:
+
 Query: 
       INSERT INTO calls
         (contact_id, shared_call_id, call_uuid, chat_item_id, call_state, call_ts, user_id, created_at, updated_at)
@@ -6944,6 +6982,8 @@ SEARCH connections USING COVERING INDEX idx_connections_user_contact_link_id (us
 Query: DELETE FROM users WHERE user_id = ?
 Plan:
 SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
+SEARCH badge_code_redemptions USING COVERING INDEX idx_badge_code_redemptions_user (user_id=?)
+SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_user (user_id=?)
 SEARCH chat_relays USING COVERING INDEX idx_chat_relays_user_id (user_id=?)
 SEARCH chat_tags USING COVERING INDEX idx_chat_tags_user_id (user_id=?)
 SEARCH note_folders USING COVERING INDEX note_folders_user_id (user_id=?)
@@ -7177,6 +7217,10 @@ Query: SELECT auth_err_counter FROM connections WHERE user_id = ? AND connection
 Plan:
 SEARCH connections USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: SELECT badge_purchase_id FROM badge_purchases WHERE badge_code_redemption_id = ?
+Plan:
+SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_code_redemption (badge_code_redemption_id=?)
+
 Query: SELECT c.agent_conn_id FROM connections c JOIN group_members m ON m.group_member_id = c.group_member_id WHERE m.local_display_name = ?
 Plan:
 SCAN m USING COVERING INDEX idx_group_members_user_id_local_display_name
@@ -7982,6 +8026,10 @@ Query: UPDATE users SET send_rcpts_small_groups = ? WHERE user_id = ?
 Plan:
 SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: UPDATE users SET shown_badge_id = ? WHERE user_id = ?
+Plan:
+SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
+
 Query: UPDATE users SET ui_themes = ?, updated_at = ? WHERE user_id = ?
 Plan:
 SEARCH users USING INTEGER PRIMARY KEY (rowid=?)

src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql

@@ -996,7 +996,7 @@ CREATE TABLE badge_code_redemptions(
   purchase_priv_key BLOB NOT NULL,
   master_key BLOB NOT NULL,
   created_at TEXT NOT NULL,
-  UNIQUE(code)
+  UNIQUE(user_id, code)
 ) STRICT;
 CREATE INDEX contact_profiles_index ON contact_profiles(
   display_name,