diff --git a/apps/simplex-store-service/src/StoreService/Names/Store.hs b/apps/simplex-store-service/src/StoreService/Names/Store.hs new file mode 100644 index 0000000000..68c41810d3 --- /dev/null +++ b/apps/simplex-store-service/src/StoreService/Names/Store.hs @@ -0,0 +1,897 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeOperators #-} + +module StoreService.Names.Store + ( NamePhase (..), + RegistrationPayment (..), + NameReveal (..), + NameRegistration (..), + NewRegistration (..), + PaidOrder (..), + RegistrationRefused (..), + VersionWrite (..), + LiveOrder (..), + OrderTerms (..), + PrepaidCode (..), + NewPrepaidCode (..), + CodeHashTaken (..), + TxFor (..), + TxStatus (..), + NameTransaction (..), + NewTransaction (..), + RecordChange (..), + EditState (..), + RecordEdit (..), + NewRecordEdit (..), + findLimit, + orderHash, + newRegistrationId, + methodText, + createPaidRegistration, + createCodeRegistration, + getRegistration, + getRegistrationByOrderHash, + getLiveOrders, + closeOverdue, + updateRegistration, + retargetRegistration, + findRegistrations, + isLabelRegistering, + activeRegistrations, + unpaidCleanupCandidates, + deleteUnpaidRegistration, + failedCodeOrdersBefore, + insertPrepaidCode, + getPrepaidCode, + getPrepaidCodeById, + reservePrepaidCode, + releasePrepaidCode, + spendPrepaidCode, + revokePrepaidCode, + insertTransaction, + recordTransactionOutcome, + pendingTransactions, + registrationTransactions, + editTransactions, + insertRecordEdit, + getRecordEdit, + getRecordEditByBody, + getRecordEditByNonce, + settleRecordEdit, + relayedEditTimes, + ) +where + +import qualified Control.Exception as E +import Control.Monad (when) +import Crypto.Number.Serialize (i2ospOf_) +import Data.ByteArray.Encoding (Base (Base16), convertToBase) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Int (Int64) +import Data.Maybe (isJust, listToMaybe) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Data.Time.Clock (UTCTime) +import Data.Word (Word64) +import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..)) +import Simplex.Chat.PaymentService.Types (CardProvider (..), CryptoCurrency (..), InvoiceId (..), InvoiceStatus (..), ServicePaymentMethod (..)) +import Simplex.Chat.Store.Shared (insertedRowId) +import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), FromField (..), ToField (..), fromTextField_) +import qualified Simplex.Messaging.Agent.Store.DB as DB +import Simplex.Messaging.Crypto (sha256Hash) +import Simplex.Messaging.Crypto.Secp256k1 (RecoverableSignature) +import Simplex.Messaging.Encoding.String (TextEncoding (..), strDecode) +import Simplex.Messaging.Eth.Address (Address, unAddress) +import Simplex.Messaging.Eth.EIP712 (serializeSignature) +import Simplex.Messaging.SimplexName (LabelHash (..)) +import Simplex.Messaging.Util (maybeFirstRow, tshow) +import StoreService.Names.Abi (hex) +import StoreService.Names.Phases (RegistrationId (..)) +import StoreService.Names.Signatures (OrderFields (..), parseSignature) +import StoreService.Store (RevokeResult (..)) +import StoreService.Store.Invoices (StoreDecodeError (..), executeChanging, invoiceStatusText, newInvoiceId, truncateToSecond) + +#if defined(dbPostgres) +import Database.PostgreSQL.Simple (Only (..), Query, (:.) (..)) +import Database.PostgreSQL.Simple.SqlQQ (sql) +#else +import Database.SQLite.Simple (Only (..), Query, (:.) (..)) +import Database.SQLite.Simple.QQ (sql) +#endif + +data NamePhase + = PUnpaid + | PQueued + | PCommitting + | PCommitted + | PRegistering + | PRegistered + | PTaken + | PFailed + | PCodeIssued + deriving (Eq, Show, Enum, Bounded) + +instance TextEncoding NamePhase where + textEncode = \case + PUnpaid -> "unpaid" + PQueued -> "queued" + PCommitting -> "committing" + PCommitted -> "committed" + PRegistering -> "registering" + PRegistered -> "registered" + PTaken -> "taken" + PFailed -> "failed" + PCodeIssued -> "code_issued" + textDecode t = lookup t [(textEncode p, p) | p <- [minBound .. maxBound]] + +instance FromField NamePhase where fromField = fromTextField_ textDecode + +instance ToField NamePhase where toField = toField . textEncode + +data RegistrationPayment + = RPInvoice ServicePaymentMethod InvoiceId + | RPCode Int64 + deriving (Eq, Show) + +-- | The name, links and owner's intent, all set by an accepted reveal and cleared together. +data NameReveal = NameReveal + { rvLabel :: Text, + rvSecret :: ByteString, + rvContactLink :: Maybe Text, + rvChannelLink :: Maybe Text, + rvNonce :: Word64, + rvDeadline :: Word64, + rvSignature :: RecoverableSignature + } + deriving (Eq, Show) + +data NameRegistration = NameRegistration + { nrId :: RegistrationId, + nrVersion :: Int64, + nrLabelHash :: LabelHash, + nrLength :: Int, + nrDuration :: Word64, + nrOwner :: Address, + nrCommitment :: ByteString, + nrSealed :: Text, + nrPhase :: NamePhase, + nrYears :: Int, + nrPrice :: Int, + nrPayment :: RegistrationPayment, + nrReveal :: Maybe NameReveal, + nrCommitTx :: Maybe ByteString, + nrCommitBlock :: Maybe Word64, + nrRegisterTx :: Maybe ByteString, + nrRegisterBlock :: Maybe Word64, + nrRevealAfter :: Maybe Word64, + nrRevealBefore :: Maybe Word64, + nrExpiresAt :: Maybe Word64, + nrIssuedCodeId :: Maybe Int64, + nrRegisteredAt :: Maybe UTCTime, + nrFailedAt :: Maybe UTCTime, + nrError :: Maybe Text, + nrLive :: Bool, + nrOrderHash :: ByteString, + nrMoves :: Int, + nrLinksRefusedAt :: Maybe UTCTime, + nrCreatedAt :: UTCTime, + nrUpdatedAt :: UTCTime + } + deriving (Eq, Show) + +data NewRegistration = NewRegistration + { nrgId :: RegistrationId, + nrgOwner :: Address, + nrgOrder :: OrderFields, + nrgYears :: Int + } + +-- | The invoice row is inserted by the caller, in the same transaction and before the registration. +data PaidOrder = PaidOrder + { poMethod :: ServicePaymentMethod, + poPrice :: Int, + poInvoiceId :: InvoiceId, + poProviderRef :: Text + } + +data RegistrationRefused = RRLiveOrder | RRCodeNotReservable + deriving (Eq, Show) + +data VersionWrite = Written Int64 | VersionChanged + deriving (Eq, Show) + +-- | A live order an order request meets; overdue when its open invoice is past its expiry time. +data LiveOrder = LiveOrder + { loRegistration :: NameRegistration, + loOverdue :: Bool + } + deriving (Eq, Show) + +-- | What an order pays with, as its hash covers it. +data OrderTerms = OTInvoice ServicePaymentMethod Int | OTCode ByteString + +data PrepaidCode = PrepaidCode + { pcId :: Int64, + pcCodeHash :: ByteString, + pcMinLength :: Int, + pcYears :: Int, + pcPaymentStatus :: BadgeCodePaymentStatus, + pcReservedBy :: Maybe RegistrationId, + pcReservedAt :: Maybe UTCTime, + pcSpentAt :: Maybe UTCTime, + pcRevokedAt :: Maybe UTCTime, + pcExpiresAt :: Maybe UTCTime, + pcCreatedAt :: UTCTime + } + deriving (Eq, Show) + +data NewPrepaidCode = NewPrepaidCode + { npcCodeHash :: ByteString, + npcMinLength :: Int, + npcYears :: Int, + npcPaymentStatus :: BadgeCodePaymentStatus, + npcExpiresAt :: Maybe UTCTime + } + +data CodeHashTaken = CodeHashTaken + deriving (Eq, Show) + +data TxFor = TxCommit RegistrationId | TxRegister RegistrationId | TxEdit Int64 + deriving (Eq, Show) + +-- | A dropped transaction was never mined and its registrar nonce went to another one. +data TxStatus = TSPending | TSMined | TSReverted | TSDropped + deriving (Eq, Show, Enum, Bounded) + +instance TextEncoding TxStatus where + textEncode = \case + TSPending -> "pending" + TSMined -> "mined" + TSReverted -> "reverted" + TSDropped -> "dropped" + textDecode t = lookup t [(textEncode s, s) | s <- [minBound .. maxBound]] + +instance FromField TxStatus where fromField = fromTextField_ textDecode + +instance ToField TxStatus where toField = toField . textEncode + +data NameTransaction = NameTransaction + { ntId :: Int64, + ntFor :: TxFor, + ntRaw :: ByteString, + ntHash :: ByteString, + ntNonce :: Word64, + ntSentAt :: UTCTime, + ntMinedBlock :: Maybe Word64, + ntStatus :: TxStatus + } + deriving (Eq, Show) + +data NewTransaction = NewTransaction + { ntxRaw :: ByteString, + ntxHash :: ByteString, + ntxNonce :: Word64 + } + +-- | A text record set to a value, "" removing it, or every record cleared. +data RecordChange = RCSetText Text Text | RCClear + deriving (Eq, Show) + +data EditState = ESPending | ESMined (Maybe ByteString) | ESReverted (Maybe Text) + deriving (Eq, Show) + +data RecordEdit = RecordEdit + { reId :: Int64, + reLabelHash :: LabelHash, + reOwner :: Address, + reNonce :: Word64, + reChange :: RecordChange, + reDeadline :: Word64, + reSignature :: RecoverableSignature, + reBodyHash :: ByteString, + reState :: EditState, + reCreatedAt :: UTCTime + } + deriving (Eq, Show) + +data NewRecordEdit = NewRecordEdit + { nreLabelHash :: LabelHash, + nreOwner :: Address, + nreNonce :: Word64, + nreChange :: RecordChange, + nreDeadline :: Word64, + nreSignature :: RecoverableSignature, + nreBodyHash :: ByteString + } + +findLimit :: Int +findLimit = 50 + +initialVersion :: Int64 +initialVersion = 1 + +orderHashFieldBytes :: Int +orderHashFieldBytes = 4 + +-- | Each field is length-prefixed, so no two different orders encode the same. +orderHash :: Address -> OrderFields -> OrderTerms -> ByteString +orderHash owner OrderFields {ofLabelHash = LabelHash lh, ofLength, ofDuration, ofCommitment, ofSealed} terms = + sha256Hash . B.concat . map field $ [tag, lh, num ofLength, num ofDuration, unAddress owner, ofCommitment, encodeUtf8 ofSealed] <> payment + where + (tag, payment) = case terms of + OTInvoice method price -> ("name-invoice", [encodeUtf8 $ methodText method, num price]) + OTCode codeHash -> ("name-code", [codeHash]) + field bs = i2ospOf_ orderHashFieldBytes (toInteger $ B.length bs) <> bs + num :: Show a => a -> ByteString + num = encodeUtf8 . tshow + +newRegistrationId :: IO RegistrationId +newRegistrationId = (\(InvoiceId t) -> RegistrationId t) <$> newInvoiceId + +methodText :: ServicePaymentMethod -> Text +methodText = \case + SPMCard CPStripe -> "card" + SPMCrypto CCBtc -> "btc" + SPMCrypto CCXmr -> "xmr" + +textMethod :: Text -> Maybe ServicePaymentMethod +textMethod t = lookup t [(methodText m, m) | m <- [SPMCard CPStripe, SPMCrypto CCBtc, SPMCrypto CCXmr]] + +createPaidRegistration :: DB.Connection -> NewRegistration -> PaidOrder -> UTCTime -> IO (Either RegistrationRefused ()) +createPaidRegistration db new@NewRegistration {nrgId = RegistrationId rid, nrgOwner, nrgOrder} PaidOrder {poMethod, poPrice, poInvoiceId = InvoiceId invId, poProviderRef} now' = do + let now = truncateToSecond now' + hash = orderHash nrgOwner nrgOrder (OTInvoice poMethod poPrice) + inserted <- insertRegistration db new PUnpaid poPrice (Just poMethod) Nothing hash now + when inserted $ + DB.execute + db + "INSERT INTO sx_badge_service_name_invoices (invoice_id, registration_id, provider_ref, created_at) VALUES (?,?,?,?)" + (invId, rid, poProviderRef, now) + pure $ if inserted then Right () else Left RRLiveOrder + +-- | Reserving the code is the conditional update of the transaction that creates the registration. +createCodeRegistration :: DB.Connection -> NewRegistration -> PrepaidCode -> UTCTime -> IO (Either RegistrationRefused ()) +createCodeRegistration db new@NewRegistration {nrgId = regId@(RegistrationId rid), nrgOwner, nrgOrder} PrepaidCode {pcId, pcCodeHash} now' = do + let now = truncateToSecond now' + inserted <- insertRegistration db new PQueued 0 Nothing (Just pcId) (orderHash nrgOwner nrgOrder (OTCode pcCodeHash)) now + if not inserted + then pure $ Left RRLiveOrder + else + reservePrepaidCode db pcId regId now >>= \case + True -> pure $ Right () + False -> do + DB.execute db "DELETE FROM sx_badge_service_name_registrations WHERE registration_id = ?" (Only rid) + pure $ Left RRCodeNotReservable + +-- | False when the registration would be a second live one for its commitment, or for its owner and label hash. +insertRegistration :: DB.Connection -> NewRegistration -> NamePhase -> Int -> Maybe ServicePaymentMethod -> Maybe Int64 -> ByteString -> UTCTime -> IO Bool +insertRegistration db NewRegistration {nrgId = RegistrationId rid, nrgOwner, nrgOrder, nrgYears} phase price method codeId hash now = + (> 0) + <$> executeChanging + db + [sql| + INSERT INTO sx_badge_service_name_registrations + (registration_id, version, label_hash, length, duration, owner, commitment, sealed, phase, years, + price, method, name_prepaid_code_id, live, order_hash, moves, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?, ?,?,?,?,?,?,?,?) + ON CONFLICT DO NOTHING + |] + ( (rid, initialVersion, Binary lh, ofLength, int64 ofDuration, Binary $ unAddress nrgOwner, Binary ofCommitment, ofSealed, phase, nrgYears) + :. (price, methodText <$> method, codeId, BI True, Binary hash, 0 :: Int, now, now) + ) + where + OrderFields {ofLabelHash = LabelHash lh, ofLength, ofDuration, ofCommitment, ofSealed} = nrgOrder + +registrationColumns :: Query +registrationColumns = + [sql| + SELECT r.registration_id, r.version, r.label_hash, r.length, r.duration, r.owner, r.commitment, r.sealed, r.phase, r.years, + r.price, r.method, ni.invoice_id, r.name_prepaid_code_id, r.label, r.secret, r.contact_link, r.channel_link, r.intent_nonce, r.intent_deadline, + r.intent_signature, r.commit_tx, r.commit_block, r.register_tx, r.register_block, r.reveal_after, r.reveal_before, r.expires_at, r.issued_code_id, r.registered_at, + r.failed_at, r.error, r.live, r.order_hash, r.moves, r.links_refused_at, r.created_at, r.updated_at + |] + +registrationFrom :: Query +registrationFrom = + [sql| + FROM sx_badge_service_name_registrations r + LEFT JOIN sx_badge_service_name_invoices ni ON ni.registration_id = r.registration_id + |] + +selectRegistrations :: Query +selectRegistrations = registrationColumns <> registrationFrom + +type RegistrationRow = + (Text, Int64, Binary ByteString, Int, Int64, Binary ByteString, Binary ByteString, Text, NamePhase, Int) + :. (Int, Maybe Text, Maybe Text, Maybe Int64, Maybe Text, Maybe (Binary ByteString), Maybe Text, Maybe Text, Maybe Int64, Maybe Int64) + :. (Maybe (Binary ByteString), Maybe (Binary ByteString), Maybe Int64, Maybe (Binary ByteString), Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe UTCTime) + :. (Maybe UTCTime, Maybe Text, BoolInt, Binary ByteString, Int, Maybe UTCTime, UTCTime, UTCTime) + +toRegistration :: RegistrationRow -> Either Text NameRegistration +toRegistration + ( (rid, nrVersion, Binary lh, nrLength, duration, Binary owner, Binary nrCommitment, nrSealed, nrPhase, nrYears) + :. (nrPrice, method_, invoiceId_, codeId_, label_, secret_, nrContactLink, nrChannelLink, nonce_, deadline_) + :. (signature_, commitTx, commitBlock, registerTx, registerBlock, revealAfter, revealBefore, expiresAt, nrIssuedCodeId, nrRegisteredAt) + :. (nrFailedAt, nrError, BI nrLive, Binary nrOrderHash, nrMoves, nrLinksRefusedAt, nrCreatedAt, nrUpdatedAt) + ) = do + nrOwner <- decodeAddress owner + nrPayment <- case (method_, invoiceId_, codeId_) of + (Just m, Just invId, Nothing) -> (`RPInvoice` InvoiceId invId) <$> note ("name_registrations.method: " <> m) (textMethod m) + (Nothing, Nothing, Just codeId) -> Right $ RPCode codeId + _ -> Left $ "name_registrations payment: " <> rid + nrReveal <- case (label_, secret_, nonce_, deadline_, signature_) of + (Nothing, Nothing, Nothing, Nothing, Nothing) -> Right Nothing + (Just rvLabel, Just (Binary rvSecret), Just nonce, Just deadline, Just (Binary sig)) -> do + rvSignature <- decodeSignature sig + Right $ Just NameReveal {rvLabel, rvSecret, rvContactLink = nrContactLink, rvChannelLink = nrChannelLink, rvNonce = word64 nonce, rvDeadline = word64 deadline, rvSignature} + _ -> Left $ "name_registrations reveal: " <> rid + pure + NameRegistration + { nrId = RegistrationId rid, + nrVersion, + nrLabelHash = LabelHash lh, + nrLength, + nrDuration = word64 duration, + nrOwner, + nrCommitment, + nrSealed, + nrPhase, + nrYears, + nrPrice, + nrPayment, + nrReveal, + nrCommitTx = fromBinary <$> commitTx, + nrCommitBlock = word64 <$> commitBlock, + nrRegisterTx = fromBinary <$> registerTx, + nrRegisterBlock = word64 <$> registerBlock, + nrRevealAfter = word64 <$> revealAfter, + nrRevealBefore = word64 <$> revealBefore, + nrExpiresAt = word64 <$> expiresAt, + nrIssuedCodeId, + nrRegisteredAt, + nrFailedAt, + nrError, + nrLive, + nrOrderHash, + nrMoves, + nrLinksRefusedAt, + nrCreatedAt, + nrUpdatedAt + } + +getRegistration :: DB.Connection -> RegistrationId -> IO (Maybe NameRegistration) +getRegistration db (RegistrationId rid) = + firstDecoded toRegistration $ DB.query db (selectRegistrations <> " WHERE r.registration_id = ?") (Only rid) + +-- | The newest stored order, live or not, with exactly these fields. +getRegistrationByOrderHash :: DB.Connection -> ByteString -> IO (Maybe NameRegistration) +getRegistrationByOrderHash db hash = + firstDecoded toRegistration $ + DB.query db (selectRegistrations <> " WHERE r.order_hash = ? ORDER BY r.created_at DESC LIMIT 1") (Only $ Binary hash) + +-- | Overdue whatever status the poller has marked, as long as the invoice is not paid. +getLiveOrders :: DB.Connection -> ByteString -> Address -> LabelHash -> UTCTime -> IO [LiveOrder] +getLiveOrders db commitment owner (LabelHash lh) now = + DB.query + db + ( registrationColumns + <> ", CASE WHEN r.phase = ? AND i.status <> ? AND i.expires_at < ? THEN 1 ELSE 0 END" + <> registrationFrom + <> " LEFT JOIN sx_badge_service_invoices i ON i.invoice_id = ni.invoice_id" + <> " WHERE r.live = 1 AND (r.commitment = ? OR (r.owner = ? AND r.label_hash = ?))" + ) + (PUnpaid, invoiceStatusText ISPaid, truncateToSecond now, Binary commitment, Binary $ unAddress owner, Binary lh) + >>= decodeAll toLiveOrder + where + toLiveOrder (row :. Only (BI loOverdue)) = (\loRegistration -> LiveOrder {loRegistration, loOverdue}) <$> toRegistration row + +-- | Run in the transaction that inserts the next order, so the unique constraints let it in. +closeOverdue :: DB.Connection -> NameRegistration -> UTCTime -> IO VersionWrite +closeOverdue db r@NameRegistration {nrId = RegistrationId rid} now = do + written <- updateRegistration db r {nrLive = False} now + when (written /= VersionChanged) $ + DB.execute + db + [sql| + UPDATE sx_badge_service_invoices SET status = ?, updated_at = ? + WHERE status = ? AND invoice_id IN (SELECT invoice_id FROM sx_badge_service_name_invoices WHERE registration_id = ?) + |] + (invoiceStatusText ISExpired, truncateToSecond now, invoiceStatusText ISOpen, rid) + pure written + +-- | Writes every changeable field of a registration read at its nrVersion, unless it changed since. +-- An unpaid registration keeps the given nrLive, which only its invoice decides. +updateRegistration :: DB.Connection -> NameRegistration -> UTCTime -> IO VersionWrite +updateRegistration db r now = do + changed <- + executeChanging + db + [sql| + UPDATE sx_badge_service_name_registrations + SET version = version + 1, label_hash = ?, length = ?, duration = ?, commitment = ?, sealed = ?, phase = ?, price = ?, + label = ?, secret = ?, contact_link = ?, channel_link = ?, intent_nonce = ?, intent_deadline = ?, intent_signature = ?, + commit_tx = ?, commit_block = ?, register_tx = ?, register_block = ?, reveal_after = ?, reveal_before = ?, expires_at = ?, + issued_code_id = ?, registered_at = ?, failed_at = ?, error = ?, live = ?, moves = ?, links_refused_at = ?, updated_at = ? + WHERE registration_id = ? AND version = ? + |] + ( (Binary lh, nrLength, int64 nrDuration, Binary nrCommitment, nrSealed, nrPhase, nrPrice) + :. (rvLabel <$> nrReveal, Binary . rvSecret <$> nrReveal, rvContactLink =<< nrReveal, rvChannelLink =<< nrReveal, int64 . rvNonce <$> nrReveal, int64 . rvDeadline <$> nrReveal, Binary . serializeSignature . rvSignature <$> nrReveal) + :. (Binary <$> nrCommitTx, int64 <$> nrCommitBlock, Binary <$> nrRegisterTx, int64 <$> nrRegisterBlock, int64 <$> nrRevealAfter, int64 <$> nrRevealBefore, int64 <$> nrExpiresAt) + :. (nrIssuedCodeId, truncateToSecond <$> nrRegisteredAt, truncateToSecond <$> nrFailedAt, nrError, BI live, nrMoves, truncateToSecond <$> nrLinksRefusedAt, truncateToSecond now) + :. (rid, nrVersion) + ) + pure $ if changed > 0 then Written (nrVersion + 1) else VersionChanged + where + NameRegistration {nrId = RegistrationId rid, nrVersion, nrLabelHash = LabelHash lh, nrLength, nrDuration, nrCommitment, nrSealed, nrPhase, nrPrice, nrReveal} = r + NameRegistration {nrCommitTx, nrCommitBlock, nrRegisterTx, nrRegisterBlock, nrRevealAfter, nrRevealBefore, nrExpiresAt} = r + NameRegistration {nrIssuedCodeId, nrRegisteredAt, nrFailedAt, nrError, nrLive, nrMoves, nrLinksRefusedAt} = r + live = case nrPhase of + PUnpaid -> nrLive + PTaken -> False + PCodeIssued -> False + _ -> True + +-- | Another name, or other links: queued again with the reveal, transactions, reveal times and link refusal cleared. +-- The order hash stays the original order's, so a resend of that order still finds it. +retargetRegistration :: DB.Connection -> NameRegistration -> OrderFields -> Int -> UTCTime -> IO VersionWrite +retargetRegistration db r OrderFields {ofLabelHash, ofLength, ofDuration, ofCommitment, ofSealed} price = + updateRegistration + db + r + { nrLabelHash = ofLabelHash, + nrLength = ofLength, + nrDuration = ofDuration, + nrCommitment = ofCommitment, + nrSealed = ofSealed, + nrPrice = price, + nrPhase = PQueued, + nrMoves = nrMoves r + 1, + nrReveal = Nothing, + nrCommitTx = Nothing, + nrCommitBlock = Nothing, + nrRegisterTx = Nothing, + nrRegisterBlock = Nothing, + nrRevealAfter = Nothing, + nrRevealBefore = Nothing, + nrLinksRefusedAt = Nothing, + nrFailedAt = Nothing, + nrError = Nothing + } + +-- | Newest first, at most findLimit. +findRegistrations :: DB.Connection -> Address -> IO [NameRegistration] +findRegistrations db owner = + DB.query db (selectRegistrations <> " WHERE r.owner = ? ORDER BY r.created_at DESC LIMIT ?") (Binary $ unAddress owner, findLimit) + >>= decodeAll toRegistration + +isLabelRegistering :: DB.Connection -> LabelHash -> IO Bool +isLabelRegistering db (LabelHash lh) = + not . null + <$> ( DB.query db "SELECT 1 FROM sx_badge_service_name_registrations WHERE label_hash = ? AND phase = ? LIMIT 1" (Binary lh, PRegistering) :: + IO [Only Int] + ) + +-- | The registrations a worker moves on, oldest first. +activeRegistrations :: DB.Connection -> IO [NameRegistration] +activeRegistrations db = + DB.query db (selectRegistrations <> " WHERE r.phase IN (?,?,?,?) ORDER BY r.created_at") (PQueued, PCommitting, PCommitted, PRegistering) + >>= decodeAll toRegistration + +unpaidCleanupCandidates :: DB.Connection -> UTCTime -> IO [(RegistrationId, InvoiceId)] +unpaidCleanupCandidates db createdBefore = + map (\(rid, invId) -> (RegistrationId rid, InvoiceId invId)) + <$> DB.query + db + [sql| + SELECT r.registration_id, ni.invoice_id + FROM sx_badge_service_name_registrations r + JOIN sx_badge_service_name_invoices ni ON ni.registration_id = r.registration_id + WHERE r.phase = ? AND r.created_at < ? + ORDER BY r.created_at + |] + (PUnpaid, truncateToSecond createdBefore) + +-- | Deletes an unpaid registration and its invoice, unless a payment was recorded for it. +deleteUnpaidRegistration :: DB.Connection -> RegistrationId -> IO Bool +deleteUnpaidRegistration db (RegistrationId rid) = do + invoiceIds <- DB.query db "SELECT invoice_id FROM sx_badge_service_name_invoices WHERE registration_id = ?" (Only rid) + deleted <- + executeChanging + db + [sql| + DELETE FROM sx_badge_service_name_registrations + WHERE registration_id = ? AND phase = ? + AND NOT EXISTS ( + SELECT 1 FROM sx_badge_service_name_invoices ni + JOIN sx_badge_service_payments p ON p.invoice_id = ni.invoice_id + WHERE ni.registration_id = ? + ) + |] + (rid, PUnpaid, rid) + when (deleted > 0) $ + mapM_ (DB.execute db "DELETE FROM sx_badge_service_invoices WHERE invoice_id = ?" . Only . fromOnly) (invoiceIds :: [Only Text]) + pure $ deleted > 0 + +-- | Code orders failed before the cutoff that still hold their unspent code. +failedCodeOrdersBefore :: DB.Connection -> UTCTime -> IO [(RegistrationId, Int64)] +failedCodeOrdersBefore db cutoff = + map (\(rid, codeId) -> (RegistrationId rid, codeId)) + <$> DB.query + db + [sql| + SELECT r.registration_id, c.name_prepaid_code_id + FROM sx_badge_service_name_registrations r + JOIN sx_badge_service_name_prepaid_codes c ON c.reserved_by = r.registration_id + WHERE r.phase = ? AND r.failed_at < ? AND c.spent_at IS NULL + ORDER BY r.failed_at + |] + (PFailed, truncateToSecond cutoff) + +insertPrepaidCode :: DB.Connection -> NewPrepaidCode -> UTCTime -> IO (Either CodeHashTaken Int64) +insertPrepaidCode db NewPrepaidCode {npcCodeHash, npcMinLength, npcYears, npcPaymentStatus, npcExpiresAt} now = do + inserted <- + executeChanging + db + [sql| + INSERT INTO sx_badge_service_name_prepaid_codes (code_hash, min_length, years, code_payment_status, expires_at, created_at) + VALUES (?,?,?,?,?,?) + ON CONFLICT DO NOTHING + |] + (Binary npcCodeHash, npcMinLength, npcYears, npcPaymentStatus, truncateToSecond <$> npcExpiresAt, truncateToSecond now) + if inserted > 0 then Right <$> insertedRowId db else pure $ Left CodeHashTaken + +prepaidCodeColumns :: Query +prepaidCodeColumns = + [sql| + SELECT name_prepaid_code_id, code_hash, min_length, years, code_payment_status, reserved_by, reserved_at, spent_at, revoked_at, expires_at, created_at + FROM sx_badge_service_name_prepaid_codes + |] + +type PrepaidCodeRow = (Int64, Binary ByteString, Int, Int, BadgeCodePaymentStatus, Maybe Text, Maybe UTCTime, Maybe UTCTime, Maybe UTCTime, Maybe UTCTime) :. Only UTCTime + +toPrepaidCode :: PrepaidCodeRow -> PrepaidCode +toPrepaidCode ((pcId, Binary pcCodeHash, pcMinLength, pcYears, pcPaymentStatus, reservedBy, pcReservedAt, pcSpentAt, pcRevokedAt, pcExpiresAt) :. Only pcCreatedAt) = + PrepaidCode {pcId, pcCodeHash, pcMinLength, pcYears, pcPaymentStatus, pcReservedBy = RegistrationId <$> reservedBy, pcReservedAt, pcSpentAt, pcRevokedAt, pcExpiresAt, pcCreatedAt} + +getPrepaidCode :: DB.Connection -> ByteString -> IO (Maybe PrepaidCode) +getPrepaidCode db codeHash = + maybeFirstRow toPrepaidCode $ DB.query db (prepaidCodeColumns <> " WHERE code_hash = ?") (Only $ Binary codeHash) + +getPrepaidCodeById :: DB.Connection -> Int64 -> IO (Maybe PrepaidCode) +getPrepaidCodeById db codeId = + maybeFirstRow toPrepaidCode $ DB.query db (prepaidCodeColumns <> " WHERE name_prepaid_code_id = ?") (Only codeId) + +-- | Only an unused code: not reserved, spent or revoked, paid or free, and not expired. +reservePrepaidCode :: DB.Connection -> Int64 -> RegistrationId -> UTCTime -> IO Bool +reservePrepaidCode db codeId (RegistrationId rid) now' = + (> 0) + <$> executeChanging + db + [sql| + UPDATE sx_badge_service_name_prepaid_codes SET reserved_by = ?, reserved_at = ? + WHERE name_prepaid_code_id = ? AND reserved_by IS NULL AND spent_at IS NULL AND revoked_at IS NULL + AND code_payment_status <> ? AND (expires_at IS NULL OR expires_at > ?) + |] + (rid, now, codeId, CPSUnpaid, now) + where + now = truncateToSecond now' + +releasePrepaidCode :: DB.Connection -> Int64 -> RegistrationId -> IO Bool +releasePrepaidCode db codeId (RegistrationId rid) = + (> 0) + <$> executeChanging + db + [sql| + UPDATE sx_badge_service_name_prepaid_codes SET reserved_by = NULL, reserved_at = NULL + WHERE name_prepaid_code_id = ? AND reserved_by = ? AND spent_at IS NULL + |] + (codeId, rid) + +-- | A spent code keeps reserved_by, naming the registration it paid for. +spendPrepaidCode :: DB.Connection -> Int64 -> RegistrationId -> UTCTime -> IO Bool +spendPrepaidCode db codeId (RegistrationId rid) now = + (> 0) + <$> executeChanging + db + "UPDATE sx_badge_service_name_prepaid_codes SET spent_at = ? WHERE name_prepaid_code_id = ? AND reserved_by = ? AND spent_at IS NULL" + (truncateToSecond now, codeId, rid) + +-- | A reserved code can be revoked, and its order keeps it; a spent one cannot. +revokePrepaidCode :: DB.Connection -> ByteString -> UTCTime -> IO RevokeResult +revokePrepaidCode db codeHash now = do + revoked <- + executeChanging + db + "UPDATE sx_badge_service_name_prepaid_codes SET revoked_at = ? WHERE code_hash = ? AND revoked_at IS NULL AND spent_at IS NULL" + (truncateToSecond now, Binary codeHash) + maybe NoSuchCode (result revoked) <$> getPrepaidCode db codeHash + where + result revoked PrepaidCode {pcId, pcRevokedAt} + | revoked > 0 = Revoked pcId + | isJust pcRevokedAt = AlreadyRevoked pcId + | otherwise = AlreadyRedeemed + +txKind :: TxFor -> (Text, Maybe Text, Maybe Int64) +txKind = \case + TxCommit (RegistrationId rid) -> ("commit", Just rid, Nothing) + TxRegister (RegistrationId rid) -> ("register", Just rid, Nothing) + TxEdit editId -> ("edit", Nothing, Just editId) + +-- | Saved once signed and before it is sent, so a restart can rebroadcast it. +insertTransaction :: DB.Connection -> TxFor -> NewTransaction -> UTCTime -> IO Int64 +insertTransaction db for NewTransaction {ntxRaw, ntxHash, ntxNonce} now = do + let (kind, rid, editId) = txKind for + DB.execute + db + [sql| + INSERT INTO sx_badge_service_name_transactions + (registration_id, name_record_edit_id, kind, raw, tx_hash, registrar_nonce, sent_at, status) + VALUES (?,?,?,?,?,?,?,?) + |] + (rid, editId, kind, Binary ntxRaw, Binary ntxHash, int64 ntxNonce, truncateToSecond now, TSPending) + insertedRowId db + +recordTransactionOutcome :: DB.Connection -> ByteString -> TxStatus -> Maybe Word64 -> IO Bool +recordTransactionOutcome db hash status block = + (> 0) + <$> executeChanging + db + "UPDATE sx_badge_service_name_transactions SET status = ?, mined_block = ? WHERE tx_hash = ?" + (status, int64 <$> block, Binary hash) + +transactionColumns :: Query +transactionColumns = + [sql| + SELECT name_transaction_id, kind, registration_id, name_record_edit_id, raw, tx_hash, registrar_nonce, sent_at, mined_block, status + FROM sx_badge_service_name_transactions + |] + +type TransactionRow = (Int64, Text, Maybe Text, Maybe Int64, Binary ByteString, Binary ByteString, Int64, UTCTime, Maybe Int64, TxStatus) + +toTransaction :: TransactionRow -> Either Text NameTransaction +toTransaction (ntId, kind, rid_, editId_, Binary ntRaw, Binary ntHash, nonce, ntSentAt, block, ntStatus) = do + ntFor <- case (kind, rid_, editId_) of + ("commit", Just rid, Nothing) -> Right $ TxCommit $ RegistrationId rid + ("register", Just rid, Nothing) -> Right $ TxRegister $ RegistrationId rid + ("edit", Nothing, Just editId) -> Right $ TxEdit editId + _ -> Left $ "name_transactions.kind: " <> kind + pure NameTransaction {ntId, ntFor, ntRaw, ntHash, ntNonce = word64 nonce, ntSentAt, ntMinedBlock = word64 <$> block, ntStatus} + +-- | Those without a receipt, in nonce order, for the sender to resume. +pendingTransactions :: DB.Connection -> IO [NameTransaction] +pendingTransactions db = + DB.query db (transactionColumns <> " WHERE status = ? ORDER BY registrar_nonce, name_transaction_id") (Only TSPending) + >>= decodeAll toTransaction + +registrationTransactions :: DB.Connection -> RegistrationId -> IO [NameTransaction] +registrationTransactions db (RegistrationId rid) = + DB.query db (transactionColumns <> " WHERE registration_id = ? ORDER BY name_transaction_id") (Only rid) + >>= decodeAll toTransaction + +editTransactions :: DB.Connection -> Int64 -> IO [NameTransaction] +editTransactions db editId = + DB.query db (transactionColumns <> " WHERE name_record_edit_id = ? ORDER BY name_transaction_id") (Only editId) + >>= decodeAll toTransaction + +pendingEdit :: Text +pendingEdit = "pending" + +minedEdit :: Text +minedEdit = "mined" + +revertedEdit :: Text +revertedEdit = "reverted" + +-- | Nothing when a pending or mined edit already holds the owner's nonce. +insertRecordEdit :: DB.Connection -> NewRecordEdit -> UTCTime -> IO (Maybe Int64) +insertRecordEdit db NewRecordEdit {nreLabelHash = LabelHash lh, nreOwner, nreNonce, nreChange, nreDeadline, nreSignature, nreBodyHash} now = do + let (key, value) = case nreChange of + RCSetText k v -> (Just k, Just v) + RCClear -> (Nothing, Nothing) + inserted <- + executeChanging + db + [sql| + INSERT INTO sx_badge_service_name_record_edits + (label_hash, owner, nonce, record_key, record_value, deadline, signature, body_hash, state, created_at) + VALUES (?,?,?,?,?,?,?,?,?,?) + ON CONFLICT DO NOTHING + |] + ( (Binary lh, Binary $ unAddress nreOwner, int64 nreNonce, key, value, int64 nreDeadline, Binary $ serializeSignature nreSignature, Binary nreBodyHash) + :. (pendingEdit, truncateToSecond now) + ) + if inserted > 0 then Just <$> insertedRowId db else pure Nothing + +recordEditColumns :: Query +recordEditColumns = + [sql| + SELECT name_record_edit_id, label_hash, owner, nonce, record_key, record_value, deadline, signature, body_hash, state, revert, mined_tx, created_at + FROM sx_badge_service_name_record_edits + |] + +type RecordEditRow = + (Int64, Binary ByteString, Binary ByteString, Int64, Maybe Text, Maybe Text, Int64, Binary ByteString, Binary ByteString, Text) + :. (Maybe Text, Maybe (Binary ByteString), UTCTime) + +toRecordEdit :: RecordEditRow -> Either Text RecordEdit +toRecordEdit ((reId, Binary lh, Binary owner, nonce, key_, value_, deadline, Binary sig, Binary reBodyHash, state) :. (revert, minedTx, reCreatedAt)) = do + reOwner <- decodeAddress owner + reSignature <- decodeSignature sig + reChange <- case (key_, value_) of + (Just key, Just value) -> Right $ RCSetText key value + (Nothing, Nothing) -> Right RCClear + _ -> Left $ "name_record_edits record: " <> tshow reId + reState <- decodeState + pure RecordEdit {reId, reLabelHash = LabelHash lh, reOwner, reNonce = word64 nonce, reChange, reDeadline = word64 deadline, reSignature, reBodyHash, reState, reCreatedAt} + where + decodeState + | state == pendingEdit = Right ESPending + | state == minedEdit = Right $ ESMined $ fromBinary <$> minedTx + | state == revertedEdit = Right $ ESReverted revert + | otherwise = Left $ "name_record_edits.state: " <> state + +getRecordEdit :: DB.Connection -> Int64 -> IO (Maybe RecordEdit) +getRecordEdit db editId = + firstDecoded toRecordEdit $ DB.query db (recordEditColumns <> " WHERE name_record_edit_id = ?") (Only editId) + +-- | The newest edit sent with this signed body. +getRecordEditByBody :: DB.Connection -> ByteString -> IO (Maybe RecordEdit) +getRecordEditByBody db bodyHash = + firstDecoded toRecordEdit $ + DB.query db (recordEditColumns <> " WHERE body_hash = ? ORDER BY name_record_edit_id DESC LIMIT 1") (Only $ Binary bodyHash) + +-- | The pending or mined edit holding the owner's nonce. +getRecordEditByNonce :: DB.Connection -> Address -> Word64 -> IO (Maybe RecordEdit) +getRecordEditByNonce db owner nonce = + firstDecoded toRecordEdit $ + DB.query db (recordEditColumns <> " WHERE owner = ? AND nonce = ? AND state IN (?,?)") (Binary $ unAddress owner, int64 nonce, pendingEdit, minedEdit) + +-- | Settles a pending edit; False when it was settled already. +settleRecordEdit :: DB.Connection -> Int64 -> EditState -> IO Bool +settleRecordEdit db editId state = + (> 0) + <$> executeChanging + db + "UPDATE sx_badge_service_name_record_edits SET state = ?, revert = ?, mined_tx = ? WHERE name_record_edit_id = ? AND state = ?" + (stateText, revert, Binary <$> minedTx, editId, pendingEdit) + where + (stateText, revert, minedTx) = case state of + ESPending -> (pendingEdit, Nothing, Nothing) + ESMined tx -> (minedEdit, Nothing, tx) + ESReverted name -> (revertedEdit, name, Nothing) + +-- | When each edit relayed for the name since the given time was sent, oldest first. +relayedEditTimes :: DB.Connection -> LabelHash -> UTCTime -> IO [UTCTime] +relayedEditTimes db (LabelHash lh) since = + map fromOnly + <$> DB.query + db + "SELECT created_at FROM sx_badge_service_name_record_edits WHERE label_hash = ? AND created_at > ? ORDER BY created_at" + (Binary lh, truncateToSecond since) + +int64 :: Word64 -> Int64 +int64 = fromIntegral + +word64 :: Int64 -> Word64 +word64 = fromIntegral + +-- | Address has no exported constructor; its parser takes lowercase hex without the EIP-55 check. +decodeAddress :: ByteString -> Either Text Address +decodeAddress bs = either (const $ Left "address column") Right $ strDecode $ convertToBase Base16 bs + +decodeSignature :: ByteString -> Either Text RecoverableSignature +decodeSignature bs = either (Left . ("signature column: " <>) . tshow) Right $ parseSignature $ hex bs + +note :: Text -> Maybe a -> Either Text a +note err = maybe (Left err) Right + +decodeAll :: (row -> Either Text a) -> [row] -> IO [a] +decodeAll decode = either (E.throwIO . StoreDecodeError) pure . traverse decode + +firstDecoded :: (row -> Either Text a) -> IO [row] -> IO (Maybe a) +firstDecoded decode rows = rows >>= fmap listToMaybe . decodeAll decode . take 1 diff --git a/simplex-chat.cabal b/simplex-chat.cabal index b7d05448d7..326ee3d52f 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -449,6 +449,7 @@ executable simplex-store-service StoreService.Names.Phases StoreService.Names.Registration StoreService.Names.Signatures + StoreService.Names.Store StoreService.Names.Turns StoreService.Options StoreService.Orders @@ -750,6 +751,7 @@ test-suite simplex-chat-test Bots.StoreService.NameRegistrationTests Bots.StoreService.NamesLabelTests Bots.StoreService.NamesSignatureTests + Bots.StoreService.NamesStoreTests Bots.StoreService.NamesWiringTests Bots.StoreService.StripeTests Bots.StoreService.WaitersTests @@ -779,6 +781,7 @@ test-suite simplex-chat-test StoreService.Names.Phases StoreService.Names.Registration StoreService.Names.Signatures + StoreService.Names.Store StoreService.Names.Turns StoreService.Options StoreService.Orders diff --git a/tests/Bots/StoreService/NamesStoreTests.hs b/tests/Bots/StoreService/NamesStoreTests.hs new file mode 100644 index 0000000000..d3f7bd2d10 --- /dev/null +++ b/tests/Bots/StoreService/NamesStoreTests.hs @@ -0,0 +1,689 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Bots.StoreService.NamesStoreTests (namesStoreTests) where + +import Bots.StoreService.WebTests (columnsOf, digestFixture, runMigrations, withServiceStore) +import Control.Arrow ((&&&)) +import Control.Monad (forM_, void) +import Data.List (sort) +import Data.Maybe (fromJust, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime (..), addUTCTime) +import Data.Word (Word8) +import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..)) +import Simplex.Chat.PaymentService.Types (CardProvider (..), CryptoCurrency (..), InvoiceId (..), ServicePaymentMethod (..)) +import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) +import qualified Simplex.Messaging.Agent.Store.DB as DB +import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationsToRun (..), toDownMigration) +import Simplex.Messaging.Crypto.Secp256k1 (RecoverableSignature) +import Simplex.Messaging.Eth.Address (Address) +import Simplex.Messaging.SimplexName (labelHash) +import StoreService.Names.Phases (RegistrationId (..)) +import StoreService.Names.Signatures (OrderFields (..), parseAnyCaseAddress, parseSignature) +import StoreService.Names.Store +import StoreService.Store (RevokeResult (..)) +import Test.Hspec + +#if defined(dbPostgres) +import Database.PostgreSQL.Simple (Only (..)) +import StoreService.Store.Postgres.Migrations (storeServiceSchemaMigrations) +#else +import Database.SQLite.Simple (Only (..)) +import StoreService.Store.SQLite.Migrations (storeServiceSchemaMigrations) +#endif + +namesStoreTests :: Spec +namesStoreTests = describe "StoreService names: store" $ do + describe "migration" $ do + it "creates the names tables with the planned columns" testNamesColumns + it "rolls back and re-applies only the names migration, with rows in it, leaving the badge tables as they were" testNamesDownUp + describe "order hash" $ do + it "is equal for the same order fields, and differs when any one field differs" testOrderHashFields + it "keeps field boundaries, so moving a byte between two fields changes it" testOrderHashBoundaries + describe "registrations" $ do + it "creates a paid order unpaid and live at version 1, linked to its invoice" testCreatePaid + it "creates a code order queued with its code reserved" testCreateCode + it "refuses a second live order for one owner and label hash, or for one commitment" testLiveUnique + it "leaves no registration when the code cannot be reserved" testCodeNotReservable + it "finds an exact resend by its order hash, live or not" testOrderHashLookup + it "tells an overdue live order apart, whatever the poller marked, unless paid" testLiveOrdersOverdue + it "closes an overdue order so a new one from the same wallet fits in the same transaction" testCloseOverdue + it "closes nothing from a stale version" testCloseOverdueStale + it "bumps the version on every write and changes nothing for a stale one" testVersionBumps + it "writes and reads back every changeable field, and clears the reveal" testRoundTrip + it "keeps live in step with the phase" testLiveFollowsPhase + it "retargets to the new fields, clearing the reveal, transactions, reveal times and refusal" testRetarget + it "finds an owner's orders newest first, at most 50" testFind + it "tells a label being registered here" testLabelRegistering + it "lists the registrations a worker moves on" testActive + it "deletes an unpaid order past the cutoff with its invoice, sparing one with a payment" testUnpaidCleanup + it "lists code orders failed before the cutoff that still hold their code" testFailedCodeOrders + describe "prepaid codes" $ do + it "issues one code per hash" testIssueCode + it "reserves only an unused code, releases and spends it only for its holder" testReserveReleaseSpend + it "refuses an unpaid, revoked or expired code" testReserveRefused + it "lets a registration hold one code" testOneCodePerRegistration + it "revokes an unspent code, reserved or not, never a spent one" testRevoke + describe "transactions" $ do + it "keeps a signed transaction pending until its outcome, and lists them by owner" testTransactions + describe "record edits" $ do + it "holds one pending or mined edit per owner and nonce, freed by a revert" testEditNonceUnique + it "settles a pending edit once, with its mined hash" testSettleEdit + it "round-trips a clear edit" testClearEdit + it "gives the times of a name's relayed edits in the window" testRelayedEditTimes + +t0 :: UTCTime +t0 = UTCTime (fromGregorian 2026 10 21) 0 + +at :: Int -> UTCTime +at minutes = addUTCTime (fromIntegral $ minutes * 60) t0 + +ownerA :: Address +ownerA = address "0x014f9c09CcEeDEF1B713110d04D3a07d5B5D9b73" + +ownerB :: Address +ownerB = address "0x8A791620dd6260079BF849Dc5567aDC3F2FdC318" + +address :: Text -> Address +address = either (error . show) id . parseAnyCaseAddress + +-- r all 0x11, s all 0x22 (a low s), v 27 +signature :: RecoverableSignature +signature = either (error . show) id $ parseSignature $ "0x" <> T.replicate 32 "11" <> T.replicate 32 "22" <> "1b" + +twoYears :: Int +twoYears = 2 + +order :: Text -> Word8 -> OrderFields +order label n = + OrderFields + { ofLabelHash = labelHash label, + ofLength = T.length label, + ofDuration = 69292800, + ofCommitment = digestFixture n, + ofSealed = "sealed-" <> label <> "-" <> T.pack (show n) + } + +newReg :: Text -> Address -> OrderFields -> NewRegistration +newReg rid nrgOwner nrgOrder = NewRegistration {nrgId = RegistrationId rid, nrgOwner, nrgOrder, nrgYears = twoYears} + +btc :: ServicePaymentMethod +btc = SPMCrypto CCBtc + +price :: Int +price = 20000 + +paidOrder :: Text -> PaidOrder +paidOrder invId = PaidOrder {poMethod = btc, poPrice = price, poInvoiceId = InvoiceId invId, poProviderRef = "ref-" <> invId} + +insertInvoiceRow :: DB.Connection -> Text -> UTCTime -> Text -> IO () +insertInvoiceRow db invId expiresAt status = + DB.execute + db + "INSERT INTO sx_badge_service_invoices (invoice_id, provider, price, amount, currency, expires_at, status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" + (invId, "crypto" :: Text, price, price, "usd" :: Text, expiresAt, status, t0, t0) + +-- | A paid order whose invoice, named after the registration, expires at the given time. +placePaid :: DBStore -> Text -> Address -> OrderFields -> UTCTime -> IO (Either RegistrationRefused ()) +placePaid st rid owner o expiresAt = withTransaction st $ \db -> do + insertInvoiceRow db ("inv-" <> rid) expiresAt "open" + createPaidRegistration db (newReg rid owner o) (paidOrder $ "inv-" <> rid) t0 + +issue :: DBStore -> Word8 -> NewPrepaidCode -> IO PrepaidCode +issue st n c = withTransaction st $ \db -> do + Right codeId <- insertPrepaidCode db c {npcCodeHash = digestFixture n} t0 + fromJust <$> getPrepaidCodeById db codeId + +usable :: NewPrepaidCode +usable = NewPrepaidCode {npcCodeHash = "", npcMinLength = 8, npcYears = twoYears, npcPaymentStatus = CPSPaid, npcExpiresAt = Nothing} + +placeCode :: DBStore -> Text -> Address -> OrderFields -> PrepaidCode -> IO (Either RegistrationRefused ()) +placeCode st rid owner o code = withTransaction st $ \db -> createCodeRegistration db (newReg rid owner o) code t0 + +reg :: DBStore -> Text -> IO NameRegistration +reg st rid = withTransaction st $ \db -> fromJust <$> getRegistration db (RegistrationId rid) + +write :: DBStore -> NameRegistration -> IO VersionWrite +write st r = withTransaction st $ \db -> updateRegistration db r (at 1) + +namesTables :: [Text] +namesTables = map ("sx_badge_service_name_" <>) ["prepaid_codes", "registrations", "invoices", "record_edits", "transactions"] + +badgeTables :: [Text] +badgeTables = map ("sx_badge_service_" <>) ["invoices", "payments", "badge_prices", "badge_offers", "badge_purchases", "badge_ledger", "badge_issuances", "badge_codes", "badge_code_invoices", "group"] + +testNamesColumns :: IO () +testNamesColumns = withServiceStore $ \st -> do + let has table cols = columnsOf st table >>= \cs -> filter (`notElem` cs) cols `shouldBe` [] + has "sx_badge_service_name_prepaid_codes" ["name_prepaid_code_id", "code_hash", "min_length", "years", "code_payment_status", "reserved_by", "reserved_at", "spent_at", "revoked_at", "expires_at", "created_at"] + has + "sx_badge_service_name_registrations" + [ "registration_id", "label_hash", "length", "label", "secret", "contact_link", "channel_link", "intent_nonce", "intent_deadline", "intent_signature", + "sealed", "owner", "commitment", "phase", "commit_tx", "commit_block", "register_tx", "register_block", "reveal_after", "reveal_before", + "years", "duration", "expires_at", "price", "name_prepaid_code_id", "issued_code_id", "registered_at", "failed_at", "error", "created_at", + "updated_at", "version", "live", "order_hash", "method", "moves", "links_refused_at" + ] + has "sx_badge_service_name_invoices" ["invoice_id", "registration_id", "provider_ref"] + has "sx_badge_service_name_record_edits" ["label_hash", "owner", "nonce", "record_key", "record_value", "deadline", "signature", "body_hash", "state", "revert", "mined_tx", "created_at"] + has "sx_badge_service_name_transactions" ["registration_id", "name_record_edit_id", "kind", "raw", "tx_hash", "registrar_nonce", "sent_at", "mined_block", "status"] + +testNamesDownUp :: IO () +testNamesDownUp = withServiceStore $ \st -> do + let names = [m | m@Migration {name = "20261010_names"} <- storeServiceSchemaMigrations] + badgeColumns = mapM (fmap sort . columnsOf st) badgeTables + length names `shouldBe` 1 + map name storeServiceSchemaMigrations `shouldSatisfy` ((== "20261010_names") . last) + badgeBefore <- badgeColumns + code <- issue st 1 usable + placeCode st "r1" ownerA (order "alicebakery" 1) code `shouldReturn` Right () + placePaid st "r2" ownerB (order "bobsbakery" 2) (at 60) `shouldReturn` Right () + runMigrations st $ MTRDown (mapMaybe toDownMigration names) + mapM (columnsOf st) namesTables `shouldReturn` map (const []) namesTables + badgeColumns `shouldReturn` badgeBefore + runMigrations st $ MTRUp names + mapM (fmap null . columnsOf st) namesTables `shouldReturn` map (const False) namesTables + badgeColumns `shouldReturn` badgeBefore + +testOrderHashFields :: IO () +testOrderHashFields = do + let o = order "alicebakery" 1 + paid = OTInvoice btc price + base = orderHash ownerA o paid + variants = + [ ("labelHash" :: Text, orderHash ownerA o {ofLabelHash = labelHash "alicebakers"} paid), + ("length", orderHash ownerA o {ofLength = 12} paid), + ("duration", orderHash ownerA o {ofDuration = 69292801} paid), + ("owner", orderHash ownerB o paid), + ("commitment", orderHash ownerA o {ofCommitment = digestFixture 2} paid), + ("sealed", orderHash ownerA o {ofSealed = ofSealed o <> "x"} paid), + ("method", orderHash ownerA o (OTInvoice (SPMCard CPStripe) price)), + ("price", orderHash ownerA o (OTInvoice btc (price + 1))), + ("code instead of invoice", orderHash ownerA o (OTCode $ digestFixture 3)), + ("another code", orderHash ownerA o (OTCode $ digestFixture 4)) + ] + orderHash ownerA (order "alicebakery" 1) paid `shouldBe` base + forM_ variants $ \(field, h) -> (field, h == base) `shouldBe` (field, False) + orderHash ownerA o (OTCode $ digestFixture 3) `shouldNotBe` orderHash ownerA o (OTCode $ digestFixture 4) + +testOrderHashBoundaries :: IO () +testOrderHashBoundaries = do + let o = order "alicebakery" 1 + orderHash ownerA o {ofSealed = "ab"} (OTCode "c") `shouldNotBe` orderHash ownerA o {ofSealed = "a"} (OTCode "bc") + +testCreatePaid :: IO () +testCreatePaid = withServiceStore $ \st -> do + let o = order "alicebakery" 1 + placePaid st "r1" ownerA o (at 60) `shouldReturn` Right () + r <- reg st "r1" + r + `shouldBe` NameRegistration + { nrId = RegistrationId "r1", + nrVersion = 1, + nrLabelHash = ofLabelHash o, + nrLength = 11, + nrDuration = 69292800, + nrOwner = ownerA, + nrCommitment = ofCommitment o, + nrSealed = ofSealed o, + nrPhase = PUnpaid, + nrYears = twoYears, + nrPrice = price, + nrPayment = RPInvoice btc (InvoiceId "inv-r1"), + nrReveal = Nothing, + nrCommitTx = Nothing, + nrCommitBlock = Nothing, + nrRegisterTx = Nothing, + nrRegisterBlock = Nothing, + nrRevealAfter = Nothing, + nrRevealBefore = Nothing, + nrExpiresAt = Nothing, + nrIssuedCodeId = Nothing, + nrRegisteredAt = Nothing, + nrFailedAt = Nothing, + nrError = Nothing, + nrLive = True, + nrOrderHash = orderHash ownerA o (OTInvoice btc price), + nrMoves = 0, + nrLinksRefusedAt = Nothing, + nrCreatedAt = t0, + nrUpdatedAt = t0 + } + +testCreateCode :: IO () +testCreateCode = withServiceStore $ \st -> do + let o = order "alicebakery" 1 + code@PrepaidCode {pcId, pcCodeHash} <- issue st 1 usable + placeCode st "r1" ownerA o code `shouldReturn` Right () + r <- reg st "r1" + (nrPhase r, nrLive r, nrPrice r, nrPayment r, nrVersion r) `shouldBe` (PQueued, True, 0, RPCode pcId, 1) + nrOrderHash r `shouldBe` orderHash ownerA o (OTCode pcCodeHash) + held <- withTransaction st $ \db -> getPrepaidCode db pcCodeHash + (pcReservedBy =<< held, pcReservedAt =<< held) `shouldBe` (Just (RegistrationId "r1"), Just t0) + +testLiveUnique :: IO () +testLiveUnique = withServiceStore $ \st -> do + let o = order "alicebakery" 1 + placePaid st "r1" ownerA o (at 60) `shouldReturn` Right () + placePaid st "r2" ownerA o {ofCommitment = digestFixture 2} (at 60) `shouldReturn` Left RRLiveOrder + placePaid st "r3" ownerB o (at 60) `shouldReturn` Left RRLiveOrder + code <- issue st 9 usable + placeCode st "r4" ownerA (order "alicebakery" 3) code `shouldReturn` Left RRLiveOrder + placePaid st "r5" ownerB (order "alicebakery" 5) (at 60) `shouldReturn` Right () + existing <- withTransaction st $ \db -> mapM (getRegistration db . RegistrationId) ["r2", "r3", "r4"] + existing `shouldBe` [Nothing, Nothing, Nothing] + free <- withTransaction st $ \db -> getPrepaidCodeById db (pcId code) + (pcReservedBy =<< free) `shouldBe` Nothing + +testCodeNotReservable :: IO () +testCodeNotReservable = withServiceStore $ \st -> do + code <- issue st 1 usable + placeCode st "r1" ownerA (order "alicebakery" 1) code `shouldReturn` Right () + placeCode st "r2" ownerB (order "bobsbakery" 2) code `shouldReturn` Left RRCodeNotReservable + withTransaction st (\db -> getRegistration db (RegistrationId "r2")) `shouldReturn` Nothing + held <- withTransaction st $ \db -> getPrepaidCodeById db (pcId code) + (pcReservedBy =<< held) `shouldBe` Just (RegistrationId "r1") + +testOrderHashLookup :: IO () +testOrderHashLookup = withServiceStore $ \st -> do + let o = order "alicebakery" 1 + placePaid st "r1" ownerA o (at 1) `shouldReturn` Right () + r <- reg st "r1" + closed <- withTransaction st $ \db -> closeOverdue db r (at 2) + closed `shouldBe` Written 2 + found <- withTransaction st $ \db -> getRegistrationByOrderHash db (orderHash ownerA o (OTInvoice btc price)) + (nrId <$> found, nrLive <$> found) `shouldBe` (Just (RegistrationId "r1"), Just False) + withTransaction st (\db -> getRegistrationByOrderHash db (orderHash ownerA o (OTInvoice btc (price + 1)))) `shouldReturn` Nothing + +testLiveOrdersOverdue :: IO () +testLiveOrdersOverdue = withServiceStore $ \st -> do + let o = order "alicebakery" 1 + live now = withTransaction st $ \db -> map (\LiveOrder {loRegistration, loOverdue} -> (nrId loRegistration, loOverdue)) <$> getLiveOrders db (ofCommitment o) ownerA (ofLabelHash o) now + setStatus status = withTransaction st $ \db -> DB.execute db "UPDATE sx_badge_service_invoices SET status = ? WHERE invoice_id = ?" (status :: Text, "inv-r1" :: Text) + placePaid st "r1" ownerA o (at 60) `shouldReturn` Right () + placePaid st "r2" ownerB (order "alicebakery" 2) (at 60) `shouldReturn` Right () + live (at 30) `shouldReturn` [(RegistrationId "r1", False)] + live (at 61) `shouldReturn` [(RegistrationId "r1", True)] + withTransaction st (\db -> map (nrId . loRegistration) <$> getLiveOrders db (ofCommitment o) ownerB (labelHash "zzzzzzzz") (at 30)) + `shouldReturn` [RegistrationId "r1"] + setStatus "expired" + live (at 61) `shouldReturn` [(RegistrationId "r1", True)] + setStatus "paid" + live (at 61) `shouldReturn` [(RegistrationId "r1", False)] + +testCloseOverdue :: IO () +testCloseOverdue = withServiceStore $ \st -> do + let o = order "alicebakery" 1 + o' = o {ofCommitment = digestFixture 2, ofSealed = "new"} + placePaid st "r1" ownerA o (at 60) `shouldReturn` Right () + placed <- withTransaction st $ \db -> do + [LiveOrder {loRegistration, loOverdue = True}] <- getLiveOrders db (ofCommitment o') ownerA (ofLabelHash o') (at 61) + void $ closeOverdue db loRegistration (at 61) + insertInvoiceRow db "inv-r2" (at 120) "open" + createPaidRegistration db (newReg "r2" ownerA o') (paidOrder "inv-r2") (at 61) + placed `shouldBe` Right () + old <- reg st "r1" + (nrLive old, nrPhase old, nrVersion old) `shouldBe` (False, PUnpaid, 2) + invoiceStatus st "inv-r1" `shouldReturn` "expired" + invoiceStatus st "inv-r2" `shouldReturn` "open" + +testCloseOverdueStale :: IO () +testCloseOverdueStale = withServiceStore $ \st -> do + placePaid st "r1" ownerA (order "alicebakery" 1) (at 60) `shouldReturn` Right () + r <- reg st "r1" + write st r {nrPhase = PQueued} `shouldReturn` Written 2 + withTransaction st (\db -> closeOverdue db r (at 61)) `shouldReturn` VersionChanged + invoiceStatus st "inv-r1" `shouldReturn` "open" + (nrLive &&& nrPhase) <$> reg st "r1" `shouldReturn` (True, PQueued) + +invoiceStatus :: DBStore -> Text -> IO Text +invoiceStatus st invId = withTransaction st $ \db -> + DB.query db "SELECT status FROM sx_badge_service_invoices WHERE invoice_id = ?" (Only invId) >>= \case + [Only status] -> pure status + rows -> fail $ "invoice " <> show invId <> ": " <> show (length rows) <> " rows" + +reveal :: NameReveal +reveal = + NameReveal + { rvLabel = "alicebakery", + rvSecret = digestFixture 7, + rvContactLink = Just "https://smp8.simplex.im/a#abc", + rvChannelLink = Nothing, + rvNonce = 3, + rvDeadline = 1792915140, + rvSignature = signature + } + +testVersionBumps :: IO () +testVersionBumps = withServiceStore $ \st -> do + code <- issue st 1 usable + placeCode st "r1" ownerA (order "alicebakery" 1) code `shouldReturn` Right () + r1 <- reg st "r1" + write st r1 {nrPhase = PCommitting, nrCommitTx = Just (digestFixture 8)} `shouldReturn` Written 2 + r2 <- reg st "r1" + write st r2 {nrPhase = PCommitted, nrRevealAfter = Just 1792828800, nrRevealBefore = Just 1792915140} `shouldReturn` Written 3 + r3 <- reg st "r1" + write st r3 {nrReveal = Just reveal} `shouldReturn` Written 4 + write st r3 {nrLinksRefusedAt = Just (at 5)} `shouldReturn` VersionChanged + write st r1 {nrPhase = PFailed} `shouldReturn` VersionChanged + r4 <- reg st "r1" + (nrVersion r4, nrPhase r4, nrReveal r4, nrLinksRefusedAt r4) `shouldBe` (4, PCommitted, Just reveal, Nothing) + +testRoundTrip :: IO () +testRoundTrip = withServiceStore $ \st -> do + code <- issue st 1 usable + issued <- issue st 2 usable + placeCode st "r1" ownerA (order "alicebakery" 1) code `shouldReturn` Right () + r <- reg st "r1" + let changed = + r + { nrPhase = PRegistered, + nrReveal = Just reveal {rvChannelLink = Just "simplex:/c#xyz"}, + nrCommitTx = Just (digestFixture 8), + nrCommitBlock = Just 100, + nrRegisterTx = Just (digestFixture 9), + nrRegisterBlock = Just 120, + nrRevealAfter = Just 1792828800, + nrRevealBefore = Just 1792915140, + nrExpiresAt = Just 1861833600, + nrIssuedCodeId = Just (pcId issued), + nrRegisteredAt = Just (at 3), + nrFailedAt = Just (at 2), + nrError = Just "The name was not signed in time", + nrLinksRefusedAt = Just (at 4), + nrMoves = 2 + } + write st changed `shouldReturn` Written 2 + reg st "r1" `shouldReturn` changed {nrVersion = 2, nrUpdatedAt = at 1} + write st changed {nrVersion = 2, nrReveal = Nothing} `shouldReturn` Written 3 + nrReveal <$> reg st "r1" `shouldReturn` Nothing + +testLiveFollowsPhase :: IO () +testLiveFollowsPhase = withServiceStore $ \st -> do + placePaid st "r1" ownerA (order "alicebakery" 1) (at 60) `shouldReturn` Right () + let step phase expected = do + r <- reg st "r1" + void $ write st r {nrPhase = phase} + (nrPhase &&& nrLive) <$> reg st "r1" `shouldReturn` (phase, expected) + step PQueued True + step PTaken False + step PFailed True + step PCodeIssued False + r <- reg st "r1" + void $ write st r {nrPhase = PUnpaid, nrLive = True} + nrLive <$> reg st "r1" `shouldReturn` True + r' <- reg st "r1" + void $ write st r' {nrLive = False} + nrLive <$> reg st "r1" `shouldReturn` False + +testRetarget :: IO () +testRetarget = withServiceStore $ \st -> do + let o = order "alicebakery" 1 + o' = order "alicebakers" 2 + placePaid st "r1" ownerA o (at 60) `shouldReturn` Right () + r <- reg st "r1" + let taken = + r + { nrPhase = PTaken, + nrReveal = Just reveal, + nrCommitTx = Just (digestFixture 8), + nrCommitBlock = Just 100, + nrRegisterTx = Just (digestFixture 9), + nrRegisterBlock = Just 120, + nrRevealAfter = Just 1, + nrRevealBefore = Just 2, + nrLinksRefusedAt = Just (at 4), + nrFailedAt = Just (at 5), + nrError = Just "failed" + } + write st taken `shouldReturn` Written 2 + withTransaction st (\db -> retargetRegistration db taken {nrVersion = 2} o' 10000 (at 6)) `shouldReturn` Written 3 + r' <- reg st "r1" + r' + `shouldBe` r + { nrVersion = 3, + nrLabelHash = ofLabelHash o', + nrCommitment = ofCommitment o', + nrSealed = ofSealed o', + nrPrice = 10000, + nrPhase = PQueued, + nrMoves = 1, + nrUpdatedAt = at 6 + } + withTransaction st (\db -> retargetRegistration db taken {nrVersion = 2} o 10000 (at 7)) `shouldReturn` VersionChanged + +testFind :: IO () +testFind = withServiceStore $ \st -> do + forM_ [1 .. 52 :: Int] $ \i -> withTransaction st $ \db -> do + let rid = "r" <> T.pack (show i) + o = order ("alicebakery" <> T.pack (show i)) (fromIntegral i) + insertInvoiceRow db ("inv-" <> rid) (at 60) "open" + createPaidRegistration db (newReg rid ownerA o) (paidOrder $ "inv-" <> rid) (at i) `shouldReturn` Right () + placePaid st "other" ownerB (order "bobsbakery" 99) (at 60) `shouldReturn` Right () + found <- withTransaction st $ \db -> findRegistrations db ownerA + map nrId found `shouldBe` [RegistrationId $ "r" <> T.pack (show i) | i <- [52, 51 .. 3 :: Int]] + withTransaction st (\db -> findRegistrations db (address "0x0000000000000000000000000000000000000001")) `shouldReturn` [] + +testLabelRegistering :: IO () +testLabelRegistering = withServiceStore $ \st -> do + let o = order "alicebakery" 1 + registering = withTransaction st $ \db -> isLabelRegistering db (ofLabelHash o) + code <- issue st 1 usable + placeCode st "r1" ownerA o code `shouldReturn` Right () + registering `shouldReturn` False + r <- reg st "r1" + void $ write st r {nrPhase = PRegistering} + registering `shouldReturn` True + r' <- reg st "r1" + void $ write st r' {nrPhase = PRegistered} + registering `shouldReturn` False + +testActive :: IO () +testActive = withServiceStore $ \st -> do + let phases = [PUnpaid ..] + forM_ (zip [1 ..] phases) $ \(i, phase) -> do + let rid = "r" <> T.pack (show i) + placePaid st rid ownerA (order ("alicebakery" <> T.pack (show i)) i) (at 60) `shouldReturn` Right () + r <- reg st rid + void $ write st r {nrPhase = phase} + active <- withTransaction st activeRegistrations + sort (map (fromEnum . nrPhase) active) `shouldBe` map fromEnum [PQueued, PCommitting, PCommitted, PRegistering] + +testUnpaidCleanup :: IO () +testUnpaidCleanup = withServiceStore $ \st -> do + placePaid st "old" ownerA (order "alicebakery" 1) (at 60) `shouldReturn` Right () + placePaid st "funded" ownerA (order "bobsbakery" 2) (at 60) `shouldReturn` Right () + placePaid st "queued" ownerA (order "carolsbakery" 3) (at 60) `shouldReturn` Right () + withTransaction st $ \db -> do + insertInvoiceRow db "inv-new" (at 60) "open" + createPaidRegistration db (newReg "new" ownerA (order "davesbakery" 4)) (paidOrder "inv-new") (at 10) `shouldReturn` Right () + DB.execute + db + "INSERT INTO sx_badge_service_payments (payment_id, invoice_id, provider, status, created_at, updated_at) VALUES (?,?,?,?,?,?)" + ("inv-funded" :: Text, "inv-funded" :: Text, "crypto" :: Text, "pending" :: Text, t0, t0) + r <- reg st "queued" + void $ write st r {nrPhase = PQueued} + candidates <- withTransaction st $ \db -> unpaidCleanupCandidates db (at 5) + sort (map (\(RegistrationId rid, InvoiceId invId) -> (rid, invId)) candidates) `shouldBe` [("funded", "inv-funded"), ("old", "inv-old")] + withTransaction st (\db -> mapM (deleteUnpaidRegistration db . RegistrationId) ["old", "funded", "queued"]) `shouldReturn` [True, False, False] + withTransaction st (\db -> getRegistration db (RegistrationId "old")) `shouldReturn` Nothing + invoiceCount st "inv-old" `shouldReturn` 0 + invoiceCount st "inv-funded" `shouldReturn` 1 + nrPhase <$> reg st "funded" `shouldReturn` PUnpaid + +invoiceCount :: DBStore -> Text -> IO Int +invoiceCount st invId = withTransaction st $ \db -> + DB.query db "SELECT COUNT(*) FROM sx_badge_service_invoices WHERE invoice_id = ?" (Only invId) >>= \case + [Only n] -> pure n + rows -> fail $ "count: " <> show (length rows) <> " rows" + +testFailedCodeOrders :: IO () +testFailedCodeOrders = withServiceStore $ \st -> do + codes@[oldCode, _, releasedCode, _] <- mapM (\n -> issue st n usable) [1, 2, 3, 4] + forM_ (zip3 ["old", "recent", "released", "queued"] [1 ..] codes) $ \(rid, n, code) -> + placeCode st rid ownerA (order ("alicebakery" <> rid) n) code `shouldReturn` Right () + let failAt rid t = reg st rid >>= \r -> void (write st r {nrPhase = PFailed, nrFailedAt = Just t}) + failAt "old" (at 1) + failAt "recent" (at 30) + failAt "released" (at 1) + withTransaction st (\db -> releasePrepaidCode db (pcId releasedCode) (RegistrationId "released")) `shouldReturn` True + withTransaction st (\db -> failedCodeOrdersBefore db (at 10)) `shouldReturn` [(RegistrationId "old", pcId oldCode)] + +testIssueCode :: IO () +testIssueCode = withServiceStore $ \st -> do + code <- issue st 1 usable {npcMinLength = 6, npcYears = 5, npcPaymentStatus = CPSFree, npcExpiresAt = Just (at 100)} + (pcMinLength code, pcYears code, pcPaymentStatus code, pcExpiresAt code, pcCreatedAt code) `shouldBe` (6, 5, CPSFree, Just (at 100), t0) + withTransaction st (\db -> insertPrepaidCode db usable {npcCodeHash = digestFixture 1} t0) `shouldReturn` Left CodeHashTaken + withTransaction st (\db -> getPrepaidCode db (digestFixture 1)) `shouldReturn` Just code + +testReserveReleaseSpend :: IO () +testReserveReleaseSpend = withServiceStore $ \st -> do + PrepaidCode {pcId} <- issue st 1 usable + placePaid st "r1" ownerA (order "alicebakery" 1) (at 60) `shouldReturn` Right () + placePaid st "r2" ownerB (order "bobsbakery" 2) (at 60) `shouldReturn` Right () + let r1 = RegistrationId "r1" + r2 = RegistrationId "r2" + run :: (DB.Connection -> IO a) -> IO a + run = withTransaction st + run (\db -> releasePrepaidCode db pcId r1) `shouldReturn` False + run (\db -> spendPrepaidCode db pcId r1 t0) `shouldReturn` False + run (\db -> reservePrepaidCode db pcId r1 (at 1)) `shouldReturn` True + run (\db -> reservePrepaidCode db pcId r2 (at 1)) `shouldReturn` False + run (\db -> releasePrepaidCode db pcId r2) `shouldReturn` False + run (\db -> spendPrepaidCode db pcId r2 (at 2)) `shouldReturn` False + run (\db -> releasePrepaidCode db pcId r1) `shouldReturn` True + run (\db -> reservePrepaidCode db pcId r2 (at 2)) `shouldReturn` True + run (\db -> spendPrepaidCode db pcId r2 (at 3)) `shouldReturn` True + run (\db -> releasePrepaidCode db pcId r2) `shouldReturn` False + run (\db -> reservePrepaidCode db pcId r1 (at 4)) `shouldReturn` False + run (\db -> spendPrepaidCode db pcId r2 (at 4)) `shouldReturn` False + spent <- run $ \db -> getPrepaidCodeById db pcId + (pcReservedBy =<< spent, pcSpentAt =<< spent) `shouldBe` (Just r2, Just (at 3)) + +testReserveRefused :: IO () +testReserveRefused = withServiceStore $ \st -> do + placePaid st "r1" ownerA (order "alicebakery" 1) (at 60) `shouldReturn` Right () + unpaid <- issue st 1 usable {npcPaymentStatus = CPSUnpaid} + expired <- issue st 2 usable {npcExpiresAt = Just (at 10)} + revoked <- issue st 3 usable + free <- issue st 4 usable {npcPaymentStatus = CPSFree, npcExpiresAt = Just (at 30)} + withTransaction st (\db -> revokePrepaidCode db (pcCodeHash revoked) t0) `shouldReturn` Revoked (pcId revoked) + let reserve code = withTransaction st $ \db -> reservePrepaidCode db (pcId code) (RegistrationId "r1") (at 20) + mapM reserve [unpaid, expired, revoked] `shouldReturn` [False, False, False] + reserve free `shouldReturn` True + +testOneCodePerRegistration :: IO () +testOneCodePerRegistration = withServiceStore $ \st -> do + first <- issue st 1 usable + second <- issue st 2 usable + placeCode st "r1" ownerA (order "alicebakery" 1) first `shouldReturn` Right () + withTransaction st (\db -> reservePrepaidCode db (pcId second) (RegistrationId "r1") t0) `shouldThrow` anyException + free <- withTransaction st $ \db -> getPrepaidCodeById db (pcId second) + (pcReservedBy =<< free) `shouldBe` Nothing + +testRevoke :: IO () +testRevoke = withServiceStore $ \st -> do + reserved <- issue st 1 usable + spent <- issue st 2 usable + unused <- issue st 3 usable + placeCode st "r1" ownerA (order "alicebakery" 1) reserved `shouldReturn` Right () + placeCode st "r2" ownerA (order "bobsbakery" 2) spent `shouldReturn` Right () + withTransaction st (\db -> spendPrepaidCode db (pcId spent) (RegistrationId "r2") t0) `shouldReturn` True + let revoke code = withTransaction st $ \db -> revokePrepaidCode db (pcCodeHash code) (at 1) + revoke reserved `shouldReturn` Revoked (pcId reserved) + revoke unused `shouldReturn` Revoked (pcId unused) + revoke unused `shouldReturn` AlreadyRevoked (pcId unused) + revoke spent `shouldReturn` AlreadyRedeemed + withTransaction st (\db -> revokePrepaidCode db (digestFixture 9) t0) `shouldReturn` NoSuchCode + held <- withTransaction st $ \db -> getPrepaidCodeById db (pcId reserved) + (pcReservedBy =<< held, pcRevokedAt =<< held) `shouldBe` (Just (RegistrationId "r1"), Just (at 1)) + +newEdit :: Address -> Word8 -> RecordChange -> NewRecordEdit +newEdit owner n change = + NewRecordEdit + { nreLabelHash = labelHash "alicebakery", + nreOwner = owner, + nreNonce = 4, + nreChange = change, + nreDeadline = 1792832400, + nreSignature = signature, + nreBodyHash = digestFixture n + } + +setChannel :: RecordChange +setChannel = RCSetText "simplex.channel" "https://smp9.simplex.im/c#abc" + +testTransactions :: IO () +testTransactions = withServiceStore $ \st -> do + code <- issue st 1 usable + placeCode st "r1" ownerA (order "alicebakery" 1) code `shouldReturn` Right () + Just editId <- withTransaction st $ \db -> insertRecordEdit db (newEdit ownerA 20 setChannel) t0 + let r1 = RegistrationId "r1" + tx :: Word8 -> NewTransaction + tx n = NewTransaction {ntxRaw = digestFixture (n + 100), ntxHash = digestFixture n, ntxNonce = fromIntegral n} + [commitId, _, registerId] <- withTransaction st $ \db -> + sequence [insertTransaction db (TxCommit r1) (tx 2) (at 1), insertTransaction db (TxEdit editId) (tx 1) (at 2), insertTransaction db (TxRegister r1) (tx 3) (at 3)] + unsettled <- withTransaction st pendingTransactions + map (\NameTransaction {ntFor, ntNonce, ntStatus} -> (ntFor, ntNonce, ntStatus)) unsettled + `shouldBe` [(TxEdit editId, 1, TSPending), (TxCommit r1, 2, TSPending), (TxRegister r1, 3, TSPending)] + map ntRaw unsettled `shouldBe` map (\n -> digestFixture (n + 100)) [1, 2, 3] + withTransaction st (\db -> recordTransactionOutcome db (digestFixture 2) TSMined (Just 77)) `shouldReturn` True + withTransaction st (\db -> recordTransactionOutcome db (digestFixture 1) TSReverted (Just 78)) `shouldReturn` True + withTransaction st (\db -> recordTransactionOutcome db (digestFixture 50) TSMined (Just 79)) `shouldReturn` False + map ntFor <$> withTransaction st pendingTransactions `shouldReturn` [TxRegister r1] + ofRegistration <- withTransaction st $ \db -> registrationTransactions db r1 + map (\NameTransaction {ntId, ntFor, ntMinedBlock, ntStatus, ntSentAt} -> (ntId, ntFor, ntMinedBlock, ntStatus, ntSentAt)) ofRegistration + `shouldBe` [(commitId, TxCommit r1, Just 77, TSMined, at 1), (registerId, TxRegister r1, Nothing, TSPending, at 3)] + map ntStatus <$> withTransaction st (\db -> editTransactions db editId) `shouldReturn` [TSReverted] + +testEditNonceUnique :: IO () +testEditNonceUnique = withServiceStore $ \st -> do + let run action = withTransaction st action + Just first <- run $ \db -> insertRecordEdit db (newEdit ownerA 1 setChannel) t0 + run (\db -> insertRecordEdit db (newEdit ownerA 2 RCClear) t0) `shouldReturn` Nothing + Just other <- run $ \db -> insertRecordEdit db (newEdit ownerB 3 setChannel) t0 + other `shouldNotBe` first + run (\db -> settleRecordEdit db first (ESReverted (Just "SignatureExpired"))) `shouldReturn` True + Just second <- run $ \db -> insertRecordEdit db (newEdit ownerA 2 RCClear) (at 1) + fmap reId <$> run (\db -> getRecordEditByNonce db ownerA 4) `shouldReturn` Just second + fmap reState <$> run (\db -> getRecordEditByBody db (digestFixture 1)) `shouldReturn` Just (ESReverted (Just "SignatureExpired")) + run (\db -> settleRecordEdit db second (ESMined Nothing)) `shouldReturn` True + run (\db -> insertRecordEdit db (newEdit ownerA 5 setChannel) (at 2)) `shouldReturn` Nothing + +testSettleEdit :: IO () +testSettleEdit = withServiceStore $ \st -> do + Just editId <- withTransaction st $ \db -> insertRecordEdit db (newEdit ownerA 1 setChannel) t0 + withTransaction st (\db -> settleRecordEdit db editId (ESMined (Just $ digestFixture 9))) `shouldReturn` True + withTransaction st (\db -> settleRecordEdit db editId (ESReverted Nothing)) `shouldReturn` False + edit <- withTransaction st $ \db -> getRecordEdit db editId + edit + `shouldBe` Just + RecordEdit + { reId = editId, + reLabelHash = labelHash "alicebakery", + reOwner = ownerA, + reNonce = 4, + reChange = setChannel, + reDeadline = 1792832400, + reSignature = signature, + reBodyHash = digestFixture 1, + reState = ESMined (Just $ digestFixture 9), + reCreatedAt = t0 + } + +testClearEdit :: IO () +testClearEdit = withServiceStore $ \st -> do + Just editId <- withTransaction st $ \db -> insertRecordEdit db (newEdit ownerA 1 RCClear) t0 + fmap (\RecordEdit {reChange, reState} -> (reChange, reState)) <$> withTransaction st (\db -> getRecordEdit db editId) + `shouldReturn` Just (RCClear, ESPending) + +testRelayedEditTimes :: IO () +testRelayedEditTimes = withServiceStore $ \st -> do + forM_ (zip [1 ..] [0, 10, 20]) $ \(n, m) -> + withTransaction st $ \db -> void $ insertRecordEdit db (newEdit ownerA n setChannel) {nreNonce = fromIntegral n} (at m) + withTransaction st (\db -> void $ insertRecordEdit db (newEdit ownerA 9 setChannel) {nreLabelHash = labelHash "bobsbakery", nreNonce = 9} (at 15)) + withTransaction st (\db -> relayedEditTimes db (labelHash "alicebakery") (at 5)) `shouldReturn` [at 10, at 20] diff --git a/tests/Bots/StoreService/WebTests.hs b/tests/Bots/StoreService/WebTests.hs index 54f7a394a4..65286e591e 100644 --- a/tests/Bots/StoreService/WebTests.hs +++ b/tests/Bots/StoreService/WebTests.hs @@ -5,7 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -module Bots.StoreService.WebTests (badgeWebTests) where +module Bots.StoreService.WebTests (badgeWebTests, withServiceStore, columnsOf, runMigrations, digestFixture) where import StoreService.Catalog (catalogCurrency, defaultCatalog) import StoreService.Config (BTCPayConfig (..), ListenerConfig (..), PollConfig (..), ServiceConfig (..), SpeedPolicy (..), StripeConfig (..)) diff --git a/tests/Test.hs b/tests/Test.hs index 0c511ed3ed..0194f7bcc2 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -12,6 +12,7 @@ import Bots.StoreService.GroupTests import Bots.StoreService.NameRegistrationTests import Bots.StoreService.NamesLabelTests import Bots.StoreService.NamesSignatureTests +import Bots.StoreService.NamesStoreTests import Bots.StoreService.NamesWiringTests import Bots.StoreService.StripeTests import Bots.StoreService.WaitersTests @@ -92,6 +93,7 @@ main = do namesConfigTests namesLabelTests namesSignatureTests + namesStoreTests namesWiringTests describe "SimpleX chat markdown" markdownTests describe "JSON Tests" jsonTests