diff --git a/apps/simplex-store-service/src/StoreService/Names/Orders.hs b/apps/simplex-store-service/src/StoreService/Names/Orders.hs index aeab67a4c5..a584d70035 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Orders.hs @@ -28,6 +28,7 @@ module StoreService.Names.Orders codeOrderInsert, checkTimestamp, checkDuration, + checkTerms, checkNameFree, checkPrice, movable, @@ -66,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 (..)) @@ -105,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 @@ -266,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 = diff --git a/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs b/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs index 643a905f57..e9dedd3647 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs @@ -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] diff --git a/apps/simplex-store-service/src/StoreService/Web/Names/Owner.hs b/apps/simplex-store-service/src/StoreService/Web/Names/Owner.hs index e0598df16a..69235a5806 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Names/Owner.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Names/Owner.hs @@ -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) diff --git a/tests/Bots/StoreService/NamesOrdersTests.hs b/tests/Bots/StoreService/NamesOrdersTests.hs index a5647d870b..6528852d1d 100644 --- a/tests/Bots/StoreService/NamesOrdersTests.hs +++ b/tests/Bots/StoreService/NamesOrdersTests.hs @@ -37,6 +37,13 @@ module Bots.StoreService.NamesOrdersTests advance, refusedWith, malformedTerms, + listName, + bakers, + bumpedTerms, + newerTerms, + olderTerms, + communityTerms, + termsChanged, ) where @@ -154,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 @@ -739,6 +754,38 @@ testFormats = withOrders $ \ctx -> do 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"] @@ -750,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. @@ -822,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 diff --git a/tests/Bots/StoreService/NamesOwnerTests.hs b/tests/Bots/StoreService/NamesOwnerTests.hs index 8d0cb4f2f3..f2c6834a05 100644 --- a/tests/Bots/StoreService/NamesOwnerTests.hs +++ b/tests/Bots/StoreService/NamesOwnerTests.hs @@ -89,7 +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 @@ -115,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 @@ -462,6 +469,20 @@ 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"} @@ -469,6 +490,54 @@ testMoveTermsOnly = withOwner $ \ctx -> do (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" diff --git a/tests/Bots/StoreService/NamesSpendTests.hs b/tests/Bots/StoreService/NamesSpendTests.hs index b100e228d7..20da5bacac 100644 --- a/tests/Bots/StoreService/NamesSpendTests.hs +++ b/tests/Bots/StoreService/NamesSpendTests.hs @@ -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, malformedTerms, 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) @@ -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) @@ -417,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