mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-11-04 08:37:30 +00:00
store: add the names store queries
This commit is contained in:
shum committed
1 parent
32685b6d9a
commit
05854d8b12
5 files changed
+1592
-1
No files matched your search
@@ -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
|
||||
@@ -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
|
||||
|
||||
@@ -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]
|
||||
@@ -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 (..))
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in new issue
Block a user