mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-11-04 08:37:30 +00:00
store: merge the signed terms
This commit is contained in:
commit
385105f6fd
17 files changed
+591
-120
No files matched your search
@@ -527,6 +527,15 @@ how many community names it loaded.
|
||||
Both the terms and the list are read only at startup, so an edit applies after a restart. After a
|
||||
restart, search each listed name on the names site and check that it shows as a community name.
|
||||
|
||||
Every order signs the terms the buyer agreed to: `terms_version`, followed by `/community` for a
|
||||
listed name. The service stores them with the order, so an open order keeps the terms it signed
|
||||
after an edit, and every move signs the current terms for the name it moves to, and stores them. An
|
||||
order or a move signed with any other value answers `409 terms_changed` with the current terms and
|
||||
the name's community entry, and the page asks again. An exact resend is still answered after the version changed.
|
||||
|
||||
**Upgrading:** a page that sends no `terms` gets `bad_request` on every order, spend and move, so the
|
||||
page and the service are deployed together.
|
||||
|
||||
### The gas key
|
||||
|
||||
`[chain] service_key` is the registrar key: an Ethereum account (EOA) that sends every names
|
||||
|
||||
@@ -28,6 +28,7 @@ module StoreService.Names.Orders
|
||||
codeOrderInsert,
|
||||
checkTimestamp,
|
||||
checkDuration,
|
||||
checkTerms,
|
||||
checkNameFree,
|
||||
checkPrice,
|
||||
movable,
|
||||
@@ -47,6 +48,7 @@ import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
import Data.Bifunctor (first)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (catMaybes, isJust)
|
||||
import Data.Scientific (toBoundedInteger)
|
||||
@@ -65,6 +67,7 @@ import Simplex.Messaging.Util (tshow)
|
||||
import StoreService.Config (NamesConfig (..))
|
||||
import StoreService.Log (logError, logWarn)
|
||||
import StoreService.Names.Codes (CodeRefusal (..), codeRefusal, reserveCode, reserveRefusal, spendLandedCode)
|
||||
import StoreService.Names.Community (communityJSON, termsFor, termsJSON)
|
||||
import StoreService.Names.Contracts (Contracts, NameStatus (..), chainPriceCents, confirmedTag, nameExpires, nameStatus, ownerOfToken, secondsPerYear)
|
||||
import StoreService.Names.Env (NamesEnv (..))
|
||||
import StoreService.Names.Phases (Phases, RegistrationId (..))
|
||||
@@ -104,6 +107,8 @@ data OrderRefusal
|
||||
| ORCode CodeRefusal
|
||||
| ORPriceTooHigh Int
|
||||
| ORBalanceChanged (Maybe Balance)
|
||||
| -- | the current terms and the name's community entry, as the answer carries them
|
||||
ORTermsChanged J.Value J.Value
|
||||
deriving (Eq, Show)
|
||||
|
||||
newtype OrderRefused = OrderRefused OrderRefusal
|
||||
@@ -129,6 +134,10 @@ data Landing = LNotLanded | LRegistered Int64 | LChanged | LUnread
|
||||
maxSealedChars :: Int
|
||||
maxSealedChars = 11095
|
||||
|
||||
-- | The terms version, of up to 32 characters, and a suffix such as /community.
|
||||
maxAgreedTermsChars :: Int
|
||||
maxAgreedTermsChars = 48
|
||||
|
||||
-- | How far a signed request's timestamp may be from the service's clock.
|
||||
signedRequestSeconds :: Integer
|
||||
signedRequestSeconds = 600
|
||||
@@ -149,9 +158,16 @@ parseOrderFields o = do
|
||||
ofCommitment <- bytes32FromHex =<< textField o "commitment"
|
||||
ofSealed <- textField o "sealed"
|
||||
unless (T.length ofSealed <= maxSealedChars) Nothing
|
||||
ofAgreedTerms <- textField o "terms"
|
||||
unless (agreedTermsFormat ofAgreedTerms) Nothing
|
||||
timestamp <- integerField =<< KM.lookup "timestamp" o
|
||||
signature <- either (const Nothing) Just . parseSignature =<< textField o "signature"
|
||||
pure (OrderFields {ofLabelHash, ofLength, ofDuration, ofCommitment, ofSealed}, timestamp, signature)
|
||||
pure (OrderFields {ofLabelHash, ofLength, ofDuration, ofCommitment, ofSealed, ofAgreedTerms}, timestamp, signature)
|
||||
|
||||
agreedTermsFormat :: Text -> Bool
|
||||
agreedTermsFormat t = not (T.null t) && T.length t <= maxAgreedTermsChars && T.all termsChar t
|
||||
where
|
||||
termsChar c = isAsciiUpper c || isAsciiLower c || isDigit c || c `elem` ("._/-" :: String)
|
||||
|
||||
textField :: J.Object -> J.Key -> Maybe Text
|
||||
textField o k = case KM.lookup k o of
|
||||
@@ -254,6 +270,11 @@ checkDuration NamesConfig {nTermStart, nTermSlackSeconds} now years duration = d
|
||||
expected = max 0 (unixSeconds nTermStart - unixSeconds now)
|
||||
when (free < 0 || abs (free - expected) > toInteger nTermSlackSeconds) $ Left ORBadRequest
|
||||
|
||||
-- | The terms the order signed must be the current ones for its name, the community variant for a listed name.
|
||||
checkTerms :: NamesConfig -> OrderFields -> Either OrderRefusal ()
|
||||
checkTerms cfg OrderFields {ofLabelHash, ofAgreedTerms} =
|
||||
unless (ofAgreedTerms == termsFor cfg ofLabelHash) $ Left $ ORTermsChanged (termsJSON cfg) (communityJSON cfg ofLabelHash)
|
||||
|
||||
-- | A name being registered here searches as available, so it is checked here too.
|
||||
checkNameFree :: Contracts -> DBStore -> LabelHash -> IO (Either OrderRefusal ())
|
||||
checkNameFree ct st lh =
|
||||
@@ -284,8 +305,8 @@ movable NameRegistration {nrPhase, nrLinksRefusedAt} = case nrPhase of
|
||||
_ -> False
|
||||
|
||||
orderFieldsOf :: NameRegistration -> OrderFields
|
||||
orderFieldsOf NameRegistration {nrLabelHash, nrLength, nrDuration, nrCommitment, nrSealed} =
|
||||
OrderFields {ofLabelHash = nrLabelHash, ofLength = nrLength, ofDuration = nrDuration, ofCommitment = nrCommitment, ofSealed = nrSealed}
|
||||
orderFieldsOf NameRegistration {nrLabelHash, nrLength, nrDuration, nrCommitment, nrSealed, nrAgreedTerms} =
|
||||
OrderFields {ofLabelHash = nrLabelHash, ofLength = nrLength, ofDuration = nrDuration, ofCommitment = nrCommitment, ofSealed = nrSealed, ofAgreedTerms = nrAgreedTerms}
|
||||
|
||||
-- | Any other live order of the new commitment, or of the owner and the new label hash, refuses the move.
|
||||
checkMoveMeets :: DBStore -> NameRegistration -> OrderFields -> UTCTime -> IO (Either OrderRefusal ())
|
||||
|
||||
@@ -49,13 +49,14 @@ data AddressError
|
||||
| ADChecksum
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | The fields an owner signs in an order and in another name for it.
|
||||
-- | The fields an owner signs in an order and in another name for it, with the terms the owner agreed to for that name.
|
||||
data OrderFields = OrderFields
|
||||
{ ofLabelHash :: LabelHash,
|
||||
ofLength :: Int,
|
||||
ofDuration :: Word64,
|
||||
ofCommitment :: ByteString,
|
||||
ofSealed :: Text
|
||||
ofSealed :: Text,
|
||||
ofAgreedTerms :: Text
|
||||
}
|
||||
deriving (Eq)
|
||||
|
||||
@@ -108,8 +109,8 @@ message :: [Text] -> ByteString
|
||||
message = encodeUtf8 . T.unwords . ("simplex.domains" :)
|
||||
|
||||
orderWords :: OrderFields -> [Text]
|
||||
orderWords OrderFields {ofLabelHash = LabelHash labelHash, ofLength, ofDuration, ofCommitment, ofSealed} =
|
||||
[hex labelHash, tshow ofLength, tshow ofDuration, hex ofCommitment, hex $ sha256Hash $ encodeUtf8 ofSealed]
|
||||
orderWords OrderFields {ofLabelHash = LabelHash labelHash, ofLength, ofDuration, ofCommitment, ofSealed, ofAgreedTerms} =
|
||||
[hex labelHash, tshow ofLength, tshow ofDuration, hex ofCommitment, hex $ sha256Hash $ encodeUtf8 ofSealed, ofAgreedTerms]
|
||||
|
||||
-- the address parser checks EIP-55 only on mixed-case hex, so one-case text is refused here by comparing the encoding
|
||||
parseChecksumAddress :: Text -> Either AddressError Address
|
||||
|
||||
@@ -195,6 +195,8 @@ data NameRegistration = NameRegistration
|
||||
nrOwner :: Address,
|
||||
nrCommitment :: ByteString,
|
||||
nrSealed :: Text,
|
||||
-- | '' for an order stored before orders signed the terms
|
||||
nrAgreedTerms :: Text,
|
||||
nrPhase :: NamePhase,
|
||||
nrYears :: Int,
|
||||
nrPrice :: Int,
|
||||
@@ -476,8 +478,8 @@ 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
|
||||
orderHash owner OrderFields {ofLabelHash = LabelHash lh, ofLength, ofDuration, ofCommitment, ofSealed, ofAgreedTerms} terms =
|
||||
sha256Hash . B.concat . map field $ [tag, lh, num ofLength, num ofDuration, unAddress owner, ofCommitment, encodeUtf8 ofSealed, encodeUtf8 ofAgreedTerms] <> payment
|
||||
where
|
||||
(tag, payment) = case terms of
|
||||
OTInvoice method price -> ("name-invoice", [encodeUtf8 $ methodText method, num price])
|
||||
@@ -557,15 +559,16 @@ insertRegistration db NewRegistration {nrgId = RegistrationId rid, nrgOwner, nrg
|
||||
[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, balance_source, balance_used)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?, ?,?,?,?,?,?,?,?,?,?)
|
||||
price, method, name_prepaid_code_id, live, order_hash, moves, created_at, updated_at, balance_source, balance_used, agreed_terms)
|
||||
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, (\(RegistrationId s, _) -> s) <$> fromBalance, maybe 0 snd fromBalance)
|
||||
:. Only ofAgreedTerms
|
||||
)
|
||||
where
|
||||
OrderFields {ofLabelHash = LabelHash lh, ofLength, ofDuration, ofCommitment, ofSealed} = nrgOrder
|
||||
OrderFields {ofLabelHash = LabelHash lh, ofLength, ofDuration, ofCommitment, ofSealed, ofAgreedTerms} = nrgOrder
|
||||
|
||||
registrationColumns :: Query
|
||||
registrationColumns =
|
||||
@@ -573,7 +576,8 @@ registrationColumns =
|
||||
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.registered_at,
|
||||
r.failed_at, r.error, r.live, r.order_hash, r.moves, r.links_refused_at, r.created_at, r.updated_at, r.balance_source, r.balance_used
|
||||
r.failed_at, r.error, r.live, r.order_hash, r.moves, r.links_refused_at, r.created_at, r.updated_at, r.balance_source, r.balance_used,
|
||||
r.agreed_terms
|
||||
|]
|
||||
|
||||
registrationFrom :: Query
|
||||
@@ -592,6 +596,7 @@ type RegistrationRow =
|
||||
:. (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 UTCTime)
|
||||
:. (Maybe UTCTime, Maybe Text, BoolInt, Binary ByteString, Int, Maybe UTCTime, UTCTime, UTCTime, Maybe Text, Int)
|
||||
:. Only Text
|
||||
|
||||
toRegistration :: RegistrationRow -> Either Text NameRegistration
|
||||
toRegistration
|
||||
@@ -599,6 +604,7 @@ toRegistration
|
||||
:. (nrPrice, method_, invoiceId_, codeId_, label_, secret_, nrContactLink, nrChannelLink, nonce_, deadline_)
|
||||
:. (signature_, commitTx, commitBlock, registerTx, registerBlock, revealAfter, revealBefore, expiresAt, nrRegisteredAt)
|
||||
:. (nrFailedAt, nrError, BI nrLive, Binary nrOrderHash, nrMoves, nrLinksRefusedAt, nrCreatedAt, nrUpdatedAt, source_, nrBalanceUsed)
|
||||
:. Only nrAgreedTerms
|
||||
) = do
|
||||
nrOwner <- decodeAddress owner
|
||||
nrPayment <- case (method_, invoiceId_, codeId_) of
|
||||
@@ -622,6 +628,7 @@ toRegistration
|
||||
nrOwner,
|
||||
nrCommitment,
|
||||
nrSealed,
|
||||
nrAgreedTerms,
|
||||
nrPhase,
|
||||
nrYears,
|
||||
nrPrice,
|
||||
@@ -734,7 +741,7 @@ updateRegistration db r now = do
|
||||
db
|
||||
[sql|
|
||||
UPDATE sx_badge_service_name_registrations
|
||||
SET version = version + 1, label_hash = ?, length = ?, duration = ?, commitment = ?, sealed = ?, phase = ?, price = ?,
|
||||
SET version = version + 1, label_hash = ?, length = ?, duration = ?, commitment = ?, sealed = ?, agreed_terms = ?, 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 = ?,
|
||||
registered_at = ?, failed_at = ?, error = ?, live = ?, moves = ?, links_refused_at = ?, updated_at = ?
|
||||
@@ -744,7 +751,7 @@ updateRegistration db r now = do
|
||||
WHERE o.live = 1 AND o.registration_id <> ? AND (o.commitment = ? OR (o.owner = ? AND o.label_hash = ?))
|
||||
)))
|
||||
|]
|
||||
( (Binary lh, nrLength, int64 nrDuration, Binary nrCommitment, nrSealed, nrPhase, nrPrice)
|
||||
( (Binary lh, nrLength, int64 nrDuration, Binary nrCommitment, nrSealed, nrAgreedTerms, nrPhase, nrPrice)
|
||||
:. (rvLabel <$> nrReveal, Binary . rvSecret <$> nrReveal, rvContactLink =<< nrReveal, rvChannelLink =<< nrReveal, int64 . rvNonce <$> nrReveal, int64 . rvDeadline <$> nrReveal, Binary . serializeSignature . rvSignature <$> nrReveal)
|
||||
:. (txHashField <$> nrCommitTx, int64 <$> nrCommitBlock, txHashField <$> nrRegisterTx, int64 <$> nrRegisterBlock, int64 <$> nrRevealAfter, int64 <$> nrRevealBefore, int64 <$> nrExpiresAt)
|
||||
:. (truncateToSecond <$> nrRegisteredAt, truncateToSecond <$> nrFailedAt, nrError, BI live, nrMoves, truncateToSecond <$> nrLinksRefusedAt, truncateToSecond now)
|
||||
@@ -752,7 +759,7 @@ updateRegistration db r now = do
|
||||
)
|
||||
if changed > 0 then pure $ Written (nrVersion + 1) else refusal
|
||||
where
|
||||
NameRegistration {nrId = RegistrationId rid, nrVersion, nrLabelHash = LabelHash lh, nrLength, nrDuration, nrOwner, nrCommitment, nrSealed, nrPhase, nrPrice, nrReveal} = r
|
||||
NameRegistration {nrId = RegistrationId rid, nrVersion, nrLabelHash = LabelHash lh, nrLength, nrDuration, nrOwner, nrCommitment, nrSealed, nrAgreedTerms, nrPhase, nrPrice, nrReveal} = r
|
||||
NameRegistration {nrCommitTx, nrCommitBlock, nrRegisterTx, nrRegisterBlock, nrRevealAfter, nrRevealBefore, nrExpiresAt} = r
|
||||
NameRegistration {nrRegisteredAt, nrFailedAt, nrError, nrMoves, nrLinksRefusedAt} = r
|
||||
live = orderLive r
|
||||
@@ -761,10 +768,10 @@ updateRegistration db r now = do
|
||||
[(version, BI storedLive)] | version == nrVersion -> pure $ if storedLive then LiveOrderExists else NotLive
|
||||
_ -> pure VersionChanged
|
||||
|
||||
-- | Another name, or other links: queued again with the reveal, transactions, reveal times and link refusal cleared.
|
||||
-- | Another name, or other links, with the terms agreed for it: 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 =
|
||||
retargetRegistration db r OrderFields {ofLabelHash, ofLength, ofDuration, ofCommitment, ofSealed, ofAgreedTerms} price =
|
||||
updateRegistration
|
||||
db
|
||||
r
|
||||
@@ -773,6 +780,7 @@ retargetRegistration db r OrderFields {ofLabelHash, ofLength, ofDuration, ofComm
|
||||
nrDuration = ofDuration,
|
||||
nrCommitment = ofCommitment,
|
||||
nrSealed = ofSealed,
|
||||
nrAgreedTerms = ofAgreedTerms,
|
||||
nrPrice = price,
|
||||
nrPhase = PQueued,
|
||||
nrMoves = nrMoves r + 1,
|
||||
|
||||
@@ -98,11 +98,12 @@ viewJSON cfg@NamesConfig {nTLD, nChain = ChainConfig {cChainId, cResolver, cSpon
|
||||
"unread" .= vrUnread,
|
||||
"expiresAt" .= nrExpiresAt,
|
||||
"error" .= nrError,
|
||||
"community" .= communityJSON cfg (nrLabelHash r)
|
||||
"community" .= communityJSON cfg (nrLabelHash r),
|
||||
"terms" .= (if T.null nrAgreedTerms then Nothing else Just nrAgreedTerms)
|
||||
]
|
||||
where
|
||||
NameRegistration {nrId = RegistrationId rid, nrVersion, nrMoves, nrLinksRefusedAt, nrPhase, nrLabelHash = LabelHash lh, nrReveal, nrOwner, nrCommitment, nrSealed} = r
|
||||
NameRegistration {nrYears, nrDuration, nrPrice, nrBalanceUsed, nrCommitTx, nrRegisterTx, nrRevealAfter, nrRevealBefore, nrExpiresAt, nrError} = r
|
||||
NameRegistration {nrYears, nrDuration, nrPrice, nrBalanceUsed, nrCommitTx, nrRegisterTx, nrRevealAfter, nrRevealBefore, nrExpiresAt, nrError, nrAgreedTerms} = r
|
||||
txText (TxHash h) = hex h
|
||||
waitingText :: LateWait -> Text
|
||||
waitingText = \case
|
||||
|
||||
@@ -22,7 +22,8 @@ schemaMigrations =
|
||||
("20261010_names", m20261010_names, Just down_m20261010_names),
|
||||
("20261022_drop_taken_codes", m20261022_drop_taken_codes, Just down_m20261022_drop_taken_codes),
|
||||
("20261022_name_balances", m20261022_name_balances, Just down_m20261022_name_balances),
|
||||
("20261022_name_late_wait", m20261022_name_late_wait, Just down_m20261022_name_late_wait)
|
||||
("20261022_name_late_wait", m20261022_name_late_wait, Just down_m20261022_name_late_wait),
|
||||
("20261023_name_terms", m20261023_name_terms, Just down_m20261023_name_terms)
|
||||
]
|
||||
|
||||
-- | The client tables share this database, so the service tables are the same names behind a prefix.
|
||||
@@ -459,6 +460,23 @@ down_m20261022_name_late_wait =
|
||||
ALTER TABLE @name_invoices DROP COLUMN late_support;
|
||||
|]
|
||||
|
||||
-- The terms an order signed; '' for an order stored before orders signed them.
|
||||
m20261023_name_terms :: Text
|
||||
m20261023_name_terms =
|
||||
withPrefix
|
||||
servicePrefix
|
||||
[r|
|
||||
ALTER TABLE @name_registrations ADD COLUMN agreed_terms TEXT NOT NULL DEFAULT '';
|
||||
|]
|
||||
|
||||
down_m20261023_name_terms :: Text
|
||||
down_m20261023_name_terms =
|
||||
withPrefix
|
||||
servicePrefix
|
||||
[r|
|
||||
ALTER TABLE @name_registrations DROP COLUMN agreed_terms;
|
||||
|]
|
||||
|
||||
{- TODO [badges] deferred with the draft in M20260915_user_badges, service only.
|
||||
|
||||
ALTER TABLE @payments ADD COLUMN receipt_hash BYTEA;
|
||||
|
||||
@@ -23,7 +23,8 @@ schemaMigrations =
|
||||
("20261010_names", m20261010_names, Just down_m20261010_names),
|
||||
("20261022_drop_taken_codes", m20261022_drop_taken_codes, Just down_m20261022_drop_taken_codes),
|
||||
("20261022_name_balances", m20261022_name_balances, Just down_m20261022_name_balances),
|
||||
("20261022_name_late_wait", m20261022_name_late_wait, Just down_m20261022_name_late_wait)
|
||||
("20261022_name_late_wait", m20261022_name_late_wait, Just down_m20261022_name_late_wait),
|
||||
("20261023_name_terms", m20261023_name_terms, Just down_m20261023_name_terms)
|
||||
]
|
||||
|
||||
-- | The client tables share this database, so the service tables are the same names behind a prefix.
|
||||
@@ -461,6 +462,23 @@ down_m20261022_name_late_wait =
|
||||
ALTER TABLE @name_invoices DROP COLUMN late_support;
|
||||
|]
|
||||
|
||||
-- The terms an order signed; '' for an order stored before orders signed them.
|
||||
m20261023_name_terms :: Query
|
||||
m20261023_name_terms =
|
||||
withPrefix
|
||||
servicePrefix
|
||||
[sql|
|
||||
ALTER TABLE @name_registrations ADD COLUMN agreed_terms TEXT NOT NULL DEFAULT '';
|
||||
|]
|
||||
|
||||
down_m20261023_name_terms :: Query
|
||||
down_m20261023_name_terms =
|
||||
withPrefix
|
||||
servicePrefix
|
||||
[sql|
|
||||
ALTER TABLE @name_registrations DROP COLUMN agreed_terms;
|
||||
|]
|
||||
|
||||
{- TODO [badges] deferred with the draft in M20260915_user_badges, service only.
|
||||
|
||||
ALTER TABLE @payments ADD COLUMN receipt_hash BLOB;
|
||||
|
||||
@@ -97,13 +97,14 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters
|
||||
where
|
||||
what = "POST /api/invoice (name)"
|
||||
refuse = refused what
|
||||
newOrder InvoiceOrder {ioRequest = req@OrderRequest {orFields = OrderFields {ofLabelHash, ofLength, ofDuration}, orTimestamp}, ioMethod, ioPrice} = do
|
||||
newOrder InvoiceOrder {ioRequest = req@OrderRequest {orFields = fields@OrderFields {ofLabelHash, ofLength, ofDuration}, orTimestamp}, ioMethod, ioPrice} = do
|
||||
now <- oeNow
|
||||
let years = nYears $ oeConfig env
|
||||
price = fromIntegral ioPrice
|
||||
checks =
|
||||
[ pure $ checkTimestamp now orTimestamp,
|
||||
pure $ checkDuration (oeConfig env) now years ofDuration,
|
||||
pure $ checkTerms (oeConfig env) fields,
|
||||
checkNameFree (oeContracts env) oeStore ofLabelHash,
|
||||
checkPrice (oeContracts env) ofLength years price
|
||||
]
|
||||
@@ -207,10 +208,11 @@ codeOrderHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow}
|
||||
EOResent NameRegistration {nrId} -> pure $ answerNow $ registrationAnswer nrId
|
||||
EOMeets -> refuse OROrderExists
|
||||
EONew _ -> newOrder now order code
|
||||
newOrder now order@OrderRequest {orFields = OrderFields {ofLabelHash, ofDuration}, orTimestamp} code@PrepaidCode {pcYears} = do
|
||||
newOrder now order@OrderRequest {orFields = fields@OrderFields {ofLabelHash, ofDuration}, orTimestamp} code@PrepaidCode {pcYears} = do
|
||||
let checks =
|
||||
[ pure $ checkTimestamp now orTimestamp,
|
||||
pure $ checkDuration oeConfig now pcYears ofDuration,
|
||||
pure $ checkTerms oeConfig fields,
|
||||
checkNameFree oeContracts oeStore ofLabelHash
|
||||
]
|
||||
firstRefusal checks >>= \case
|
||||
@@ -253,10 +255,11 @@ spendHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} cfg
|
||||
EOResent r -> resentOrder env cfg what now r
|
||||
EOMeets -> refuse OROrderExists
|
||||
EONew _ -> runExceptT (checked now order spend) >>= either refuse (place order spend)
|
||||
checked now OrderRequest {orFields = OrderFields {ofLabelHash, ofLength, ofDuration}, orTimestamp} spend@Spend {spPrice} = do
|
||||
checked now OrderRequest {orFields = fields@OrderFields {ofLabelHash, ofLength, ofDuration}, orTimestamp} spend@Spend {spPrice} = do
|
||||
let years = nYears oeConfig
|
||||
liftEither $ checkTimestamp now orTimestamp
|
||||
liftEither $ checkDuration oeConfig now years ofDuration
|
||||
liftEither $ checkTerms oeConfig fields
|
||||
holder <- ExceptT $ checkSpendBalance oeStore spend now
|
||||
ExceptT $ checkNameFree oeContracts oeStore ofLabelHash
|
||||
ExceptT $ checkPrice oeContracts ofLength years spPrice
|
||||
@@ -343,3 +346,4 @@ orderRefusalResponse = \case
|
||||
ORCode refusal -> codeRefusalResponse refusal
|
||||
ORPriceTooHigh price -> jsonResponse status409 $ J.object ["error" .= ("price_too_high" :: Text), "price" .= price]
|
||||
ORBalanceChanged balance -> jsonResponse status409 $ J.object ["error" .= ("balance_changed" :: Text), "balance" .= (balanceJSON <$> balance)]
|
||||
ORTermsChanged terms community -> jsonResponse status409 $ J.object ["error" .= ("terms_changed" :: Text), "terms" .= terms, "community" .= community]
|
||||
@@ -123,7 +123,7 @@ retargetHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} r
|
||||
moveChecked now r@NameRegistration {nrMoves, nrYears, nrPrice, nrPayment} fields@OrderFields {ofLabelHash, ofLength, ofDuration}
|
||||
| nrMoves >= nMaxOrderMoves oeConfig = answerNow <$> registrationRefusalResponse env "move_limit" rid
|
||||
| otherwise =
|
||||
firstRefusal [checkMoveMeets oeStore r fields now, pure $ checkDuration oeConfig now nrYears ofDuration, checkNameFree oeContracts oeStore ofLabelHash] >>= \case
|
||||
firstRefusal [checkMoveMeets oeStore r fields now, pure $ checkDuration oeConfig now nrYears ofDuration, pure $ checkTerms oeConfig fields, checkNameFree oeContracts oeStore ofLabelHash] >>= \case
|
||||
Just refusal -> refuse refusal
|
||||
Nothing -> case nrPayment of
|
||||
RPInvoice {} -> checkMovePrice oeContracts r ofLength >>= either refuse (write now r fields)
|
||||
|
||||
@@ -24,7 +24,7 @@ import StoreService.Service (ServiceState (..), checkDevChain, newServiceState,
|
||||
import StoreService.Store (ManagedGroup (..), getManagedGroup)
|
||||
import StoreService.Waiters (newWaiters)
|
||||
import Bots.StoreService.BotTests (badgeBotName, badgeCmdUsage, badgeProfile, badgeTypeOf, credentialOf, devKeysIni, entryOf, issueCode, issueRaw, mkStoreServiceOpts, newPurchaseKeys, operatorCmd, redeemWithQueue, requestObject, revokeRaw, serviceDbPrefix, shouldAnswerError, statementOf, stopStoreService, testIssuerKeyIdx, withStoreService)
|
||||
import Bots.StoreService.ConfigTests (chainSection, controllerAddr, namesSection)
|
||||
import Bots.StoreService.ConfigTests (chainSection, controllerAddr, namesSection, termsVersion)
|
||||
import Bots.StoreService.FakeEthNode (CallAnswer (..), FakeEthNode (..), Fault (..), answerCall, awaitSent, setFault, withFakeEthNode)
|
||||
import Bots.StoreService.WebTests (capturingStderr, digestFixture)
|
||||
import Bots.StoreService.NamesSearchTests (aliceHex)
|
||||
@@ -220,6 +220,7 @@ testNamesBoot ps = do
|
||||
"sealed" J..= ("sealed" :: Text),
|
||||
"price" J..= (10000 :: Int),
|
||||
"balance" J..= (10000 :: Int),
|
||||
"terms" J..= termsVersion,
|
||||
"timestamp" J..= (1792574100 :: Int),
|
||||
"signature" J..= ("0x" <> T.replicate 32 "11" <> T.replicate 32 "22" <> "1b")
|
||||
]
|
||||
|
||||
@@ -7,6 +7,7 @@
|
||||
|
||||
module Bots.StoreService.NamesBalancesTests (namesBalancesTests, cardPaid, coveredSpend, credit, creditLate, fieldsN, figures, holdPrice, holder, invariantHolds, lateCredit, payment, placeOrderRow, settleHolder, source) where
|
||||
|
||||
import Bots.StoreService.ConfigTests (termsVersion)
|
||||
import Bots.StoreService.NamesOrdersTests (Ctx (..), withOrders)
|
||||
import Bots.StoreService.NamesStoreTests (at, btc, invoiceStatus, newReg, ownerA, ownerB, paidOrder, reg, signature, t0, write)
|
||||
import Bots.StoreService.WebTests (capturingStderr, rcv, withServiceStore, withServiceStores)
|
||||
@@ -101,7 +102,8 @@ fieldsN label =
|
||||
ofLength = T.length label,
|
||||
ofDuration = 69292800,
|
||||
ofCommitment = C.sha256Hash $ encodeUtf8 label,
|
||||
ofSealed = "sealed-" <> label
|
||||
ofSealed = "sealed-" <> label,
|
||||
ofAgreedTerms = termsVersion
|
||||
}
|
||||
|
||||
-- | A crypto invoice row, or a card one with its client secret in place of an address.
|
||||
|
||||
@@ -10,6 +10,8 @@ module Bots.StoreService.NamesOrdersTests
|
||||
withOrdersVia,
|
||||
withOrdersOn,
|
||||
withOrdersCancelling,
|
||||
withSettings,
|
||||
configured,
|
||||
aliceOrder,
|
||||
commitmentOf,
|
||||
fieldsOf,
|
||||
@@ -34,6 +36,14 @@ module Bots.StoreService.NamesOrdersTests
|
||||
field,
|
||||
advance,
|
||||
refusedWith,
|
||||
malformedTerms,
|
||||
listName,
|
||||
bakers,
|
||||
bumpedTerms,
|
||||
newerTerms,
|
||||
olderTerms,
|
||||
communityTerms,
|
||||
termsChanged,
|
||||
)
|
||||
where
|
||||
|
||||
@@ -151,6 +161,14 @@ namesOrdersTests = describe "StoreService names: orders" $ do
|
||||
it "runs code orders in the code's turn, one of two spending one code for two names winning, the other answered code_reserved" testConcurrentCodeOrders
|
||||
it "answers the code's refusal when its reservation fails in the insert, writing nothing" testCodeNotReservable
|
||||
it "counts code orders and code checks against one code limit" testCodeLimitShared
|
||||
describe "terms" $ do
|
||||
it "answers terms_changed with the current terms and community for an old version or the wrong variant, listed or not, creating nothing" testTermsChanged
|
||||
it "accepts the community terms for a listed name as Appendix C signs them, storing them" testCommunityTerms
|
||||
it "answers an exact resend after the version changed, and takes the same fields under the new terms as another order" testResendAfterBump
|
||||
it "checks the terms after the existing orders, the timestamp and the duration, before the chain and the price" testTermsCheckOrder
|
||||
it "answers terms_changed for a code order under old terms, listed or not, leaving the code unreserved, and accepts the community terms" testCodeTermsChanged
|
||||
it "answers a code order's exact resend after the version changed" testCodeResendAfterBump
|
||||
it "checks a code order's terms after the timestamp, before the chain and the code's state" testCodeTermsCheckOrder
|
||||
describe "closed orders" $ do
|
||||
it "accepts a new order of the same wallet and name after a cancel" testOrderAfterCancel
|
||||
it "closes an overdue order of the same wallet and name before the poller marks it, cancelling its invoice after" testOverdueClosed
|
||||
@@ -176,6 +194,7 @@ namesOrdersTests = describe "StoreService names: orders" $ do
|
||||
describe "registration view" $ do
|
||||
it "has the contract's fields" testViewFields
|
||||
it "has the community entry of its label hash, null for an unlisted name" testViewCommunity
|
||||
it "has the terms the order signed, null for an order stored before orders signed them" testViewTerms
|
||||
it "reads the intent nonce in committed and nothing in taken" testViewReads
|
||||
it "leaves a failed intentNonce read null and named in unread, reading nothing in taken" testViewUnread
|
||||
it "reads the order's balance, held until its holder's invoice expires and free past it, and the cents its order took from another's" testViewBalance
|
||||
@@ -226,6 +245,7 @@ data Order = Order
|
||||
oDuration :: Word64,
|
||||
oMethod :: Text,
|
||||
oPrice :: Int,
|
||||
oTerms :: Text,
|
||||
oTimestamp :: Word64
|
||||
}
|
||||
|
||||
@@ -240,6 +260,7 @@ aliceOrder =
|
||||
oDuration = durationAt orderTime,
|
||||
oMethod = "btc",
|
||||
oPrice = alicePrice,
|
||||
oTerms = termsVersion,
|
||||
oTimestamp = seconds orderTime
|
||||
}
|
||||
|
||||
@@ -251,8 +272,8 @@ commitmentOf :: Int -> ByteString
|
||||
commitmentOf n = C.sha256Hash $ BC.pack $ "commitment " <> show n
|
||||
|
||||
fieldsOf :: Order -> OrderFields
|
||||
fieldsOf Order {oLabel, oCommitment, oSealed, oDuration} =
|
||||
OrderFields {ofLabelHash = labelHash oLabel, ofLength = T.length oLabel, ofDuration = oDuration, ofCommitment = oCommitment, ofSealed = oSealed}
|
||||
fieldsOf Order {oLabel, oCommitment, oSealed, oDuration, oTerms} =
|
||||
OrderFields {ofLabelHash = labelHash oLabel, ofLength = T.length oLabel, ofDuration = oDuration, ofCommitment = oCommitment, ofSealed = oSealed, ofAgreedTerms = oTerms}
|
||||
|
||||
signedBody :: TVar ChaChaDRG -> Order -> IO J.Object
|
||||
signedBody g o@Order {oKey, oTimestamp} = do
|
||||
@@ -271,10 +292,11 @@ unsignedBody o@Order {oOwner, oMethod, oPrice, oTimestamp} =
|
||||
("sealed", J.String ofSealed),
|
||||
("method", J.String oMethod),
|
||||
("price", J.toJSON oPrice),
|
||||
("terms", J.String ofAgreedTerms),
|
||||
("timestamp", J.toJSON oTimestamp)
|
||||
]
|
||||
where
|
||||
OrderFields {ofLabelHash = LabelHash lh, ofLength, ofDuration, ofCommitment, ofSealed} = fieldsOf o
|
||||
OrderFields {ofLabelHash = LabelHash lh, ofLength, ofDuration, ofCommitment, ofSealed, ofAgreedTerms} = fieldsOf o
|
||||
|
||||
withSignature :: Text -> J.Object -> J.Object
|
||||
withSignature sig = KM.insert "signature" (J.String sig)
|
||||
@@ -352,6 +374,20 @@ withOrdersOn cOpenStore via action = cOpenStore >>= \cStore -> withFakeEthNode $
|
||||
Warp.testWithApplicationSettings (webSettings (listener cfg)) (pure $ ordersApp cWeb cOrders) $ \port ->
|
||||
action Ctx {cStore, cOpenStore, cNode, cOrders, cWeb, cClient = (mgr, "http://127.0.0.1:" <> show port), cStub, cClock, cRandom, cIps}
|
||||
|
||||
-- | The context's store, chain, providers and clock with its names settings changed, as after a restart.
|
||||
configured :: (NamesConfig -> NamesConfig) -> Ctx -> Ctx
|
||||
configured change ctx@Ctx {cOrders, cWeb} = ctx {cOrders = orders, cWeb = cWeb {weOrders = Just orders}}
|
||||
where
|
||||
orders = cOrders {oeConfig = change (oeConfig cOrders)}
|
||||
|
||||
-- | Another server of the orders routes over the context with its names settings changed.
|
||||
withSettings :: (NamesConfig -> NamesConfig) -> Ctx -> (Ctx -> IO a) -> IO a
|
||||
withSettings change ctx action = do
|
||||
let ctx'@Ctx {cOrders, cWeb} = configured change ctx
|
||||
mgr <- newManager defaultManagerSettings
|
||||
Warp.testWithApplicationSettings (webSettings (listener $ weConfig cWeb)) (pure $ ordersApp cWeb cOrders) $ \port ->
|
||||
action ctx' {cClient = (mgr, "http://127.0.0.1:" <> show port)}
|
||||
|
||||
ordersApp :: WebEnv -> OrdersEnv -> Application
|
||||
ordersApp web orders req respond = fromMaybe (webApp web req respond) (namesApp (weHttp web) (codeRoutes orders (weProviders web) (weWaiters web)) req respond)
|
||||
|
||||
@@ -459,28 +495,40 @@ testPaidOrder = withOrders $ \ctx -> do
|
||||
field "labelHash" r `shouldBe` Just (J.String $ hex $ (\(LabelHash h) -> h) alice)
|
||||
field "price" r `shouldBe` Just (J.Number 10000)
|
||||
field "duration" r `shouldBe` Just (J.toJSON $ durationAt orderTime)
|
||||
field "terms" r `shouldBe` Just (J.String termsVersion)
|
||||
stubCalls (cStub ctx) `shouldReturn` [StubCreate (SPMCrypto CCBtc) OrderDraft {odAmount = CurrencyAmount 10000, odCurrency = "usd"}]
|
||||
reg <- invoiceRegistration ctx invId
|
||||
(nrPhase reg, nrLive reg, nrVersion reg, nrYears reg, nrPrice reg, nrPayment reg) `shouldBe` (PUnpaid, True, 1, 2, 10000, RPInvoice (SPMCrypto CCBtc) invId)
|
||||
nrOrderHash reg `shouldBe` orderHash ownerA (fieldsOf aliceOrder) (OTInvoice (SPMCrypto CCBtc) 10000)
|
||||
nrAgreedTerms reg `shouldBe` termsVersion
|
||||
|
||||
-- | The body of the webapp's order vector, with viem's signature over it (NamesSignatureTests).
|
||||
-- | The body of the contract's Appendix C order vector, with viem's signature over it (NamesSignatureTests).
|
||||
testViemOrder :: IO ()
|
||||
testViemOrder = withOrders $ \ctx -> do
|
||||
let dynamis =
|
||||
aliceOrder
|
||||
{ oLabel = "dynamis",
|
||||
oCommitment = unhex "9cf04ddef2eedfb02e6e7ba58f879c0636c584b6acc67ffe9f97a06bfb016ac1",
|
||||
oSealed = "q3Zk0Yx7c2VhbGVkLW9yZGVyLWZpeHR1cmU",
|
||||
oDuration = 69259500,
|
||||
oPrice = 20000
|
||||
}
|
||||
viemSignature = "0x73e32be461e99e64b093a4ad09b04b4d810e5623a1b0e9c9fdb4701ec2a6a2a84df9ffdccc39c5cb827cde4d846c7662f591665f1b868ab1c15778646d3f414e1b"
|
||||
signedBody (cRandom ctx) dynamis >>= (`shouldBe` withSignature viemSignature (unsignedBody dynamis))
|
||||
(status, v) <- postOrder ctx $ withSignature viemSignature (unsignedBody dynamis)
|
||||
testViemOrder = withOrders $ \ctx0 -> withSettings vectorTermStart ctx0 $ \ctx -> do
|
||||
writeIORef (cClock ctx) (posixSecondsToUTCTime $ fromIntegral $ oTimestamp vectorOrder)
|
||||
signedBody (cRandom ctx) vectorOrder >>= (`shouldBe` withSignature vectorSignature (unsignedBody vectorOrder))
|
||||
(status, v) <- postOrder ctx $ withSignature vectorSignature (unsignedBody vectorOrder)
|
||||
status `shouldBe` 200
|
||||
(field "phase" . registrationOf =<< v) `shouldBe` Just "unpaid"
|
||||
|
||||
-- | Appendix C's order: alicebakery with no links, signed with the terms version.
|
||||
vectorOrder :: Order
|
||||
vectorOrder =
|
||||
aliceOrder
|
||||
{ oCommitment = unhex "5e62a4cb7da596cb38169a6a552b5f69db2acee279b53be6693a78e03c3dfaa5",
|
||||
oSealed = "AAAAAAAAAAAAAAAACWgxqMk-UKfpra_Zh6vc4KNBR6SX1WYpGb4COoWCCbM0bisYCH14WLzghp8hqi_-KyXSi4qf_DAdP_M4bFetD0s",
|
||||
oDuration = 69292800,
|
||||
oTimestamp = 1792828800
|
||||
}
|
||||
|
||||
vectorSignature :: Text
|
||||
vectorSignature = "0x17107b11494e25098efc348aca64a2469ffb832bcc79dc57377a1b26a4004b6701ad73648f50af8b39d4079820a3de7e681ddf15f8cf15b5cff02b4a48cf1fe61c"
|
||||
|
||||
-- | Appendix C's duration is the page's at 21 October 2026 00:00 UTC, before its timestamp,
|
||||
-- so the term starts later by as much for the vector to pass the duration check at its timestamp.
|
||||
vectorTermStart :: NamesConfig -> NamesConfig
|
||||
vectorTermStart cfg = cfg {nTermStart = posixSecondsToUTCTime $ fromIntegral $ oTimestamp vectorOrder + oDuration vectorOrder - 2 * yearSeconds}
|
||||
|
||||
testExactResend :: IO ()
|
||||
testExactResend = withOrders $ \ctx -> do
|
||||
body <- signedBody (cRandom ctx) aliceOrder
|
||||
@@ -545,7 +593,8 @@ testOneFieldDiffers = withOrders $ \ctx -> do
|
||||
aliceOrder {oDuration = oDuration aliceOrder + 1},
|
||||
aliceOrder {oMethod = "xmr"},
|
||||
aliceOrder {oMethod = "card"},
|
||||
aliceOrder {oPrice = alicePrice + 1}
|
||||
aliceOrder {oPrice = alicePrice + 1},
|
||||
aliceOrder {oTerms = termsVersion <> "/community"}
|
||||
]
|
||||
forM_ variants $ \o -> placeOrder ctx o `shouldReturn` refusedWith 409 "order_exists"
|
||||
length <$> stubCalls (cStub ctx) `shouldReturn` 1
|
||||
@@ -695,13 +744,52 @@ testFormats = withOrders $ \ctx -> do
|
||||
with "duration" (J.Number (-1)),
|
||||
with "timestamp" "1792574100",
|
||||
with "length" (J.Number 1e30),
|
||||
KM.delete "terms" good,
|
||||
with "terms" (J.Number 20261023),
|
||||
KM.delete "kind" good,
|
||||
with "kind" "badge"
|
||||
]
|
||||
$ \body -> postOrder ctx body `shouldReturn` refusedWith 400 "bad_request"
|
||||
forM_ malformedTerms $ \t -> placeOrder ctx aliceOrder {oTerms = t} `shouldReturn` refusedWith 400 "bad_request"
|
||||
forM_ [5, 64] $ \len -> postOrder ctx (with "length" (J.Number len)) `shouldReturn` refusedWith 400 "invalid_name"
|
||||
stubCalls (cStub ctx) `shouldReturn` []
|
||||
|
||||
-- | The name on the operator's community list.
|
||||
listName :: Text -> NamesConfig -> NamesConfig
|
||||
listName label cfg = cfg {nCommunity = M.insert lh bakers (nCommunity cfg)}
|
||||
where
|
||||
LabelHash lh = labelHash label
|
||||
|
||||
bakers :: Text
|
||||
bakers = "bakers and bakeries in Portugal"
|
||||
|
||||
-- | The operator's next terms version, after a restart.
|
||||
bumpedTerms :: NamesConfig -> NamesConfig
|
||||
bumpedTerms cfg@NamesConfig {nTerms} = cfg {nTerms = nTerms {tVersion = newerTerms}}
|
||||
|
||||
newerTerms, olderTerms :: Text
|
||||
newerTerms = "2026-11-01"
|
||||
olderTerms = "2026-10-01"
|
||||
|
||||
communityTerms :: Text -> Text
|
||||
communityTerms version = version <> "/community"
|
||||
|
||||
-- | terms_changed with the current version, the terms' URL and the name's community entry.
|
||||
termsChanged :: Text -> Maybe Text -> (Int, Maybe J.Object)
|
||||
termsChanged version community =
|
||||
( 409,
|
||||
Just $
|
||||
KM.fromList
|
||||
[ ("error", "terms_changed"),
|
||||
("terms", J.object ["version" .= version, "url" .= termsUrl]),
|
||||
("community", maybe J.Null (\t -> J.object ["for" .= t]) community)
|
||||
]
|
||||
)
|
||||
|
||||
-- | Signed as sent, so only their format refuses them.
|
||||
malformedTerms :: [Text]
|
||||
malformedTerms = ["", T.replicate 49 "a", "2026-10-23 community", "2026-10-23+community", "2026-10-23/communit\233"]
|
||||
|
||||
testTwoWallets :: IO ()
|
||||
testTwoWallets = withOrders $ \ctx -> do
|
||||
(a, _) <- placed ctx aliceOrder
|
||||
@@ -709,6 +797,64 @@ testTwoWallets = withOrders $ \ctx -> do
|
||||
a `shouldNotBe` b
|
||||
mapM (fmap nrLive . invoiceRegistration ctx) [a, b] `shouldReturn` [True, True]
|
||||
|
||||
testTermsChanged :: IO ()
|
||||
testTermsChanged = withOrders $ \ctx0 -> withSettings (listName "dynamis") ctx0 $ \ctx -> do
|
||||
let dynamis = aliceOrder {oLabel = "dynamis", oCommitment = commitmentOf 2, oPrice = 20000}
|
||||
-- 48 characters pass the format and meet the terms check
|
||||
forM_ [olderTerms, communityTerms termsVersion, communityTerms olderTerms, T.replicate 48 "a"] $ \t ->
|
||||
placeOrder ctx aliceOrder {oTerms = t} `shouldReturn` termsChanged termsVersion Nothing
|
||||
forM_ [termsVersion, olderTerms, communityTerms olderTerms] $ \t ->
|
||||
placeOrder ctx dynamis {oTerms = t} `shouldReturn` termsChanged termsVersion (Just bakers)
|
||||
stubCalls (cStub ctx) `shouldReturn` []
|
||||
registrationsOf ctx ownerA `shouldReturn` []
|
||||
(invId, v) <- placed ctx dynamis {oTerms = communityTerms termsVersion}
|
||||
field "terms" (registrationOf v) `shouldBe` Just (J.String $ communityTerms termsVersion)
|
||||
nrAgreedTerms <$> invoiceRegistration ctx invId `shouldReturn` communityTerms termsVersion
|
||||
|
||||
testCommunityTerms :: IO ()
|
||||
testCommunityTerms = withOrders $ \ctx0 -> withSettings (listName "alicebakery" . vectorTermStart) ctx0 $ \ctx -> do
|
||||
writeIORef (cClock ctx) (posixSecondsToUTCTime $ fromIntegral $ oTimestamp vectorOrder)
|
||||
postOrder ctx (withSignature vectorSignature $ unsignedBody vectorOrder) `shouldReturn` termsChanged termsVersion (Just bakers)
|
||||
let community = vectorOrder {oTerms = communityTerms termsVersion}
|
||||
communitySignature = "0x03eccb591b79ab4e3e6f22ccbeb77a6ac32c6dad8cb318557836258c390bc31d78852a3279c6c8cc2ef8d1025641d45ba4101f54dfd84c264deb2ab391c1cbc61c"
|
||||
signedBody (cRandom ctx) community >>= (`shouldBe` withSignature communitySignature (unsignedBody community))
|
||||
(status, v) <- postOrder ctx $ withSignature communitySignature (unsignedBody community)
|
||||
(status, field "terms" . registrationOf =<< v, field "community" . registrationOf =<< v)
|
||||
`shouldBe` (200, Just (J.String $ communityTerms termsVersion), Just (J.object ["for" .= bakers]))
|
||||
|
||||
testResendAfterBump :: IO ()
|
||||
testResendAfterBump = withOrders $ \ctx0 -> do
|
||||
body <- signedBody (cRandom ctx0) aliceOrder
|
||||
(invId@(InvoiceId invText), view) <- placed ctx0 aliceOrder
|
||||
withSettings bumpedTerms ctx0 $ \ctx -> do
|
||||
advance ctx 60
|
||||
let later = aliceOrder {oTimestamp = seconds orderTime + 60}
|
||||
postOrder ctx body `shouldReturn` (200, Just view)
|
||||
placed ctx later `shouldReturn` (invId, view)
|
||||
placeOrder ctx later {oTerms = newerTerms} `shouldReturn` refusedWith 409 "order_exists"
|
||||
fst <$> post ctx ("/api/invoice/" <> T.unpack invText <> "/cancel") "" `shouldReturn` 200
|
||||
(newer, _) <- placed ctx later {oTerms = newerTerms}
|
||||
newer `shouldNotBe` invId
|
||||
[n, o] <- mapM (invoiceRegistration ctx) [newer, invId]
|
||||
(nrAgreedTerms n, nrAgreedTerms o) `shouldBe` (newerTerms, termsVersion)
|
||||
nrOrderHash n `shouldNotBe` nrOrderHash o
|
||||
(status, v) <- postOrder ctx body
|
||||
(status, field "invoiceId" =<< v, field "status" =<< v) `shouldBe` (200, Just (J.String invText), Just "expired")
|
||||
|
||||
testTermsCheckOrder :: IO ()
|
||||
testTermsCheckOrder = withOrders $ \ctx@Ctx {cNode = node} -> do
|
||||
let old = aliceOrder {oTerms = olderTerms}
|
||||
void $ placed ctx aliceOrder {oOwner = ownerBText, oKey = keyB, oCommitment = commitmentOf 5}
|
||||
placeOrder ctx old {oOwner = ownerBText, oKey = keyB, oCommitment = commitmentOf 6} `shouldReturn` refusedWith 409 "order_exists"
|
||||
placeOrder ctx old {oTimestamp = seconds orderTime + 601} `shouldReturn` refusedWith 400 "bad_request"
|
||||
placeOrder ctx old {oDuration = oDuration old + fromIntegral slackSeconds + 1} `shouldReturn` refusedWith 400 "bad_request"
|
||||
placeOrder ctx old {oPrice = 9000} `shouldReturn` termsChanged termsVersion Nothing
|
||||
answerCall node fakeController reservedNamesCall $ Returns $ uint256 (1 :: Int)
|
||||
placeOrder ctx old `shouldReturn` termsChanged termsVersion Nothing
|
||||
setFault node "eth_call" HttpFailure
|
||||
placeOrder ctx old `shouldReturn` termsChanged termsVersion Nothing
|
||||
length <$> stubCalls (cStub ctx) `shouldReturn` 1
|
||||
|
||||
-- code orders
|
||||
|
||||
-- | A prepaid code as the operator issues it, with its text as the page sends it.
|
||||
@@ -757,7 +903,7 @@ testCodeOrder = withOrders $ \ctx -> do
|
||||
rid <- registered ctx code aliceOrder
|
||||
r <- registrationById ctx rid
|
||||
(nrPhase r, nrLive r, nrVersion r, nrYears r, nrPrice r, nrPayment r) `shouldBe` (PQueued, True, 1, 2, 0, RPCode pcId)
|
||||
(nrOwner r, nrDuration r, nrCommitment r, nrSealed r) `shouldBe` (ownerA, durationAt orderTime, oCommitment aliceOrder, oSealed aliceOrder)
|
||||
(nrOwner r, nrDuration r, nrCommitment r, nrSealed r, nrAgreedTerms r) `shouldBe` (ownerA, durationAt orderTime, oCommitment aliceOrder, oSealed aliceOrder, termsVersion)
|
||||
nrOrderHash r `shouldBe` orderHash ownerA (fieldsOf aliceOrder) (OTCode pcCodeHash)
|
||||
held <- readCode ctx issued
|
||||
(pcReservedBy held, pcReservedAt held, pcSpentAt held) `shouldBe` (Just rid, Just orderTime, Nothing)
|
||||
@@ -781,6 +927,46 @@ testCodeResend = withOrders $ \ctx -> do
|
||||
register ctx code aliceOrder {oTimestamp = seconds orderTime + 3660} `shouldReturn` registrationAnswer rid
|
||||
length <$> registrationsOf ctx ownerA `shouldReturn` 1
|
||||
|
||||
testCodeTermsChanged :: IO ()
|
||||
testCodeTermsChanged = withOrders $ \ctx0 -> withSettings (listName "dynamis") ctx0 $ \ctx -> do
|
||||
(code, issued) <- issueCode ctx 7 2 id
|
||||
let dynamis = aliceOrder {oLabel = "dynamis", oCommitment = commitmentOf 2}
|
||||
forM_ [olderTerms, communityTerms termsVersion] $ \t ->
|
||||
register ctx code aliceOrder {oTerms = t} `shouldReturn` termsChanged termsVersion Nothing
|
||||
forM_ [termsVersion, communityTerms olderTerms] $ \t ->
|
||||
register ctx code dynamis {oTerms = t} `shouldReturn` termsChanged termsVersion (Just bakers)
|
||||
pcReservedBy <$> readCode ctx issued `shouldReturn` Nothing
|
||||
rid <- registered ctx code dynamis {oTerms = communityTerms termsVersion}
|
||||
nrAgreedTerms <$> registrationById ctx rid `shouldReturn` communityTerms termsVersion
|
||||
pcReservedBy <$> readCode ctx issued `shouldReturn` Just rid
|
||||
|
||||
testCodeResendAfterBump :: IO ()
|
||||
testCodeResendAfterBump = withOrders $ \ctx0 -> do
|
||||
(code, _) <- issueCode ctx0 8 2 id
|
||||
rid <- registered ctx0 code aliceOrder
|
||||
withSettings bumpedTerms ctx0 $ \ctx -> do
|
||||
advance ctx 60
|
||||
register ctx code aliceOrder `shouldReturn` registrationAnswer rid
|
||||
register ctx code aliceOrder {oTimestamp = seconds orderTime + 60} `shouldReturn` registrationAnswer rid
|
||||
register ctx code aliceOrder {oTerms = newerTerms, oTimestamp = seconds orderTime + 60} `shouldReturn` refusedWith 409 "order_exists"
|
||||
|
||||
testCodeTermsCheckOrder :: IO ()
|
||||
testCodeTermsCheckOrder = withOrders $ \ctx@Ctx {cStore, cNode = node} -> do
|
||||
let old = aliceOrder {oTerms = olderTerms}
|
||||
(code, _) <- issueCode ctx 8 2 id
|
||||
register ctx code old {oTimestamp = seconds orderTime + 601} `shouldReturn` refusedWith 400 "bad_request"
|
||||
register ctx code old {oDuration = oDuration old + fromIntegral slackSeconds + 1} `shouldReturn` refusedWith 400 "bad_request"
|
||||
(reserved, reservedCode) <- issueCode ctx 8 2 id
|
||||
placeCode cStore "holder" ownerB (order "holderone" 1) reservedCode `shouldReturn` Right ()
|
||||
(long, _) <- issueCode ctx 12 2 id
|
||||
(unpaid, _) <- issueCode ctx 8 2 $ \c -> c {npcPaymentStatus = CPSUnpaid}
|
||||
forM_ [reserved, long, unpaid] $ \c -> register ctx c old `shouldReturn` termsChanged termsVersion Nothing
|
||||
answerCall node fakeController reservedNamesCall $ Returns $ uint256 (1 :: Int)
|
||||
register ctx code old `shouldReturn` termsChanged termsVersion Nothing
|
||||
setFault node "eth_call" HttpFailure
|
||||
register ctx code old `shouldReturn` termsChanged termsVersion Nothing
|
||||
length <$> registrationsOf ctx ownerA `shouldReturn` 0
|
||||
|
||||
testCodeOneFieldDiffers :: IO ()
|
||||
testCodeOneFieldDiffers = withOrders $ \ctx -> do
|
||||
(code, _) <- issueCode ctx 7 2 id
|
||||
@@ -791,6 +977,7 @@ testCodeOneFieldDiffers = withOrders $ \ctx -> do
|
||||
(code, aliceOrder {oCommitment = commitmentOf 2}),
|
||||
(code, aliceOrder {oSealed = "sealed-alicebakery-2"}),
|
||||
(code, aliceOrder {oDuration = oDuration aliceOrder + 1}),
|
||||
(code, aliceOrder {oTerms = termsVersion <> "/community"}),
|
||||
(other, aliceOrder)
|
||||
]
|
||||
forM_ variants $ \(c, o) -> register ctx c o `shouldReturn` refusedWith 409 "order_exists"
|
||||
@@ -922,9 +1109,11 @@ testCodeSizes = withOrders $ \ctx -> do
|
||||
with "code" (J.Number 8),
|
||||
with "labelHash" (J.String $ T.toUpper $ hex $ (\(LabelHash h) -> h) alice),
|
||||
with "owner" (J.String $ T.toLower ownerAText),
|
||||
with "timestamp" "1792574100"
|
||||
with "timestamp" "1792574100",
|
||||
KM.delete "terms" good
|
||||
]
|
||||
$ \body -> postRegister ctx body `shouldReturn` refusedWith 400 "bad_request"
|
||||
forM_ malformedTerms $ \t -> register ctx code aliceOrder {oTerms = t} `shouldReturn` refusedWith 400 "bad_request"
|
||||
forM_ ["[]", "{"] $ \body -> post ctx "/api/name/register" body `shouldReturn` (400, errorOnly "bad_request")
|
||||
-- the formats and the length come before the code
|
||||
forM_ [5, 64] $ \len -> postRegister ctx (KM.insert "code" "not a code" $ with "length" (J.Number len)) `shouldReturn` refusedWith 400 "invalid_name"
|
||||
@@ -1374,12 +1563,12 @@ testViewFields = withServiceStore $ \st -> withFakeEthNode $ \node -> do
|
||||
sort (KM.keys v)
|
||||
`shouldBe` sort
|
||||
[ "id", "version", "moves", "linksRefused", "phase", "labelHash", "label", "owner", "commitment", "sealed", "resolver", "sponsor", "chainId", "tld",
|
||||
"years", "duration", "price", "fromBalance", "balance", "latePayment", "commitTx", "registerTx", "revealAfter", "revealBefore", "intentNonce", "unread", "expiresAt", "error", "community"
|
||||
"years", "duration", "price", "fromBalance", "balance", "latePayment", "commitTx", "registerTx", "revealAfter", "revealBefore", "intentNonce", "unread", "expiresAt", "error", "community", "terms"
|
||||
]
|
||||
field "latePayment" v `shouldBe` Just J.Null
|
||||
let waiting w = field "latePayment" $ objectOf $ viewJSON (testNamesConfig node) r Nothing (Just w) ViewReads {vrIntentNonce = Nothing, vrUnread = []}
|
||||
map waiting [LWConfirming, LWCrediting, LWSupport] `shouldBe` map (\t -> Just $ J.object ["waiting" .= (t :: Text)]) ["confirming", "crediting", "support"]
|
||||
map (`field` v) ["id", "phase", "owner", "tld", "chainId", "linksRefused", "label", "unread", "sponsor", "fromBalance", "balance", "community"]
|
||||
map (`field` v) ["id", "phase", "owner", "tld", "chainId", "linksRefused", "label", "unread", "sponsor", "fromBalance", "balance", "community", "terms"]
|
||||
`shouldBe` map
|
||||
Just
|
||||
[ "r1",
|
||||
@@ -1393,7 +1582,8 @@ testViewFields = withServiceStore $ \st -> withFakeEthNode $ \node -> do
|
||||
J.String $ safeDecodeUtf8 $ strEncode fakeSponsor,
|
||||
J.Number 0,
|
||||
J.Null,
|
||||
J.Null
|
||||
J.Null,
|
||||
J.String termsVersion
|
||||
]
|
||||
|
||||
testViewCommunity :: IO ()
|
||||
@@ -1407,6 +1597,15 @@ testViewCommunity = withServiceStore $ \st -> withFakeEthNode $ \node -> do
|
||||
let LabelHash bobHash = labelHash "bobsbakery"
|
||||
listing [(bobHash, "bakers of Porto")] `shouldBe` Just J.Null
|
||||
|
||||
testViewTerms :: IO ()
|
||||
testViewTerms = withServiceStore $ \st -> withFakeEthNode $ \node -> do
|
||||
Right () <- placePaid st "r1" ownerA (order "alicebakery" 1) {ofAgreedTerms = "2026-10-23/community"} (addUTCTime 3600 t0)
|
||||
r <- withTransaction st $ \db -> fromJust <$> getRegistration db (RegistrationId "r1")
|
||||
let terms :: NameRegistration -> Maybe J.Value
|
||||
terms r' = field "terms" $ objectOf $ viewJSON (testNamesConfig node) r' Nothing Nothing ViewReads {vrIntentNonce = Nothing, vrUnread = []}
|
||||
terms r `shouldBe` Just "2026-10-23/community"
|
||||
terms r {nrAgreedTerms = ""} `shouldBe` Just J.Null
|
||||
|
||||
testViewReads :: IO ()
|
||||
testViewReads = withServiceStore $ \st -> withFakeEthNode $ \node -> do
|
||||
g <- C.newRandom
|
||||
|
||||
@@ -28,6 +28,7 @@ module Bots.StoreService.NamesOwnerTests
|
||||
)
|
||||
where
|
||||
|
||||
import Bots.StoreService.ConfigTests (termsVersion)
|
||||
import Bots.StoreService.FakeEthNode
|
||||
import Bots.StoreService.NamesContractsTests (registrarOf, unhex)
|
||||
import Bots.StoreService.NamesOrdersTests
|
||||
@@ -88,6 +89,11 @@ namesOwnerTests = describe "StoreService names: owner" $ do
|
||||
it "refuses a move from registered, queued, taken, and committed without a refused reveal" testMoveRefusedPhases
|
||||
it "moves a failed order, a lapsed one, and a committed one whose links were refused, to the same name with other links too" testMoveAccepted
|
||||
it "answers a body equal to the current fields with the view unchanged, counting no move, whatever its timestamp" testMoveRepeat
|
||||
it "answers a repeat after the terms version changed with the view unchanged, counting no second move" testMoveRepeatAfterBump
|
||||
it "moves an order by a body differing only in terms, storing them" testMoveTermsOnly
|
||||
it "answers terms_changed for an old version or the wrong variant, listed or not, a body differing only in terms included, and moves under the community terms, storing them" testMoveTermsChanged
|
||||
it "checks the terms after the timestamp, /retry's first check, the existing orders and the duration, before the chain" testMoveTermsCheckOrder
|
||||
it "answers move_limit before checking the terms" testMoveLimitBeforeTerms
|
||||
it "answers the fourth move move_limit with the current view, changing nothing" testMoveLimit
|
||||
it "refuses a move meeting another live order of the wallet's or the commitment with a bare order_exists, before the price" testMoveMeetsOrder
|
||||
it "runs the order checks on the new fields: invalid_name, the duration, name_taken, name_check_unavailable" testMoveOrderChecks
|
||||
@@ -113,15 +119,18 @@ withOwner :: (Ctx -> IO a) -> IO a
|
||||
withOwner = withOwnerAs id
|
||||
|
||||
withOwnerAs :: (NamesConfig -> NamesConfig) -> (Ctx -> IO a) -> IO a
|
||||
withOwnerAs change action = withOrders $ \ctx@Ctx {cOrders, cWeb} -> do
|
||||
let orders = cOrders {oeConfig = change (oeConfig cOrders)}
|
||||
web = cWeb {weOrders = Just orders}
|
||||
routes path = ownerRoutes orders path <|> codeRoutes orders (weProviders web) (weWaiters web) path
|
||||
app req respond = fromMaybe (webApp web req respond) (namesApp (weHttp web) routes req respond)
|
||||
ctx' = ctx {cOrders = orders, cWeb = web}
|
||||
withOwnerAs change action = withOrders $ \ctx -> do
|
||||
let ctx' = configured change ctx
|
||||
forM_ ["alicebakery", "dynamis"] $ answerUnowned ctx'
|
||||
serveOwner ctx' action
|
||||
|
||||
-- | The owner routes over the context's settings.
|
||||
serveOwner :: Ctx -> (Ctx -> IO a) -> IO a
|
||||
serveOwner ctx@Ctx {cOrders = orders, cWeb = web} action = do
|
||||
let routes path = ownerRoutes orders path <|> codeRoutes orders (weProviders web) (weWaiters web) path
|
||||
app req respond = fromMaybe (webApp web req respond) (namesApp (weHttp web) routes req respond)
|
||||
mgr <- newManager defaultManagerSettings
|
||||
Warp.testWithApplication (pure app) $ \port -> action ctx' {cClient = (mgr, "http://127.0.0.1:" <> show port)}
|
||||
Warp.testWithApplication (pure app) $ \port -> action ctx {cClient = (mgr, "http://127.0.0.1:" <> show port)}
|
||||
|
||||
ownerRoutes :: OrdersEnv -> [Text] -> Maybe Route
|
||||
ownerRoutes orders = \case
|
||||
@@ -238,13 +247,13 @@ linksRefusedPhase r = (committedPhase r) {nrLinksRefusedAt = Just orderTime}
|
||||
moveTo :: Ctx -> Text -> Int -> IO OrderFields
|
||||
moveTo Ctx {cClock} label n = do
|
||||
t <- readIORef cClock
|
||||
pure OrderFields {ofLabelHash = labelHash label, ofLength = T.length label, ofDuration = yearsDuration 2 t, ofCommitment = commitmentOf n, ofSealed = "sealed-" <> label <> "-" <> tshow n}
|
||||
pure OrderFields {ofLabelHash = labelHash label, ofLength = T.length label, ofDuration = yearsDuration 2 t, ofCommitment = commitmentOf n, ofSealed = "sealed-" <> label <> "-" <> tshow n, ofAgreedTerms = termsVersion}
|
||||
|
||||
moveBody :: Ctx -> Secp256k1PrivateKey -> RegistrationId -> OrderFields -> IO J.Object
|
||||
moveBody ctx key rid fields = clockSeconds ctx >>= moveBodyAt ctx key rid fields
|
||||
|
||||
moveBodyAt :: Ctx -> Secp256k1PrivateKey -> RegistrationId -> OrderFields -> Word64 -> IO J.Object
|
||||
moveBodyAt ctx key rid fields@OrderFields {ofLabelHash = LabelHash lh, ofLength, ofDuration, ofCommitment, ofSealed} timestamp = do
|
||||
moveBodyAt ctx key rid fields@OrderFields {ofLabelHash = LabelHash lh, ofLength, ofDuration, ofCommitment, ofSealed, ofAgreedTerms} timestamp = do
|
||||
sig <- signWith ctx key $ retargetMessage rid fields timestamp
|
||||
pure $
|
||||
KM.fromList
|
||||
@@ -253,6 +262,7 @@ moveBodyAt ctx key rid fields@OrderFields {ofLabelHash = LabelHash lh, ofLength,
|
||||
("duration", J.toJSON ofDuration),
|
||||
("commitment", J.String $ hex ofCommitment),
|
||||
("sealed", J.String ofSealed),
|
||||
("terms", J.String ofAgreedTerms),
|
||||
("timestamp", J.toJSON timestamp),
|
||||
("signature", J.String sig)
|
||||
]
|
||||
@@ -285,8 +295,8 @@ postFind :: Ctx -> J.Object -> IO (Int, Maybe J.Object)
|
||||
postFind ctx = post ctx "/api/registration/find" . J.encode
|
||||
|
||||
currentFields :: NameRegistration -> OrderFields
|
||||
currentFields NameRegistration {nrLabelHash, nrLength, nrDuration, nrCommitment, nrSealed} =
|
||||
OrderFields {ofLabelHash = nrLabelHash, ofLength = nrLength, ofDuration = nrDuration, ofCommitment = nrCommitment, ofSealed = nrSealed}
|
||||
currentFields NameRegistration {nrLabelHash, nrLength, nrDuration, nrCommitment, nrSealed, nrAgreedTerms} =
|
||||
OrderFields {ofLabelHash = nrLabelHash, ofLength = nrLength, ofDuration = nrDuration, ofCommitment = nrCommitment, ofSealed = nrSealed, ofAgreedTerms = nrAgreedTerms}
|
||||
|
||||
fieldsIn :: J.Object -> [(Text, J.Value)] -> Expectation
|
||||
fieldsIn v = mapM_ (\(k, value) -> (k, field k v) `shouldBe` (k, Just value))
|
||||
@@ -459,6 +469,75 @@ testMoveRepeat = withOwner $ \ctx -> do
|
||||
stored ctx r `shouldReturn` movedOnce
|
||||
nrMoves movedOnce `shouldBe` 1
|
||||
|
||||
testMoveRepeatAfterBump :: IO ()
|
||||
testMoveRepeatAfterBump = withOwner $ \ctx0 -> do
|
||||
answerFree ctx0 "alicebakers"
|
||||
r <- paidIn ctx0 aliceOrder failedPhase
|
||||
body <- moveBody ctx0 keyA (nrId r) =<< moveTo ctx0 "alicebakers" 10
|
||||
first' <- postMove ctx0 (nrId r) body
|
||||
fst first' `shouldBe` 200
|
||||
movedOnce <- stored ctx0 r
|
||||
serveOwner (configured bumpedTerms ctx0) $ \ctx -> do
|
||||
advance ctx 60
|
||||
postMove ctx (nrId r) body `shouldReturn` first'
|
||||
stored ctx r `shouldReturn` movedOnce
|
||||
(nrMoves &&& nrAgreedTerms) movedOnce `shouldBe` (1, termsVersion)
|
||||
|
||||
testMoveTermsOnly :: IO ()
|
||||
testMoveTermsOnly = withOwner $ \ctx -> do
|
||||
r <- paidIn ctx aliceOrder $ \p -> (failedPhase p) {nrAgreedTerms = "2026-10-01"}
|
||||
(status, v) <- move ctx keyA r (currentFields r) {ofAgreedTerms = termsVersion}
|
||||
(status, field "phase" =<< v, field "moves" =<< v) `shouldBe` (200, Just "queued", Just (J.Number 1))
|
||||
(nrAgreedTerms &&& nrMoves) <$> stored ctx r `shouldReturn` (termsVersion, 1)
|
||||
|
||||
testMoveTermsChanged :: IO ()
|
||||
testMoveTermsChanged = withOwnerAs (listName "alicebakers") $ \ctx -> do
|
||||
answerFree ctx "alicebakers"
|
||||
r <- paidIn ctx aliceOrder failedPhase
|
||||
forM_ [olderTerms, communityTerms termsVersion] $ \t ->
|
||||
move ctx keyA r (currentFields r) {ofCommitment = commitmentOf 11, ofAgreedTerms = t} `shouldReturn` termsChanged termsVersion Nothing
|
||||
move ctx keyA r (currentFields r) {ofAgreedTerms = olderTerms} `shouldReturn` termsChanged termsVersion Nothing
|
||||
to <- moveTo ctx "alicebakers" 10
|
||||
forM_ [termsVersion, communityTerms olderTerms] $ \t ->
|
||||
move ctx keyA r to {ofAgreedTerms = t} `shouldReturn` termsChanged termsVersion (Just bakers)
|
||||
stored ctx r `shouldReturn` r
|
||||
v <- moved ctx keyA r to {ofAgreedTerms = communityTerms termsVersion}
|
||||
fieldsIn v [("terms", J.String $ communityTerms termsVersion), ("community", J.object [("for", J.String bakers)])]
|
||||
nrAgreedTerms <$> stored ctx r `shouldReturn` communityTerms termsVersion
|
||||
|
||||
testMoveTermsCheckOrder :: IO ()
|
||||
testMoveTermsCheckOrder = withOwner $ \ctx@Ctx {cNode} -> do
|
||||
answerFree ctx "alicebakers"
|
||||
r <- paidIn ctx aliceOrder failedPhase
|
||||
to <- (\f -> f {ofAgreedTerms = olderTerms}) <$> moveTo ctx "alicebakers" 10
|
||||
ts <- clockSeconds ctx
|
||||
(moveBodyAt ctx keyA (nrId r) to (ts - signedWindow - 1) >>= postMove ctx (nrId r)) `shouldReturn` refusedWith 400 "bad_request"
|
||||
setFault cNode "eth_call" HttpFailure
|
||||
move ctx keyA r to `shouldReturn` refusedWith 503 "name_check_unavailable"
|
||||
clearFault cNode "eth_call"
|
||||
void $ placed ctx dynamisOrder
|
||||
toDynamis <- moveTo ctx "dynamis" 10
|
||||
move ctx keyA r toDynamis {ofAgreedTerms = olderTerms} `shouldReturn` refusedWith 409 "order_exists"
|
||||
move ctx keyA r to {ofDuration = ofDuration to + 3601} `shouldReturn` refusedWith 400 "bad_request"
|
||||
answerReserved ctx "alicebakers" 1
|
||||
move ctx keyA r to `shouldReturn` termsChanged termsVersion Nothing
|
||||
stored ctx r `shouldReturn` r
|
||||
answerExpiry ctx "alicebakery" (seconds orderTime + 2 * 31536000)
|
||||
answerOwner ctx "alicebakery" ownerA
|
||||
answer <- move ctx keyA r to
|
||||
view <- getView ctx r
|
||||
answer `shouldBe` refusedWithView "registration_changed" view
|
||||
field "phase" view `shouldBe` Just "registered"
|
||||
|
||||
testMoveLimitBeforeTerms :: IO ()
|
||||
testMoveLimitBeforeTerms = withOwner $ \ctx -> do
|
||||
answerFree ctx "alicebakers"
|
||||
r <- paidIn ctx aliceOrder $ \p -> (failedPhase p) {nrMoves = 3}
|
||||
to <- moveTo ctx "alicebakers" 10
|
||||
view <- getView ctx r
|
||||
move ctx keyA r to {ofAgreedTerms = olderTerms} `shouldReturn` refusedWithView "move_limit" view
|
||||
stored ctx r `shouldReturn` r
|
||||
|
||||
testMoveLimit :: IO ()
|
||||
testMoveLimit = withOwner $ \ctx -> do
|
||||
answerFree ctx "alicebakers"
|
||||
@@ -603,7 +682,7 @@ testMoveKeepsFromBalance = withOwner $ \ctx@Ctx {cStore} -> do
|
||||
answerFree ctx "alicebakers"
|
||||
paying <- paidIn ctx (byB aliceOrder) failedPhase
|
||||
withTransaction cStore $ \db -> creditBalance db (nrId paying) 5000 orderTime
|
||||
let fields = OrderFields {ofLabelHash = labelHash "dynamis", ofLength = 7, ofDuration = yearsDuration 2 orderTime, ofCommitment = commitmentOf 3, ofSealed = "sealed-dynamis-3"}
|
||||
let fields = OrderFields {ofLabelHash = labelHash "dynamis", ofLength = 7, ofDuration = yearsDuration 2 orderTime, ofCommitment = commitmentOf 3, ofSealed = "sealed-dynamis-3", ofAgreedTerms = termsVersion}
|
||||
new = NewRegistration {nrgId = RegistrationId "diff", nrgOwner = ownerA, nrgOrder = fields, nrgYears = 2}
|
||||
withTransaction cStore $ \db -> do
|
||||
insertInvoiceRow db "inv-diff" (addUTCTime 3600 orderTime) "open"
|
||||
@@ -667,8 +746,9 @@ testMoveSizes = withOwner $ \ctx -> do
|
||||
postMove ctx (nrId r) (KM.insert "owner" (J.String $ T.replicate 5300 "0") body) `shouldReturn` refusedWith 400 "bad_request"
|
||||
move ctx keyA r to {ofSealed = T.replicate 11096 "s"} `shouldReturn` refusedWith 400 "bad_request"
|
||||
valid <- moveBody ctx keyA (nrId r) to
|
||||
forM_ [KM.insert "labelHash" (J.String $ T.toUpper $ hex $ (\(LabelHash h) -> h) $ ofLabelHash to) valid, KM.delete "signature" valid, KM.insert "length" "11" valid] $ \malformed ->
|
||||
forM_ [KM.insert "labelHash" (J.String $ T.toUpper $ hex $ (\(LabelHash h) -> h) $ ofLabelHash to) valid, KM.delete "signature" valid, KM.insert "length" "11" valid, KM.delete "terms" valid] $ \malformed ->
|
||||
postMove ctx (nrId r) malformed `shouldReturn` refusedWith 400 "bad_request"
|
||||
forM_ malformedTerms $ \t -> move ctx keyA r to {ofAgreedTerms = t} `shouldReturn` refusedWith 400 "bad_request"
|
||||
post ctx (registrationPath (nrId r) <> "/name") "[]" `shouldReturn` refusedWith 400 "bad_request"
|
||||
stored ctx r `shouldReturn` r
|
||||
-- an owner in the body is ignored
|
||||
|
||||
@@ -36,30 +36,49 @@ namesSignatureTests = describe "StoreService names: signatures" $ do
|
||||
it "hashes ClearRecords" $
|
||||
clearRecordsDigest (resolverDomain chainId resolver) (namehash TLDSimplex "dynamis") 4 99 `shouldBe` hx "0xca4bd243288f27f38e3b45384ba36ce685ff155352cf8125f031e6fb189a46dd"
|
||||
describe "EIP-191 messages" $ do
|
||||
it "signs an order" $
|
||||
-- the contract's Appendix C, which the webapp computed with viem and pins in test/terms-vectors.test.ts
|
||||
it "signs an order with the terms version" $
|
||||
testMessage
|
||||
(orderMessage dynamisOrder timestamp)
|
||||
"simplex.domains order 0x78b602f03f164366531da963764c1f2fdfd588d0487daf2aa261ca799e5ffe33 7 69259500 0x9cf04ddef2eedfb02e6e7ba58f879c0636c584b6acc67ffe9f97a06bfb016ac1 0xb1971beb567c8dc1b2f01f0d823754c6168d8d6830db2221702a7678e1804674 1792574100"
|
||||
"0x5deee1b3589df9e53665e34aa65a491a4eabfd76a39207b0e9303457f7c44b7a"
|
||||
"0x73e32be461e99e64b093a4ad09b04b4d810e5623a1b0e9c9fdb4701ec2a6a2a84df9ffdccc39c5cb827cde4d846c7662f591665f1b868ab1c15778646d3f414e1b"
|
||||
(orderMessage termsOrder termsTimestamp)
|
||||
"simplex.domains order 0xbcc46b7948ff6be55bc3ff4db5bc4be16638f29e818a89244dae11caaed7c9c6 11 69292800 0x5e62a4cb7da596cb38169a6a552b5f69db2acee279b53be6693a78e03c3dfaa5 0x22709445157a2a1f7cb7e284e3ccf6c7ebc3b4d857002af452853c4a65907fe2 2026-10-23 1792828800"
|
||||
"0x50dfb031e558f78b83fa07c7ea0207c02a98d73751e43bc754dd26b7bc92b840"
|
||||
"0x17107b11494e25098efc348aca64a2469ffb832bcc79dc57377a1b26a4004b6701ad73648f50af8b39d4079820a3de7e681ddf15f8cf15b5cff02b4a48cf1fe61c"
|
||||
it "signs an order with the community terms" $
|
||||
testMessage
|
||||
(orderMessage communityOrder termsTimestamp)
|
||||
"simplex.domains order 0xbcc46b7948ff6be55bc3ff4db5bc4be16638f29e818a89244dae11caaed7c9c6 11 69292800 0x5e62a4cb7da596cb38169a6a552b5f69db2acee279b53be6693a78e03c3dfaa5 0x22709445157a2a1f7cb7e284e3ccf6c7ebc3b4d857002af452853c4a65907fe2 2026-10-23/community 1792828800"
|
||||
"0xf8521525761939c4cef8979cb54217e9e32b1a57999fc2f03e486f4eb1903802"
|
||||
"0x03eccb591b79ab4e3e6f22ccbeb77a6ac32c6dad8cb318557836258c390bc31d78852a3279c6c8cc2ef8d1025641d45ba4101f54dfd84c264deb2ab391c1cbc61c"
|
||||
it "signs find with the owner in lowercase" $
|
||||
testMessage
|
||||
(findMessage owner timestamp)
|
||||
"simplex.domains find 0x014f9c09cceedef1b713110d04d3a07d5b5d9b73 1792574100"
|
||||
"0x08a989fbf0457984c062b44d7237be9c7948f2cf23d48410609777a09b515646"
|
||||
"0xfa0908260c3f21c8e47bd37e2c3cf3bd6bc62966591ab1a2c4e31695646548f47d2e79b34413be27b4b07330682de642f48a8f5e641449d7d79728eeb4ab14da1c"
|
||||
it "signs another name for an order, with its duration" $
|
||||
it "signs another name for an order with the terms version" $
|
||||
testMessage
|
||||
(retargetMessage registrationId dynamisOrder {ofLabelHash = labelHash "another"} timestamp)
|
||||
"simplex.domains name t2Jk8RmQ4vXw9NcP3yLb6g 0x5bfbbf75311ec002834031d73fa30bfe8bdf675f4a3df72443841490c4b49d02 7 69259500 0x9cf04ddef2eedfb02e6e7ba58f879c0636c584b6acc67ffe9f97a06bfb016ac1 0xb1971beb567c8dc1b2f01f0d823754c6168d8d6830db2221702a7678e1804674 1792574100"
|
||||
"0x8bc79aa98fbd53013e8961db27554ecd17139e14ec168b86afbaf2fc910bfc52"
|
||||
"0xe3d680bcc62255179d5260beeb920319c86bd919f6b01927bee01509cf6c1fe3121151947fb9e3a310e6652c0c9a9bf7ceb48e8d903774a38a3162d916e8b4591b"
|
||||
it "signs a spend from an order's balance, as the webapp signs it" $
|
||||
(retargetMessage registrationId termsOrder termsTimestamp)
|
||||
"simplex.domains name t2Jk8RmQ4vXw9NcP3yLb6g 0xbcc46b7948ff6be55bc3ff4db5bc4be16638f29e818a89244dae11caaed7c9c6 11 69292800 0x5e62a4cb7da596cb38169a6a552b5f69db2acee279b53be6693a78e03c3dfaa5 0x22709445157a2a1f7cb7e284e3ccf6c7ebc3b4d857002af452853c4a65907fe2 2026-10-23 1792828800"
|
||||
"0x01eda78f875428396a940b658b910b6eb6dc0bce82860c17d59f8f16e7767d25"
|
||||
"0x1d29abf2489da963d59d0982074b5af770efbaf96be3c756afbd6a7fea672b507e756944da0901724e2a5d7cfe2419ccb7573310ae65e65f4fd35d7c6fe494b51c"
|
||||
it "signs another name for an order with the community terms" $
|
||||
testMessage
|
||||
(spendMessage registrationId spendOrder timestamp)
|
||||
"simplex.domains spend t2Jk8RmQ4vXw9NcP3yLb6g 0x5bfbbf75311ec002834031d73fa30bfe8bdf675f4a3df72443841490c4b49d02 7 69259500 0xbb87d2d7aa14251a04cdd68b5d878d0b4c44c6c76486d90a534dab9525105e33 0x51431a705eb4903084cc8dbf3c1b966c9372914511c4623c889d49fdb8047da4 1792574100"
|
||||
"0x72c2f4b7d84839fb97eb78668355a02fc0b18e211f264fca97d19a8f36decde3"
|
||||
"0x8668cb4b72295479b4f9bcc2fd07fabfec2b4b8ae9230f2553536acb93c3e0cf6b2dad928a9a11b003c43ab43edeec117ce01c9214b8e99fe75fd547425e74481b"
|
||||
(retargetMessage registrationId communityOrder termsTimestamp)
|
||||
"simplex.domains name t2Jk8RmQ4vXw9NcP3yLb6g 0xbcc46b7948ff6be55bc3ff4db5bc4be16638f29e818a89244dae11caaed7c9c6 11 69292800 0x5e62a4cb7da596cb38169a6a552b5f69db2acee279b53be6693a78e03c3dfaa5 0x22709445157a2a1f7cb7e284e3ccf6c7ebc3b4d857002af452853c4a65907fe2 2026-10-23/community 1792828800"
|
||||
"0x4f1af02904f9f8863e92169f6e1a1d6733a3a25c5d22ffde7ac00f09a660c022"
|
||||
"0x30d027224b85cd9ac638edec1266748f21f46279eda72e68448f97b8fce73ca06c401035ad5416fc1e48f39646d0637fcaad1588ec74562ff842821b33e299361b"
|
||||
it "signs a spend from an order's balance with the terms version" $
|
||||
testMessage
|
||||
(spendMessage registrationId termsOrder termsTimestamp)
|
||||
"simplex.domains spend t2Jk8RmQ4vXw9NcP3yLb6g 0xbcc46b7948ff6be55bc3ff4db5bc4be16638f29e818a89244dae11caaed7c9c6 11 69292800 0x5e62a4cb7da596cb38169a6a552b5f69db2acee279b53be6693a78e03c3dfaa5 0x22709445157a2a1f7cb7e284e3ccf6c7ebc3b4d857002af452853c4a65907fe2 2026-10-23 1792828800"
|
||||
"0x109f0bd4f5eb1aa054f17c82a0b04dbd5d1e7b23c5ee91cf69464fb1435eb034"
|
||||
"0x20e930097b35350861332afa4b0b5dcff746aa879875269cc784575e6bb871711d3f6b1e11437d0a616a37a8b5b1ebbdd4c98aee04e09405ac3fa55a6af6ff831b"
|
||||
it "signs a spend from an order's balance with the community terms" $
|
||||
testMessage
|
||||
(spendMessage registrationId communityOrder termsTimestamp)
|
||||
"simplex.domains spend t2Jk8RmQ4vXw9NcP3yLb6g 0xbcc46b7948ff6be55bc3ff4db5bc4be16638f29e818a89244dae11caaed7c9c6 11 69292800 0x5e62a4cb7da596cb38169a6a552b5f69db2acee279b53be6693a78e03c3dfaa5 0x22709445157a2a1f7cb7e284e3ccf6c7ebc3b4d857002af452853c4a65907fe2 2026-10-23/community 1792828800"
|
||||
"0xd114398466a7a6d7d9a183feb4624e06c41d1dcdfb6b69e896ff9d74c70845c3"
|
||||
"0x90d2ab549b2cf5fd51442ac3f410b934e7fa45bd12853cfbfa2f8ab4876ed5600b9fe3a90459140f180949353e7dc3f56cd1447de31ae5c05e12f7bf6a113f061c"
|
||||
describe "signature format" $ do
|
||||
it "refuses a high s, though recovery accepts it" testHighS
|
||||
it "refuses v other than 27 or 28" $
|
||||
@@ -112,10 +131,11 @@ testHighS :: IO ()
|
||||
testHighS = do
|
||||
parseSignature highS `shouldBe` Left SEHighS
|
||||
let (rsR, (rsS, v)) = B.splitAt 32 <$> B.splitAt 32 (hx highS)
|
||||
recoverAddress RecoverableSignature {rsR, rsS, rsRecId = B.head v - 27} (personalDigest $ orderMessage dynamisOrder timestamp)
|
||||
recoverAddress RecoverableSignature {rsR, rsS, rsRecId = B.head v - 27} (personalDigest $ orderMessage termsOrder termsTimestamp)
|
||||
`shouldReturn` Right owner
|
||||
where
|
||||
highS = "0x73e32be461e99e64b093a4ad09b04b4d810e5623a1b0e9c9fdb4701ec2a6a2a8b206002333c63a347d8321b27b93899bc51d768793c21589fe7ae62862f6fff31c"
|
||||
-- the order vector's signature with s replaced by n - s and v flipped
|
||||
highS = "0x17107b11494e25098efc348aca64a2469ffb832bcc79dc57377a1b26a4004b67fe528c9b70af5074c62bf867df5c21805290fdd0b6798a85efe233428767215b1b"
|
||||
|
||||
-- fixtures
|
||||
|
||||
@@ -132,26 +152,20 @@ dynamis =
|
||||
rChannelLink = Nothing
|
||||
}
|
||||
|
||||
dynamisOrder :: OrderFields
|
||||
dynamisOrder =
|
||||
-- Appendix C's derived inputs: alicebakery with no links, its commitment as the webapp builds it, and a new seal under the fixture seed and a zero IV
|
||||
termsOrder :: OrderFields
|
||||
termsOrder =
|
||||
OrderFields
|
||||
{ ofLabelHash = labelHash "dynamis",
|
||||
ofLength = 7,
|
||||
ofDuration = duration,
|
||||
ofCommitment = commitment,
|
||||
ofSealed = "q3Zk0Yx7c2VhbGVkLW9yZGVyLWZpeHR1cmU"
|
||||
{ ofLabelHash = labelHash "alicebakery",
|
||||
ofLength = 11,
|
||||
ofDuration = 69292800,
|
||||
ofCommitment = hx "0x5e62a4cb7da596cb38169a6a552b5f69db2acee279b53be6693a78e03c3dfaa5",
|
||||
ofSealed = "AAAAAAAAAAAAAAAACWgxqMk-UKfpra_Zh6vc4KNBR6SX1WYpGb4COoWCCbM0bisYCH14WLzghp8hqi_-KyXSi4qf_DAdP_M4bFetD0s",
|
||||
ofAgreedTerms = "2026-10-23"
|
||||
}
|
||||
|
||||
-- the webapp's spend vector (test/flow.test.ts, SPEND): "another" with no links, sealed under a zero IV
|
||||
spendOrder :: OrderFields
|
||||
spendOrder =
|
||||
OrderFields
|
||||
{ ofLabelHash = labelHash "another",
|
||||
ofLength = 7,
|
||||
ofDuration = duration,
|
||||
ofCommitment = hx "0xbb87d2d7aa14251a04cdd68b5d878d0b4c44c6c76486d90a534dab9525105e33",
|
||||
ofSealed = "AAAAAAAAAAAAAAAACWgxqMk-UKfpra_bgbzR57AIDvSNmCR_G7IYbN7DX70sL2FVRHB1VfC0wdF-tc3ajHM3o8koM159Ja8hyg"
|
||||
}
|
||||
communityOrder :: OrderFields
|
||||
communityOrder = termsOrder {ofAgreedTerms = "2026-10-23/community"}
|
||||
|
||||
commitment :: ByteString
|
||||
commitment = hx "0x9cf04ddef2eedfb02e6e7ba58f879c0636c584b6acc67ffe9f97a06bfb016ac1"
|
||||
@@ -163,6 +177,10 @@ node = hx "0x833cc73a7eae1ddee67ec8845ec3d39799406c7bc87fab7c504a7e0ab5cb89bb"
|
||||
timestamp :: Word64
|
||||
timestamp = 1792574100
|
||||
|
||||
-- 24 October 2026 08:00 UTC
|
||||
termsTimestamp :: Word64
|
||||
termsTimestamp = 1792828800
|
||||
|
||||
-- 2 years of 365 days and the free days until 1 January 2027
|
||||
duration :: Word64
|
||||
duration = 69259500
|
||||
@@ -171,7 +189,7 @@ registrationId :: RegistrationId
|
||||
registrationId = RegistrationId "t2Jk8RmQ4vXw9NcP3yLb6g"
|
||||
|
||||
orderSignature :: Text
|
||||
orderSignature = "0x73e32be461e99e64b093a4ad09b04b4d810e5623a1b0e9c9fdb4701ec2a6a2a84df9ffdccc39c5cb827cde4d846c7662f591665f1b868ab1c15778646d3f414e1b"
|
||||
orderSignature = "0x17107b11494e25098efc348aca64a2469ffb832bcc79dc57377a1b26a4004b6701ad73648f50af8b39d4079820a3de7e681ddf15f8cf15b5cff02b4a48cf1fe61c"
|
||||
|
||||
retString :: ByteString
|
||||
retString = hx "0000000000000000000000000000000000000000000000000000000000000020000000000000000000000000000000000000000000000000000000000000002168747470733a2f2f736d70382e73696d706c65782e696d2f6123636f6e7461637400000000000000000000000000000000000000000000000000000000000000"
|
||||
|
||||
@@ -9,7 +9,8 @@ import Bots.StoreService.BotTests (operatorCmd, withStoreService)
|
||||
import Bots.StoreService.FakeBTCPay (FakeBTCPay (..), setInvoiceState, setRates, webhookEvent, webhookSigHeader, withFakeBTCPay)
|
||||
import Bots.StoreService.FakeEthNode
|
||||
import Bots.StoreService.NamesContractsTests (reservedNamesCall)
|
||||
import Bots.StoreService.NamesOrdersTests (Ctx (..), Order (..), advance, aliceOrder, commitmentOf, field, fieldsOf, invoiceRegistration, keyA, keyB, orderTime, ownerAText, placeOrder, placed, post, refusedWith, registrationById, registrationOf, registrationsOf, settleNow, withOrdersOn, yearsDuration)
|
||||
import Bots.StoreService.ConfigTests (termsVersion)
|
||||
import Bots.StoreService.NamesOrdersTests (Ctx (..), Order (..), advance, aliceOrder, bakers, bumpedTerms, commitmentOf, communityTerms, configured, field, fieldsOf, invoiceRegistration, keyA, keyB, listName, malformedTerms, olderTerms, orderTime, ownerAText, placeOrder, placed, post, refusedWith, registrationById, registrationOf, registrationsOf, settleNow, termsChanged, withOrdersOn, yearsDuration)
|
||||
import Bots.StoreService.NamesOwnerTests (findBody, postFind)
|
||||
import Bots.StoreService.NamesStoreTests (at, order, ownerA, placePaid, reg, t0, write)
|
||||
import Bots.StoreService.WebTests (StubCall (..), capturingStderr, StubState (..), jsonObject, rcv, sampleProviderInvoice, statusOf, stubCalls, webGet, webRequestBody, withServiceStores)
|
||||
@@ -17,7 +18,7 @@ import ChatTests.DBUtils (TestParams)
|
||||
import Control.Concurrent.Async (Async, async, cancel, concurrently, wait)
|
||||
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
|
||||
import Control.Concurrent.STM (atomically, check)
|
||||
import Control.Monad (join, replicateM_, void)
|
||||
import Control.Monad (forM_, join, replicateM_, void)
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
import qualified Data.Aeson.Types as JT
|
||||
@@ -83,6 +84,10 @@ namesSpendTests = describe "StoreService names: spend" $ do
|
||||
it "refuses a card difference below the card minimum after the price check, accepting it by crypto and at the minimum" testCardMinimum
|
||||
it "refuses sealed missing or over 11095 characters and a body over 16384 bytes, accepting the longest" testSpendSizes
|
||||
it "counts spends against the create limit" testSpendLimit
|
||||
describe "terms" $ do
|
||||
it "answers terms_changed for an old version or the wrong variant, listed or not, and stores the community terms, covered and by difference" testSpendTermsChanged
|
||||
it "answers an exact resend after the version changed, covered and by difference" testSpendResendAfterBump
|
||||
it "checks the terms after the timestamp and the duration, before the balance and the chain" testSpendTermsCheckOrder
|
||||
describe "holders" $ do
|
||||
it "closes the balance's overdue unfunded holder in the spend's transaction, publishing it and cancelling its invoice" testOverdueHolderSpent
|
||||
it "closes an overdue unfunded holder of another name for a difference spend, the new invoice holding the balance" testDifferenceClosesHolder
|
||||
@@ -108,20 +113,22 @@ withSpendHook action = do
|
||||
hook <- newIORef (pure ())
|
||||
withServiceStores $ \open -> withSpendOn open (\p -> p {pCreateInvoice = \m d -> join (readIORef hook) >> pCreateInvoice p m d}) (action hook)
|
||||
|
||||
-- | The spend route beside find, the registration poll and the service's routes.
|
||||
withSpendOn :: IO DBStore -> (Provider -> Provider) -> (Ctx -> IO a) -> IO a
|
||||
withSpendOn open via action =
|
||||
withOrdersOn open via $ \ctx@Ctx {cOrders, cWeb} -> do
|
||||
let routes :: [Text] -> Maybe Route
|
||||
routes = \case
|
||||
["api", "registration", "find"] -> Just Route {rMethod = "POST", rLimit = Http.findLimit, rHandler = findHandler cOrders}
|
||||
["api", "registration", rid, "spend"] -> Just Route {rMethod = "POST", rLimit = createLimit, rHandler = spendHandler cOrders (weConfig cWeb) (weProviders cWeb) (weWaiters cWeb) rid}
|
||||
["api", "registration", rid] -> Just Route {rMethod = "GET", rLimit = readLimit, rHandler = registrationHandler cOrders holdMicros rid}
|
||||
_ -> Nothing
|
||||
app :: Application
|
||||
app req respond = fromMaybe (webApp cWeb req respond) (namesApp (weHttp cWeb) routes req respond)
|
||||
mgr <- newManager defaultManagerSettings
|
||||
Warp.testWithApplication (pure app) $ \port -> action ctx {cClient = (mgr, "http://127.0.0.1:" <> show port)}
|
||||
withSpendOn open via action = withOrdersOn open via (`serveSpend` action)
|
||||
|
||||
-- | The spend route beside find, the registration poll and the service's routes, over the context's settings.
|
||||
serveSpend :: Ctx -> (Ctx -> IO a) -> IO a
|
||||
serveSpend ctx@Ctx {cOrders, cWeb} action = do
|
||||
let routes :: [Text] -> Maybe Route
|
||||
routes = \case
|
||||
["api", "registration", "find"] -> Just Route {rMethod = "POST", rLimit = Http.findLimit, rHandler = findHandler cOrders}
|
||||
["api", "registration", rid, "spend"] -> Just Route {rMethod = "POST", rLimit = createLimit, rHandler = spendHandler cOrders (weConfig cWeb) (weProviders cWeb) (weWaiters cWeb) rid}
|
||||
["api", "registration", rid] -> Just Route {rMethod = "GET", rLimit = readLimit, rHandler = registrationHandler cOrders holdMicros rid}
|
||||
_ -> Nothing
|
||||
app :: Application
|
||||
app req respond = fromMaybe (webApp cWeb req respond) (namesApp (weHttp cWeb) routes req respond)
|
||||
mgr <- newManager defaultManagerSettings
|
||||
Warp.testWithApplication (pure app) $ \port -> action ctx {cClient = (mgr, "http://127.0.0.1:" <> show port)}
|
||||
|
||||
withSpend :: (Ctx -> IO a) -> IO a
|
||||
withSpend action = withSpendHook (const action)
|
||||
@@ -182,12 +189,13 @@ spendBody Ctx {cRandom} source SpendBody {sbOrder = o@Order {oKey, oPrice, oTime
|
||||
("sealed", J.String ofSealed),
|
||||
("price", J.toJSON oPrice),
|
||||
("balance", J.toJSON sbBalance),
|
||||
("terms", J.String ofAgreedTerms),
|
||||
("timestamp", J.toJSON oTimestamp),
|
||||
("signature", J.String $ hex $ serializeSignature sig)
|
||||
]
|
||||
<> maybe [] (\m -> [("method", J.String m)]) sbMethod
|
||||
where
|
||||
fields@OrderFields {ofLabelHash = LabelHash lh, ofLength, ofDuration, ofCommitment, ofSealed} = fieldsOf o
|
||||
fields@OrderFields {ofLabelHash = LabelHash lh, ofLength, ofDuration, ofCommitment, ofSealed, ofAgreedTerms} = fieldsOf o
|
||||
|
||||
postSpend :: Ctx -> RegistrationId -> J.Object -> IO (Int, Maybe J.Object)
|
||||
postSpend ctx (RegistrationId rid) = post ctx ("/api/registration/" <> T.unpack rid <> "/spend") . J.encode
|
||||
@@ -259,6 +267,7 @@ testCoveredSpend = withSpend $ \ctx -> do
|
||||
r <- registrationById ctx rid
|
||||
(nrPhase r, nrLive r, nrPrice r, nrPayment r, nrBalanceSource r, nrBalanceUsed r) `shouldBe` (PQueued, True, 10000, RPBalance, Just src, 10000)
|
||||
nrOrderHash r `shouldBe` orderHash ownerA (fieldsOf aliceOrder) (OTBalance src 10000 15000 Nothing)
|
||||
nrAgreedTerms r `shouldBe` oTerms aliceOrder
|
||||
view <- viewOf ctx rid
|
||||
(field "phase" view, field "price" view, field "fromBalance" view, field "balance" view) `shouldBe` (Just "queued", Just (J.Number 10000), Just (J.Number 10000), Just J.Null)
|
||||
amountOf ctx src `shouldReturn` Just 5000
|
||||
@@ -282,6 +291,7 @@ testDifferenceSpend = withSpend $ \ctx -> do
|
||||
holder <- invoiceRegistration ctx invId
|
||||
(nrPhase holder, nrLive holder, nrPrice holder, nrPayment holder, nrBalanceSource holder, nrBalanceUsed holder) `shouldBe` (PUnpaid, True, 10000, RPInvoice btc invId, Just src, 6000)
|
||||
nrOrderHash holder `shouldBe` orderHash ownerA (fieldsOf aliceOrder) (OTBalance src 10000 6000 (Just btc))
|
||||
nrAgreedTerms holder `shouldBe` oTerms aliceOrder
|
||||
fmap irAmount <$> getInvoice (cStore ctx) invId `shouldReturn` Just (CurrencyAmount 4000)
|
||||
field "balance" <$> viewOf ctx src `shouldReturn` Just (J.object ["amount" J..= (6000 :: Int), "held" J..= True, "heldUntil" J..= expiry, "refunded" J..= (0 :: Int)])
|
||||
|
||||
@@ -414,6 +424,50 @@ testCheckOrder = withSpend $ \ctx@Ctx {cNode = node, cStub} -> do
|
||||
spend ctx src (covered 31000) {sbOrder = aliceOrder {oCommitment = commitmentOf 3}} `shouldReturn` refusedWith 409 "order_exists"
|
||||
amountOf ctx src `shouldReturn` Just 20000
|
||||
|
||||
testSpendTermsChanged :: IO ()
|
||||
testSpendTermsChanged = withSpend $ \ctx0 -> serveSpend (configured (listName "dynamis") ctx0) $ \ctx -> do
|
||||
src <- sourceOf ctx "src" 30000
|
||||
forM_ [olderTerms, communityTerms termsVersion] $ \t ->
|
||||
spend ctx src (covered 30000) {sbOrder = aliceOrder {oTerms = t}} `shouldReturn` termsChanged termsVersion Nothing
|
||||
forM_ [termsVersion, communityTerms olderTerms] $ \t ->
|
||||
spend ctx src (dynamis 30000 Nothing) {sbOrder = dynamisOrder {oTerms = t}} `shouldReturn` termsChanged termsVersion (Just bakers)
|
||||
amountOf ctx src `shouldReturn` Just 30000
|
||||
rid <- registrationAnswer . snd <$> spend ctx src (dynamis 30000 Nothing) {sbOrder = dynamisOrder {oTerms = communityTerms termsVersion}}
|
||||
nrAgreedTerms <$> registrationById ctx rid `shouldReturn` communityTerms termsVersion
|
||||
serveSpend (configured (listName "alicebakery") ctx) $ \listing -> do
|
||||
low <- sourceOf listing "low" 4000
|
||||
(status, v) <- spend listing low (difference 4000) {sbOrder = aliceOrder {oTerms = communityTerms termsVersion}}
|
||||
status `shouldBe` 200
|
||||
nrAgreedTerms <$> invoiceRegistration listing (invoiceIdOf v) `shouldReturn` communityTerms termsVersion
|
||||
|
||||
testSpendResendAfterBump :: IO ()
|
||||
testSpendResendAfterBump = withSpend $ \ctx0 -> do
|
||||
src <- sourceOf ctx0 "src" 15000
|
||||
low <- sourceOf ctx0 "low" 5000
|
||||
coveredBody <- spendBody ctx0 src (covered 15000)
|
||||
(200, Just coveredAnswer) <- postSpend ctx0 src coveredBody
|
||||
differenceBody <- spendBody ctx0 low (dynamis 5000 (Just "btc"))
|
||||
(200, Just differenceView) <- postSpend ctx0 low differenceBody
|
||||
serveSpend (configured bumpedTerms ctx0) $ \ctx -> do
|
||||
advance ctx 60
|
||||
postSpend ctx src coveredBody `shouldReturn` (200, Just coveredAnswer)
|
||||
postSpend ctx low differenceBody `shouldReturn` (200, Just differenceView)
|
||||
mapM (fmap length . paidFrom ctx) [src, low] `shouldReturn` [1, 1]
|
||||
|
||||
testSpendTermsCheckOrder :: IO ()
|
||||
testSpendTermsCheckOrder = withSpend $ \ctx@Ctx {cNode = node} -> do
|
||||
src <- sourceOf ctx "src" 15000
|
||||
let old = aliceOrder {oTerms = olderTerms}
|
||||
spend ctx src (covered 15000) {sbOrder = old {oTimestamp = seconds orderTime + 601}} `shouldReturn` refusedWith 400 "bad_request"
|
||||
spend ctx src (covered 15000) {sbOrder = old {oDuration = oDuration old + 3601}} `shouldReturn` refusedWith 400 "bad_request"
|
||||
spend ctx src (covered 14000) {sbOrder = old} `shouldReturn` termsChanged termsVersion Nothing
|
||||
answerCall node fakeController reservedNamesCall $ Returns $ uint256 (1 :: Int)
|
||||
spend ctx src (covered 15000) {sbOrder = old {oPrice = 9000}} `shouldReturn` termsChanged termsVersion Nothing
|
||||
setFault node "eth_call" HttpFailure
|
||||
spend ctx src (covered 15000) {sbOrder = old} `shouldReturn` termsChanged termsVersion Nothing
|
||||
amountOf ctx src `shouldReturn` Just 15000
|
||||
paidFrom ctx src `shouldReturn` []
|
||||
|
||||
testCardMinimum :: IO ()
|
||||
testCardMinimum = withSpend $ \ctx -> do
|
||||
small <- sourceOf ctx "small" 9951
|
||||
@@ -432,6 +486,9 @@ testSpendSizes = withSpend $ \ctx -> do
|
||||
src <- sourceOf ctx "src" 15000
|
||||
missing <- KM.delete "sealed" <$> spendBody ctx src (covered 15000)
|
||||
postSpend ctx src missing `shouldReturn` refusedWith 400 "bad_request"
|
||||
noTerms <- KM.delete "terms" <$> spendBody ctx src (covered 15000)
|
||||
postSpend ctx src noTerms `shouldReturn` refusedWith 400 "bad_request"
|
||||
forM_ malformedTerms $ \t -> spend ctx src (covered 15000) {sbOrder = aliceOrder {oTerms = t}} `shouldReturn` refusedWith 400 "bad_request"
|
||||
spend ctx src (covered 15000) {sbOrder = aliceOrder {oSealed = T.replicate 11096 "a"}} `shouldReturn` refusedWith 400 "bad_request"
|
||||
padded <- KM.insert "padding" (J.String $ T.replicate 16384 "a") <$> spendBody ctx src (covered 15000)
|
||||
postSpend ctx src padded `shouldReturn` refusedWith 400 "bad_request"
|
||||
|
||||
@@ -5,6 +5,7 @@
|
||||
|
||||
module Bots.StoreService.NamesStoreTests (namesStoreTests, at, btc, insertInvoiceRow, invoiceStatus, issue, newReg, order, ownerA, ownerB, paidOrder, placeCode, placePaid, price, reg, reveal, signature, t0, usable, write) where
|
||||
|
||||
import Bots.StoreService.ConfigTests (termsVersion)
|
||||
import Bots.StoreService.WebTests (columnsOf, digestFixture, runMigrations, withServiceStore)
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.Monad (forM_, void)
|
||||
@@ -47,6 +48,7 @@ namesStoreTests = describe "StoreService names: store" $ do
|
||||
it "rolls back and re-applies only the names migrations, with rows in them, leaving the badge tables and paid invoices as they were" testNamesDownUp
|
||||
it "turns a code_issued order taken at price 0 and not live at its next version, dropping issued_code_id with its index and foreign key, which the down migration restores" testDropTakenCodes
|
||||
it "makes taken orders not live and gives a taken paid order a balance of its price, none to a code order or a price of 0, and rolls back the balance tables and columns" testNameBalancesMigration
|
||||
it "gives the orders stored before it empty agreed terms, and rolls the column back keeping them" testNameTermsMigration
|
||||
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
|
||||
@@ -117,7 +119,8 @@ order label n =
|
||||
ofLength = T.length label,
|
||||
ofDuration = 69292800,
|
||||
ofCommitment = digestFixture n,
|
||||
ofSealed = "sealed-" <> label <> "-" <> T.pack (show n)
|
||||
ofSealed = "sealed-" <> label <> "-" <> T.pack (show n),
|
||||
ofAgreedTerms = termsVersion
|
||||
}
|
||||
|
||||
newReg :: Text -> Address -> OrderFields -> NewRegistration
|
||||
@@ -181,7 +184,7 @@ testNamesColumns = withServiceStore $ \st -> do
|
||||
[ "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", "registered_at", "failed_at", "error", "created_at",
|
||||
"updated_at", "version", "live", "order_hash", "method", "moves", "links_refused_at", "balance_source", "balance_used"
|
||||
"updated_at", "version", "live", "order_hash", "method", "moves", "links_refused_at", "balance_source", "balance_used", "agreed_terms"
|
||||
]
|
||||
has "sx_badge_service_name_invoices" ["invoice_id", "registration_id", "provider_ref", "late_alerted_at", "late_alerted_units", "late_support"]
|
||||
has "sx_badge_service_name_balances" ["registration_id", "amount", "credited", "refunded", "reserved_by", "refunded_at", "created_at", "updated_at"]
|
||||
@@ -194,7 +197,7 @@ testNamesDownUp :: IO ()
|
||||
testNamesDownUp = withServiceStore $ \st -> do
|
||||
let names = dropWhile ((/= "20261010_names") . name) storeServiceSchemaMigrations
|
||||
badgeColumns = mapM (fmap sort . columnsOf st) badgeTables
|
||||
map name names `shouldBe` ["20261010_names", "20261022_drop_taken_codes", "20261022_name_balances", "20261022_name_late_wait"]
|
||||
map name names `shouldBe` ["20261010_names", "20261022_drop_taken_codes", "20261022_name_balances", "20261022_name_late_wait", "20261023_name_terms"]
|
||||
badgeBefore <- badgeColumns
|
||||
code <- issue st 1 usable
|
||||
placeCode st "r1" ownerA (order "alicebakery" 1) code `shouldReturn` Right ()
|
||||
@@ -267,6 +270,31 @@ testNameBalancesMigration = withServiceStore $ \st -> do
|
||||
runMigrations st $ MTRUp balances
|
||||
balanceOf "paid" `shouldReturn` Just (price, price, 0, Nothing)
|
||||
|
||||
testNameTermsMigration :: IO ()
|
||||
testNameTermsMigration = withServiceStore $ \st -> do
|
||||
let terms = [m | m@Migration {name = "20261023_name_terms"} <- storeServiceSchemaMigrations]
|
||||
applied :: IO Bool
|
||||
applied = elem "agreed_terms" <$> columnsOf st "sx_badge_service_name_registrations"
|
||||
agreedTerms :: IO [(Text, Text)]
|
||||
agreedTerms = withTransaction st $ \db -> DB.query_ db "SELECT registration_id, agreed_terms FROM sx_badge_service_name_registrations"
|
||||
kept :: IO [(Text, Text, Int)]
|
||||
kept = withTransaction st $ \db -> DB.query_ db "SELECT registration_id, phase, price FROM sx_badge_service_name_registrations"
|
||||
length terms `shouldBe` 1
|
||||
runMigrations st $ MTRDown (mapMaybe toDownMigration terms)
|
||||
applied `shouldReturn` False
|
||||
withTransaction st $ \db -> do
|
||||
insertInvoiceRow db "inv-paid" (at 60) "open"
|
||||
insertOldRegistration db "paid" 1 "unpaid" price Nothing (Just "inv-paid")
|
||||
kept `shouldReturn` [("paid", "unpaid", price)]
|
||||
runMigrations st $ MTRUp terms
|
||||
applied `shouldReturn` True
|
||||
agreedTerms `shouldReturn` [("paid", "")]
|
||||
runMigrations st $ MTRDown (mapMaybe toDownMigration terms)
|
||||
applied `shouldReturn` False
|
||||
kept `shouldReturn` [("paid", "unpaid", price)]
|
||||
runMigrations st $ MTRUp terms
|
||||
agreedTerms `shouldReturn` [("paid", "")]
|
||||
|
||||
-- | A registration row as the code before the balances wrote it, paid by the invoice or the code given.
|
||||
insertOldRegistration :: DB.Connection -> Text -> Word8 -> Text -> Int -> Maybe Int64 -> Maybe Text -> IO ()
|
||||
insertOldRegistration db rid n phase cents codeId invId = do
|
||||
@@ -293,6 +321,7 @@ testOrderHashFields = do
|
||||
("owner", orderHash ownerB o paid),
|
||||
("commitment", orderHash ownerA o {ofCommitment = digestFixture 2} paid),
|
||||
("sealed", orderHash ownerA o {ofSealed = ofSealed o <> "x"} paid),
|
||||
("terms", orderHash ownerA o {ofAgreedTerms = ofAgreedTerms o <> "/community"} 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)),
|
||||
@@ -306,6 +335,7 @@ testOrderHashBoundaries :: IO ()
|
||||
testOrderHashBoundaries = do
|
||||
let o = order "alicebakery" 1
|
||||
orderHash ownerA o {ofSealed = "ab"} (OTCode "c") `shouldNotBe` orderHash ownerA o {ofSealed = "a"} (OTCode "bc")
|
||||
orderHash ownerA o {ofSealed = "ab", ofAgreedTerms = "c"} (OTCode "d") `shouldNotBe` orderHash ownerA o {ofSealed = "a", ofAgreedTerms = "bc"} (OTCode "d")
|
||||
|
||||
testCreatePaid :: IO ()
|
||||
testCreatePaid = withServiceStore $ \st -> do
|
||||
@@ -322,6 +352,7 @@ testCreatePaid = withServiceStore $ \st -> do
|
||||
nrOwner = ownerA,
|
||||
nrCommitment = ofCommitment o,
|
||||
nrSealed = ofSealed o,
|
||||
nrAgreedTerms = termsVersion,
|
||||
nrPhase = PUnpaid,
|
||||
nrYears = twoYears,
|
||||
nrPrice = price,
|
||||
@@ -486,7 +517,8 @@ testRoundTrip = withServiceStore $ \st -> do
|
||||
nrFailedAt = Just (at 2),
|
||||
nrError = Just "The name was not signed in time",
|
||||
nrLinksRefusedAt = Just (at 4),
|
||||
nrMoves = 2
|
||||
nrMoves = 2,
|
||||
nrAgreedTerms = termsVersion <> "/community"
|
||||
}
|
||||
write st changed `shouldReturn` Written 2
|
||||
reg st "r1" `shouldReturn` changed {nrVersion = 2, nrLive = False, nrUpdatedAt = at 1}
|
||||
@@ -572,7 +604,7 @@ testWriteMeetsLiveOrder = withServiceStore $ \st -> do
|
||||
testRetarget :: IO ()
|
||||
testRetarget = withServiceStore $ \st -> do
|
||||
let o = order "alicebakery" 1
|
||||
o' = order "alicebakers" 2
|
||||
o' = (order "alicebakers" 2) {ofAgreedTerms = termsVersion <> "/community"}
|
||||
placePaid st "r1" ownerA o (at 60) `shouldReturn` Right ()
|
||||
r <- reg st "r1"
|
||||
let failed =
|
||||
@@ -598,6 +630,7 @@ testRetarget = withServiceStore $ \st -> do
|
||||
nrLabelHash = ofLabelHash o',
|
||||
nrCommitment = ofCommitment o',
|
||||
nrSealed = ofSealed o',
|
||||
nrAgreedTerms = ofAgreedTerms o',
|
||||
nrPrice = 10000,
|
||||
nrPhase = PQueued,
|
||||
nrMoves = 1,
|
||||
|
||||
@@ -5,6 +5,7 @@
|
||||
|
||||
module Bots.StoreService.NamesWorkerTests (namesWorkerTests) where
|
||||
|
||||
import Bots.StoreService.ConfigTests (termsVersion)
|
||||
import Bots.StoreService.FakeEthNode
|
||||
import Bots.StoreService.NamesContractsTests (availableCall, maxCommitmentAgeCall, minCommitmentAgeCall, noncesCall, registrarOf, unhex)
|
||||
import Bots.StoreService.NamesOrdersTests
|
||||
@@ -505,7 +506,7 @@ testTwoWallets = withWorker $ \w@W {wCtx = ctx} -> do
|
||||
|
||||
-- | The order of alicebakery, by owner A, with this commitment.
|
||||
aliceFields :: Int -> OrderFields
|
||||
aliceFields n = OrderFields {ofLabelHash = labelHash "alicebakery", ofLength = 11, ofDuration = yearsDuration 2 orderTime, ofCommitment = commitmentOf n, ofSealed = "sealed-alicebakery-" <> tshow n}
|
||||
aliceFields n = OrderFields {ofLabelHash = labelHash "alicebakery", ofLength = 11, ofDuration = yearsDuration 2 orderTime, ofCommitment = commitmentOf n, ofSealed = "sealed-alicebakery-" <> tshow n, ofAgreedTerms = termsVersion}
|
||||
|
||||
aliceRegistration :: Text -> Int -> NewRegistration
|
||||
aliceRegistration rid n = NewRegistration {nrgId = RegistrationId rid, nrgOwner = ownerA, nrgOrder = aliceFields n, nrgYears = 2}
|
||||
|
||||
Reference in new issue
Block a user