From cc62da7ce745694fa91769b995041e79fba3866d Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 14:49:28 +0000 Subject: [PATCH] store: spend a balance on another name --- .../src/StoreService/Names/Balances.hs | 52 +- .../src/StoreService/Web/Names.hs | 8 +- .../src/StoreService/Web/Names/Orders.hs | 83 ++- .../src/StoreService/Web/Server.hs | 2 +- simplex-chat.cabal | 1 + .../StoreService/GroupIntegrationTests.hs | 23 +- tests/Bots/StoreService/NamesOrdersTests.hs | 9 +- tests/Bots/StoreService/NamesSpendTests.hs | 519 ++++++++++++++++++ tests/Test.hs | 2 + 9 files changed, 682 insertions(+), 17 deletions(-) create mode 100644 tests/Bots/StoreService/NamesSpendTests.hs diff --git a/apps/simplex-store-service/src/StoreService/Names/Balances.hs b/apps/simplex-store-service/src/StoreService/Names/Balances.hs index 2e164ff5be..2115b4c43c 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Balances.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Balances.hs @@ -5,14 +5,23 @@ module StoreService.Names.Balances ( RefundRefusal (..), RefundRecord (..), recordRefund, + Spend (..), + spendTerms, + checkSpendBalance, + coveredOrderInsert, + differenceOrderInsert, ) where +import Data.Maybe (isNothing) import Data.Text (Text) import Data.Time.Clock (UTCTime) +import Simplex.Chat.PaymentService.Types (ServicePaymentMethod) import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) +import qualified Simplex.Messaging.Agent.Store.DB as DB +import StoreService.Names.Orders (OrderRefusal (..)) import StoreService.Names.Phases (RegistrationId) -import StoreService.Names.Store (Balance (..), BalanceHold, BalanceLink, balanceByReference, balanceChain, refundBalance) +import StoreService.Names.Store (Balance (..), BalanceHold, BalanceLink, NameRegistration, NewRegistration, OrderTerms (..), PaidOrder, RegistrationRefused (..), balanceByReference, balanceChain, createBalanceRegistration, createPaidRegistration, getBalance, heldBy, overdueHolder, refundBalance) import StoreService.Names.Turns (Turns, withBalanceTurn) -- | RefundAmount: the balance's amount now, which is not the cents given. RefundHeld: an order holds it, overdue or not, @@ -54,3 +63,44 @@ recordRefund turns st ref cents now = Just Balance {blAmount} | blAmount /= cents || blAmount <= 0 -> Just $ RefundAmount blAmount | otherwise -> Nothing + +-- | A new order paid from a balance. Its hash covers the paying order, the price, the balance the page read, +-- and the method, present exactly when the price is more than that balance. +data Spend = Spend + { spSource :: RegistrationId, + spPrice :: Int, + spBalance :: Int, + spMethod :: Maybe ServicePaymentMethod + } + +spendTerms :: Spend -> OrderTerms +spendTerms Spend {spSource, spPrice, spBalance, spMethod} = OTBalance spSource spPrice spBalance spMethod + +-- | The balance has the amount the page read and no open order holds it. A hold by an overdue order reads as none, +-- and that order is returned for the new order's transaction to close. +checkSpendBalance :: DBStore -> Spend -> UTCTime -> IO (Either OrderRefusal (Maybe NameRegistration)) +checkSpendBalance st Spend {spSource, spBalance} now = + withTransaction st $ \db -> + getBalance db spSource now >>= \case + Just balance@Balance {blAmount} + | blAmount == spBalance && isNothing (heldBy balance) -> Right <$> overdueHolder db spSource now + balance -> pure $ Left $ ORBalanceChanged balance + +-- | The order queued, its price spent from the balance read. +coveredOrderInsert :: Spend -> NewRegistration -> DB.Connection -> UTCTime -> IO (Either OrderRefusal ()) +coveredOrderInsert Spend {spSource, spPrice, spBalance} new db now = + balanceRefusal db spSource now =<< createBalanceRegistration db new spSource spPrice spBalance now + +-- | The order unpaid with its invoice for the difference, holding all of the balance read. +differenceOrderInsert :: Spend -> NewRegistration -> PaidOrder -> DB.Connection -> UTCTime -> IO (Either OrderRefusal ()) +differenceOrderInsert spend@Spend {spSource} new paid db now = + balanceRefusal db spSource now =<< createPaidRegistration db new (spendTerms spend) paid now + +-- | A write refused at the balance answers with the balance as this transaction reads it. +balanceRefusal :: DB.Connection -> RegistrationId -> UTCTime -> Either RegistrationRefused () -> IO (Either OrderRefusal ()) +balanceRefusal db source now = \case + Right () -> pure $ Right () + Left RRBalanceChanged -> Left . ORBalanceChanged <$> getBalance db source now + Left RRLiveOrder -> pure $ Left OROrderExists + -- a spend reserves no code + Left RRCodeNotReservable -> pure $ Left OROrderExists diff --git a/apps/simplex-store-service/src/StoreService/Web/Names.hs b/apps/simplex-store-service/src/StoreService/Web/Names.hs index 3082ca0cbd..b6f765f21d 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Names.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Names.hs @@ -7,11 +7,12 @@ module StoreService.Web.Names (Route (..), namesRoutes, namesApp) where import Data.Text (Text) import Network.HTTP.Types (Method) import Network.Wai (Request, ResponseReceived, pathInfo) +import StoreService.Config (ServiceConfig) import StoreService.Names.Env (NamesEnv (..)) import StoreService.Names.Orders (ordersEnv) import StoreService.Web.Http (HttpEnv, Limit, Respond, codeLimit, createLimit, findLimit, holdMicros, limited, only, previewLimit, readLimit, recordsLimit, searchLimit) import StoreService.Web.Names.Codes (codeCheckHandler) -import StoreService.Web.Names.Orders (codeOrderHandler) +import StoreService.Web.Names.Orders (codeOrderHandler, spendHandler) import StoreService.Web.Names.Owner (findHandler, retargetHandler) import StoreService.Web.Names.Records (recordsHandler) import StoreService.Web.Names.Registration (registrationHandler, retryHandler, revealHandler) @@ -23,8 +24,8 @@ data Route = Route rHandler :: Request -> Respond -> IO ResponseReceived } -namesRoutes :: NamesEnv -> [Text] -> Maybe Route -namesRoutes env@NamesEnv {neConfig, neStore, neContracts, neProfiles, neRecords, neWaiters, neProviders} = \case +namesRoutes :: ServiceConfig -> NamesEnv -> [Text] -> Maybe Route +namesRoutes cfg env@NamesEnv {neConfig, neStore, neContracts, neProfiles, neRecords, neWaiters, neProviders} = \case ["api", "name", "records"] -> Just Route {rMethod = "POST", rLimit = recordsLimit, rHandler = recordsHandler neRecords} ["api", "name", "register"] -> Just Route {rMethod = "POST", rLimit = codeLimit, rHandler = codeOrderHandler (ordersEnv env) neProviders neWaiters} ["api", "code", "check"] -> Just Route {rMethod = "POST", rLimit = codeLimit, rHandler = codeCheckHandler neStore} @@ -37,6 +38,7 @@ namesRoutes env@NamesEnv {neConfig, neStore, neContracts, neProfiles, neRecords, ["api", "registration", rid, "name"] -> Just Route {rMethod = "POST", rLimit = createLimit, rHandler = retargetHandler (ordersEnv env) rid} ["api", "registration", rid, "reveal"] -> Just Route {rMethod = "POST", rLimit = readLimit, rHandler = revealHandler (ordersEnv env) rid} ["api", "registration", rid, "retry"] -> Just Route {rMethod = "POST", rLimit = createLimit, rHandler = retryHandler (ordersEnv env) rid} + ["api", "registration", rid, "spend"] -> Just Route {rMethod = "POST", rLimit = createLimit, rHandler = spendHandler (ordersEnv env) cfg neProviders neWaiters rid} _ -> Nothing -- | Nothing for a path no route knows. The limit is taken only once the route and the method match. 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 de0052898a..aa82cb3834 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs @@ -9,6 +9,7 @@ module StoreService.Web.Names.Orders firstRefusal, nameInvoiceHandler, codeOrderHandler, + spendHandler, nameInvoiceView, orderRefusalResponse, ) @@ -17,36 +18,39 @@ where import Control.Concurrent.STM (atomically) import qualified Control.Exception as E import Control.Monad (forM_, unless) +import Control.Monad.Except (ExceptT (..), liftEither, runExceptT) import Data.Aeson ((.=)) import qualified Data.Aeson as J import qualified Data.Aeson.KeyMap as KM import Data.Bifunctor (first) -import Data.Maybe (isJust) +import Data.Maybe (isJust, maybeToList) import Data.Text (Text) import Data.Time.Clock (UTCTime, addUTCTime) -import Data.Word (Word32) +import Data.Word (Word32, Word64) import Network.HTTP.Types (status200, status409, status503) import Network.Wai (Request, Response, ResponseReceived) import Simplex.Chat.Badges.Code (NameCode (..), parseNameCode) import Simplex.Chat.PaymentService.Types (CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), ServicePaymentMethod) import Simplex.Messaging.Agent.Store.Common (withTransaction) import qualified Simplex.Messaging.Agent.Store.DB as DB +import Simplex.Messaging.Crypto.Secp256k1 (RecoverableSignature) import Simplex.Messaging.Util (tshow) import StoreService.Catalog (catalogCurrency) import StoreService.Config (NamesConfig (..), ServiceConfig) import StoreService.Log (logError, logInfo, logWarn) +import StoreService.Names.Balances (Spend (..), checkSpendBalance, coveredOrderInsert, differenceOrderInsert, spendTerms) import StoreService.Names.Codes (CodeRefusal (..), readPrepaidCode) import StoreService.Names.Orders import StoreService.Names.Phases (RegistrationId (..)) -import StoreService.Names.Signatures (OrderFields (..)) +import StoreService.Names.Signatures (OrderFields (..), spendMessage) import StoreService.Names.Store (NameRegistration (..), NewRegistration (..), OrderTerms (..), PaidOrder (..), PrepaidCode (..), RegistrationPayment (..), createPaidRegistration, getRegistration, newRegistrationId, orderHash, textMethod) -import StoreService.Names.Turns (withLabelTurn) +import StoreService.Names.Turns (withBalanceTurn, withLabelTurn) import StoreService.Names.View (balanceJSON, registrationAt, registrationView) import StoreService.Orders (publishRegistration) import StoreService.Providers (OrderDraft (..), Provider (..), ProviderError (..), ProviderInvoice (..), expiresItself) import StoreService.Store.Invoices (InvoiceRow (..), NewNameInvoice (..), getInvoice, insertNameInvoice, newInvoiceId, truncateToSecond) import StoreService.Waiters (Waiters, publish) -import StoreService.Web.Http (Respond, badRequest, confirmationsFor, internalError, invalidName, invoiceAt, invoicePairs, invoiceWindow, jsonError, jsonResponse, nameBodyBytes, providerFor, providerNamed, providerUnavailable, readBoundedBody) +import StoreService.Web.Http (Respond, badRequest, confirmationsFor, internalError, invalidName, invoiceAt, invoicePairs, invoiceWindow, jsonError, jsonResponse, nameBodyBytes, notFound, providerFor, providerNamed, providerUnavailable, readBoundedBody) import StoreService.Web.Names.Codes (codeRefusalResponse) data InvoiceOrder = InvoiceOrder @@ -164,10 +168,11 @@ createAtProvider env@OrdersEnv {oeStore, oeConfig, oeNow} cfg providers waiters -- | An exact resend, answered with its order as it reads now: the invoice view, or the id of an order without an invoice. resentOrder :: OrdersEnv -> ServiceConfig -> Text -> UTCTime -> NameRegistration -> IO Answer -resentOrder env@OrdersEnv {oeStore} cfg what now r@NameRegistration {nrPayment} = case nrPayment of +resentOrder env@OrdersEnv {oeStore} cfg what now r@NameRegistration {nrId, nrPayment} = case nrPayment of RPInvoice _ invId -> getInvoice oeStore invId >>= maybe (refused what OROrderExists) (fmap answerNow . invoiceViewResponse env cfg (registrationAt now r) . invoiceAt now) + RPBalance -> pure $ answerNow $ registrationAnswer nrId + -- the hash of an invoice or spend order never matches a code order's RPCode _ -> refused what OROrderExists - RPBalance -> refused what OROrderExists invoiceViewResponse :: OrdersEnv -> ServiceConfig -> NameRegistration -> InvoiceRow -> IO Response invoiceViewResponse env cfg r row = jsonResponse status200 <$> nameInvoiceView env (confirmationsFor cfg) row r @@ -221,6 +226,70 @@ parseCodeOrder o = do order@(req, _) <- maybe (Left ORBadRequest) Right $ (,) <$> parseOrderRequest o <*> textField o "code" order <$ checkLength (orFields req) +-- | POST /api/registration/:id/spend, another name paid from this order's balance, in the contract's order of checks, +-- under the new name's turn and then the balance's. +spendHandler :: OrdersEnv -> ServiceConfig -> [Provider] -> Waiters -> Text -> Request -> Respond -> IO ResponseReceived +spendHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} cfg providers waiters ridText req respond = + readBoundedBody nameBodyBytes req >>= requested >>= sendAnswer respond + where + source = RegistrationId ridText + what = "POST /api/registration/:id/spend" + refuse = refused what + requested = \case + Just body | Just (J.Object o) <- J.decode body -> either refuse paying (parseSpend source o) + _ -> refuse ORBadRequest + paying ((fields, timestamp, signature), spend) = + withTransaction oeStore (`getRegistration` source) >>= \case + Nothing -> pure $ answerNow notFound + Just NameRegistration {nrOwner} -> + checkSigner nrOwner (spendMessage source fields timestamp) signature >>= \case + Left refusal -> refuse refusal + Right () -> do + let order = OrderRequest {orOwner = nrOwner, orFields = fields, orTimestamp = timestamp, orSignature = signature} + withLabelTurn oeTurns (ofLabelHash fields) $ withBalanceTurn oeTurns source $ inTurns order spend + inTurns order@OrderRequest {orOwner, orFields} spend = do + now <- oeNow + withTransaction oeStore (\db -> existingOrder db order (orderHash orOwner orFields $ spendTerms spend) now) >>= \case + 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 + let years = nYears oeConfig + liftEither $ checkTimestamp now orTimestamp + liftEither $ checkDuration oeConfig now years ofDuration + holder <- ExceptT $ checkSpendBalance oeStore spend now + ExceptT $ checkNameFree oeContracts oeStore ofLabelHash + ExceptT $ checkPrice oeContracts ofLength years spPrice + pure holder + place order@OrderRequest {orOwner, orFields} spend@Spend {spPrice, spBalance, spMethod} holder = case spMethod of + Nothing -> do + rid <- newRegistrationId + let new = NewRegistration {nrgId = rid, nrgOwner = orOwner, nrgOrder = orFields, nrgYears = nYears oeConfig} + placeOrder env order (maybeToList holder) (coveredOrderInsert spend new) >>= \case + Left refusal -> refuse refusal + Right closed -> pure Answer {aResponse = registrationAnswer rid, aAfter = announceClosed env providers waiters closed} + Just method -> + createAtProvider env cfg providers waiters what $ + InvoicedOrder {ivRequest = order, ivHolders = maybeToList holder, ivMethod = method, ivPrice = spPrice, ivAmount = fromIntegral (spPrice - spBalance), ivInsert = differenceOrderInsert spend} + +-- | Every format check, the method present exactly for a difference, then the length's range. +parseSpend :: RegistrationId -> J.Object -> Either OrderRefusal ((OrderFields, Word64, RecoverableSignature), Spend) +parseSpend spSource o = do + parsed@((fields, _, _), _) <- maybe (Left ORBadRequest) Right $ do + signed <- parseOrderFields o + spPrice <- cents "price" + spBalance <- cents "balance" + spMethod <- case (KM.lookup "method" o, spPrice > spBalance) of + (Nothing, False) -> Just Nothing + (Just (J.String t), True) -> Just <$> textMethod t + _ -> Nothing + pure (signed, Spend {spSource, spPrice, spBalance, spMethod}) + parsed <$ checkLength fields + where + -- positive, and within an invoice amount's range + cents :: J.Key -> Maybe Int + cents k = KM.lookup k o >>= integerField >>= \n -> if n > (0 :: Word32) then Just (fromIntegral n) else Nothing + -- | After the commit, the closed orders' invoices and versions are published, and their invoices cancelled at the provider, -- best effort, as the poller's sweep would cancel them. announceClosed :: OrdersEnv -> [Provider] -> Waiters -> [ClosedOrder] -> IO () diff --git a/apps/simplex-store-service/src/StoreService/Web/Server.hs b/apps/simplex-store-service/src/StoreService/Web/Server.hs index 884d77f3bc..6e23349ad2 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Server.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Server.hs @@ -122,7 +122,7 @@ webApp env@WebEnv {weHttp} req respond = case pathInfo req of ["webhooks", "stripe"] -> only "POST" req respond $ webhookHandler env PPStripe "POST /webhooks/stripe" req respond _ -> fromMaybe (respond notFound) names where - names = weNames env >>= \n -> namesApp weHttp (namesRoutes n) req respond + names = weNames env >>= \n -> namesApp weHttp (namesRoutes (weConfig env) n) req respond -- | The names site on a names host, the badges site on any other. servedSite :: WebEnv -> Request -> Maybe Site diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 7a4f155c39..5c6e878174 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -783,6 +783,7 @@ test-suite simplex-chat-test Bots.StoreService.NamesSearchTests Bots.StoreService.NamesSenderTests Bots.StoreService.NamesSignatureTests + Bots.StoreService.NamesSpendTests Bots.StoreService.NamesStoreTests Bots.StoreService.NamesWiringTests Bots.StoreService.NamesWorkerTests diff --git a/tests/Bots/StoreService/GroupIntegrationTests.hs b/tests/Bots/StoreService/GroupIntegrationTests.hs index 291cbd6ee9..1fee6d1685 100644 --- a/tests/Bots/StoreService/GroupIntegrationTests.hs +++ b/tests/Bots/StoreService/GroupIntegrationTests.hs @@ -137,7 +137,7 @@ badgeGroupIntegrationTests = do it "leaves a tracker it cannot edit alone rather than publishing the code again" testUneditableTrackerLeftAlone namesBootTests :: SpecWith TestParams -namesBootTests = it "boots with [names] and [chain], routing fixed /api/name paths ahead of a search, find ahead of registrations, registrations to GET, another name, a reveal and a retry to POST, a path no route knows and a taken order's code to 404, code checks and orders under one limit, and another name and retries under another" testNamesBoot +namesBootTests = it "boots with [names] and [chain], routing fixed /api/name paths ahead of a search, find ahead of registrations, registrations to GET, another name, a reveal, a spend and a retry to POST, a path no route knows and a taken order's code to 404, code checks and orders under one limit, and another name and retries under another" testNamesBoot testNamesBoot :: HasCallStack => TestParams -> IO () testNamesBoot ps = do @@ -173,12 +173,29 @@ testNamesBoot ps = do answer revealed {method = "POST", requestBody = RequestBodyLBS "{}"} `shouldReturn` (404, Just $ J.object ["error" J..= ("not_found" :: Text)]) revealedByGet <- httpLbs revealed mgr (statusCode $ responseStatus revealedByGet, lookup "Allow" $ responseHeaders revealedByGet) `shouldBe` (405, Just "POST") + spent <- request "/api/registration/t2Jk8RmQ4vXw9NcP3yLb6g/spend" + -- formats are checked before the order, so only a well-formed body reaches the 404 + let spendBody = + J.object + [ "labelHash" J..= aliceHex, + "length" J..= (11 :: Int), + "duration" J..= (69292800 :: Int), + "commitment" J..= aliceHex, + "sealed" J..= ("sealed" :: Text), + "price" J..= (10000 :: Int), + "balance" J..= (10000 :: Int), + "timestamp" J..= (1792574100 :: Int), + "signature" J..= ("0x" <> T.replicate 32 "11" <> T.replicate 32 "22" <> "1b") + ] + answer spent {method = "POST", requestBody = RequestBodyLBS $ J.encode spendBody} `shouldReturn` (404, Just $ J.object ["error" J..= ("not_found" :: Text)]) + spentByGet <- httpLbs spent mgr + (statusCode $ responseStatus spentByGet, lookup "Allow" $ responseHeaders spentByGet) `shouldBe` (405, Just "POST") retried <- request "/api/registration/t2Jk8RmQ4vXw9NcP3yLb6g/retry" answer retried {method = "POST"} `shouldReturn` (404, Just $ J.object ["error" J..= ("not_found" :: Text)]) retriedByGet <- httpLbs retried mgr (statusCode $ responseStatus retriedByGet, lookup "Allow" $ responseHeaders retriedByGet) `shouldBe` (405, Just "POST") - -- another name and the retry above took 2 of this client's 5 create requests a minute - replicateM_ 3 $ statusCode . responseStatus <$> httpLbs retried {method = "POST"} mgr `shouldReturn` 404 + -- another name, the spend and the retry above took 3 of this client's 5 create requests a minute + replicateM_ 2 $ statusCode . responseStatus <$> httpLbs retried {method = "POST"} mgr `shouldReturn` 404 statusCode . responseStatus <$> httpLbs retried {method = "POST"} mgr `shouldReturn` 429 -- the register above took the first of this client's 10 code requests a minute, which the code check shares let codeRequest path = request path >>= \r -> statusCode . responseStatus <$> httpLbs r {method = "POST", requestBody = RequestBodyLBS "{}"} mgr diff --git a/tests/Bots/StoreService/NamesOrdersTests.hs b/tests/Bots/StoreService/NamesOrdersTests.hs index 0831e1457f..3bee423bba 100644 --- a/tests/Bots/StoreService/NamesOrdersTests.hs +++ b/tests/Bots/StoreService/NamesOrdersTests.hs @@ -7,10 +7,13 @@ module Bots.StoreService.NamesOrdersTests Ctx (..), Order (..), withOrders, + withOrdersVia, withOrdersCancelling, aliceOrder, commitmentOf, + fieldsOf, orderTime, + placeOrder, placed, post, settleNow, @@ -273,6 +276,8 @@ withSignature sig = KM.insert "signature" (J.String sig) data Ctx = Ctx { cStore :: DBStore, + -- | Another store over the same database, as a second process opens one. + cOpenStore :: IO DBStore, cNode :: FakeEthNode, cOrders :: OrdersEnv, cWeb :: WebEnv, @@ -303,7 +308,7 @@ withOrders = withOrdersVia id -- | With the providers changed as a test needs them. withOrdersVia :: (Provider -> Provider) -> (Ctx -> IO a) -> IO a -withOrdersVia via action = withServiceStore $ \cStore -> withFakeEthNode $ \cNode -> do +withOrdersVia via action = withServiceStores $ \cOpenStore -> cOpenStore >>= \cStore -> withFakeEthNode $ \cNode -> do cRandom <- C.newRandom ct <- newContracts TLDSimplex =<< newChainClient cRandom (fakeChainConfig cNode) turns <- newTurns @@ -326,7 +331,7 @@ withOrdersVia via action = withServiceStore $ \cStore -> withFakeEthNode $ \cNod let cWeb = built {weOrders = Just cOrders} mgr <- newManager defaultManagerSettings Warp.testWithApplicationSettings (webSettings (listener cfg)) (pure $ ordersApp cWeb cOrders) $ \port -> - action Ctx {cStore, cNode, cOrders, cWeb, cClient = (mgr, "http://127.0.0.1:" <> show port), cStub, cClock, cRandom, cIps} + action Ctx {cStore, cOpenStore, cNode, cOrders, cWeb, cClient = (mgr, "http://127.0.0.1:" <> show port), cStub, cClock, cRandom, cIps} 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) diff --git a/tests/Bots/StoreService/NamesSpendTests.hs b/tests/Bots/StoreService/NamesSpendTests.hs new file mode 100644 index 0000000000..021dc9e74b --- /dev/null +++ b/tests/Bots/StoreService/NamesSpendTests.hs @@ -0,0 +1,519 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Bots.StoreService.NamesSpendTests (namesSpendTests) where + +import Bots.StoreService.FakeEthNode +import Bots.StoreService.NamesContractsTests (reservedNamesCall) +import Bots.StoreService.NamesOrdersTests (Ctx (..), Order (..), advance, aliceOrder, commitmentOf, field, fieldsOf, invoiceRegistration, keyB, orderTime, placeOrder, post, refusedWith, registrationById, registrationOf, settleNow, withOrdersVia, yearsDuration) +import Bots.StoreService.NamesStoreTests (at, order, ownerA, placePaid, reg, t0, write) +import Bots.StoreService.WebTests (StubCall (..), StubState (..), jsonObject, rcv, sampleProviderInvoice, statusOf, stubCalls, webGet, webRequestBody) +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_) +import qualified Data.Aeson as J +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) +import Data.List (sort) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Time.Clock (UTCTime, addUTCTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Data.Word (Word64) +import Network.HTTP.Client (defaultManagerSettings, newManager) +import Network.HTTP.Types (hContentType) +import qualified Network.Wai.Handler.Warp as Warp +import Simplex.Chat.PaymentService.Types (CryptoCurrency (..), CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), ServicePaymentMethod (..)) +import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.Secp256k1 (signRecoverable) +import Simplex.Messaging.Eth.EIP712 (serializeSignature) +import Simplex.Messaging.SimplexName (LabelHash (..), labelHash) +import StoreService.Names.Abi (hex, uint256) +import StoreService.Names.Balances (RefundRefusal (..), recordRefund) +import StoreService.Names.Orders (OrdersEnv (..)) +import StoreService.Names.Phases (RegistrationId (..), phasesWaiting) +import StoreService.Names.Signatures (OrderFields (..), personalDigest, spendMessage) +import StoreService.Names.Store +import StoreService.Names.View (balanceJSON) +import StoreService.Orders (cancelOpenInvoice) +import StoreService.Providers (Funded (..), OrderDraft (..), PaymentSignal (..), Provider (..), ProviderError (..)) +import StoreService.Names.Turns (balanceTurnCount, labelTurnCount, withBalanceTurn) +import StoreService.Store.Invoices (InvoiceRow (..), getInvoice) +import StoreService.Web.Http (createLimit, holdMicros, readLimit) +import StoreService.Web.Names (Route (..), namesApp) +import StoreService.Web.Names.Orders (spendHandler) +import StoreService.Web.Names.Registration (registrationHandler) +import StoreService.Web.Server (WebEnv (..), webApp) +import System.Timeout (timeout) +import Test.Hspec + +namesSpendTests :: Spec +namesSpendTests = describe "StoreService names: spend" $ do + describe "orders" $ do + it "queues an order whose price the balance covers, spending the price and keeping the rest, or all of it" testCoveredSpend + it "makes an invoice for the difference, the order holding all of the balance until the invoice's expiry" testDifferenceSpend + it "answers an exact resend with its order in any phase, by its own hash, with a new timestamp and after the balance changed" testSpendResend + it "keeps a spend and an /api/invoice order of the same fields apart, each meeting the other as order_exists" testInvoiceBodyApart + describe "refusals" $ do + it "answers balance_changed with the current balance for a stale amount, a held balance and an order with none" testBalanceChanged + it "refuses a method with a covered price, none with a difference, and prices and balances not positive" testMethodRule + it "refuses another signer and a stale timestamp, and answers an unknown order 404" testSignerAndId + it "answers name_taken, catalog_changed, name_check_unavailable, provider_unavailable and order_exists, spending nothing" testOrderChecks + it "runs its checks in the contract's order" testCheckOrder + 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 "holders" $ do + it "closes the balance's overdue unfunded holder in the spend's transaction, publishing it and cancelling its invoice" testOverdueHolderSpent + it "goes through when the overdue holder was cancelled meanwhile" testHolderCancelledMeanwhile + it "answers balance_changed when the overdue holder was funded meanwhile, cancelling the new invoice" testHolderFundedMeanwhile + describe "races" $ do + it "lets one of two concurrent spends of one balance win, the other answered balance_changed" testConcurrentSpends + it "answers balance_changed and cancels the provider invoice when another store changed the balance after the check" testWriteRefusedAtBalance + it "lets one of a spend and a refund of the balance win" testSpendRacesRefund + it "takes the new name's turn and then the balance's" testSpendTurns + +-- fixtures + +-- | The spend route beside the registration poll and the service's routes; the hook runs as each provider invoice is created. +withSpendHook :: (IORef (IO ()) -> Ctx -> IO a) -> IO a +withSpendHook action = do + hook <- newIORef (pure ()) + withOrdersVia (\p -> p {pCreateInvoice = \m d -> join (readIORef hook) >> pCreateInvoice p m d}) $ \ctx@Ctx {cOrders, cWeb} -> do + let routes :: [Text] -> Maybe Route + routes = \case + ["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 req respond = fromMaybe (webApp cWeb req respond) (namesApp (weHttp cWeb) routes req respond) + mgr <- newManager defaultManagerSettings + Warp.testWithApplication (pure app) $ \port -> action hook ctx {cClient = (mgr, "http://127.0.0.1:" <> show port)} + +withSpend :: (Ctx -> IO a) -> IO a +withSpend action = withSpendHook (const action) + +-- | Run by the next provider invoice made, once. +onCreate :: IORef (IO ()) -> IO () -> IO () +onCreate hook act = writeIORef hook (writeIORef hook (pure ()) >> act) + +-- | A taken paid order of owner A with a balance of the cents. +sourceOf :: Ctx -> Text -> Int -> IO RegistrationId +sourceOf Ctx {cStore} rid cents = do + placePaid cStore rid ownerA (order ("source-" <> rid) 1) {ofCommitment = C.sha256Hash $ encodeUtf8 rid} (at 60) `shouldReturn` Right () + taken <- reg cStore rid + write cStore taken {nrPhase = PTaken} `shouldReturn` Written 2 + credit cStore rid cents + pure $ RegistrationId rid + +credit :: DBStore -> Text -> Int -> IO () +credit st rid cents = withTransaction st $ \db -> creditBalance db (RegistrationId rid) cents t0 + +-- | What the page sends: the new order's fields and price, the balance it read, and a method only for a difference. +data SpendBody = SpendBody + { sbOrder :: Order, + sbBalance :: Int, + sbMethod :: Maybe Text + } + +-- | alicebakery, at 10000. +covered :: Int -> SpendBody +covered balance = SpendBody {sbOrder = aliceOrder, sbBalance = balance, sbMethod = Nothing} + +difference :: Int -> SpendBody +difference balance = (covered balance) {sbMethod = Just "btc"} + +-- | 7 letters, at the launch price of 20000 for 2 years. +dynamisOrder :: Order +dynamisOrder = aliceOrder {oLabel = "dynamis", oPrice = 20000, oCommitment = commitmentOf 2} + +dynamis :: Int -> Maybe Text -> SpendBody +dynamis = SpendBody dynamisOrder + +-- | Signed and timed at the clock's time, as a page acting later sends it. +timedAt :: UTCTime -> SpendBody -> SpendBody +timedAt now b@SpendBody {sbOrder} = b {sbOrder = sbOrder {oTimestamp = seconds now, oDuration = yearsDuration 2 now}} + +spendBody :: Ctx -> RegistrationId -> SpendBody -> IO J.Object +spendBody Ctx {cRandom} source SpendBody {sbOrder = o@Order {oKey, oPrice, oTimestamp}, sbBalance, sbMethod} = do + sig <- either (error . show) id <$> signRecoverable cRandom oKey (personalDigest $ spendMessage source fields oTimestamp) + pure $ + KM.fromList $ + [ ("labelHash", J.String $ hex lh), + ("length", J.toJSON ofLength), + ("duration", J.toJSON ofDuration), + ("commitment", J.String $ hex ofCommitment), + ("sealed", J.String ofSealed), + ("price", J.toJSON oPrice), + ("balance", J.toJSON sbBalance), + ("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 + +postSpend :: Ctx -> RegistrationId -> J.Object -> IO (Int, Maybe J.Object) +postSpend ctx (RegistrationId rid) = post ctx ("/api/registration/" <> T.unpack rid <> "/spend") . J.encode + +spend :: Ctx -> RegistrationId -> SpendBody -> IO (Int, Maybe J.Object) +spend ctx source b = spendBody ctx source b >>= postSpend ctx source + +registrationAnswer :: Maybe J.Object -> RegistrationId +registrationAnswer = \case + Just v | KM.keys v == ["registrationId"], Just (J.String rid) <- field "registrationId" v -> RegistrationId rid + other -> error $ "not a registration id: " <> show other + +invoiceIdOf :: Maybe J.Object -> InvoiceId +invoiceIdOf v = case field "invoiceId" =<< v of + Just (J.String t) -> InvoiceId t + other -> error $ "not an invoice view: " <> show other + +registrationPath :: RegistrationId -> String +registrationPath (RegistrationId rid) = "/api/registration/" <> T.unpack rid + +viewOf :: Ctx -> RegistrationId -> IO J.Object +viewOf Ctx {cClient} rid = webGet cClient (registrationPath rid) >>= jsonObject + +-- | A registration poll at the order's version, once the server holds it. +heldPoll :: Ctx -> NameRegistration -> IO (Async (Int, J.Object)) +heldPoll Ctx {cOrders, cClient} NameRegistration {nrId, nrVersion} = do + waiting <- atomically $ phasesWaiting (oePhases cOrders) + poll <- async $ webGet cClient (registrationPath nrId <> "?seenVersion=" <> show nrVersion) >>= \resp -> (statusOf resp,) <$> jsonObject resp + timeout pollSeconds (atomically $ phasesWaiting (oePhases cOrders) >>= check . (> waiting)) >>= maybe (error "the poll was not held") pure + pure poll + +woken :: Async (Int, J.Object) -> IO (Int, J.Object) +woken poll = timeout pollSeconds (wait poll) >>= maybe (cancel poll >> error "the poll was not woken") pure + +pollSeconds :: Int +pollSeconds = 5000000 + +balanceOf :: Ctx -> RegistrationId -> IO (Maybe Balance) +balanceOf Ctx {cStore, cClock} rid = readIORef cClock >>= \now -> withTransaction cStore $ \db -> getBalance db rid now + +amountOf :: Ctx -> RegistrationId -> IO (Maybe Int) +amountOf ctx rid = fmap blAmount <$> balanceOf ctx rid + +balanceChanged :: Maybe Balance -> (Int, Maybe J.Object) +balanceChanged b = (409, Just $ KM.fromList [("error", "balance_changed"), ("balance", maybe J.Null balanceJSON b)]) + +-- | The orders a balance paid. +paidFrom :: Ctx -> RegistrationId -> IO [NameRegistration] +paidFrom Ctx {cStore} source = filter ((== Just source) . nrBalanceSource) <$> withTransaction cStore (`findRegistrations` ownerA) + +cancels :: Ctx -> IO [Text] +cancels Ctx {cStub} = (\calls -> [r | StubCancel r <- calls]) <$> stubCalls cStub + +providerRef :: Ctx -> InvoiceId -> IO Text +providerRef Ctx {cStore} invId = maybe (error "no invoice row") irProviderRef <$> getInvoice cStore invId + +seconds :: UTCTime -> Word64 +seconds = floor . utcTimeToPOSIXSeconds + +btc :: ServicePaymentMethod +btc = SPMCrypto CCBtc + +-- tests + +testCoveredSpend :: IO () +testCoveredSpend = withSpend $ \ctx -> do + src <- sourceOf ctx "src" 15000 + rid <- registrationAnswer . snd <$> spend ctx src (covered 15000) + 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) + 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 + exact <- sourceOf ctx "exact" 20000 + rid' <- registrationAnswer . snd <$> spend ctx exact (dynamis 20000 Nothing) + nrBalanceUsed <$> registrationById ctx rid' `shouldReturn` 20000 + fmap (\b -> (blAmount b, blHold b)) <$> balanceOf ctx exact `shouldReturn` Just (0, Nothing) + stubCalls (cStub ctx) `shouldReturn` [] + +testDifferenceSpend :: IO () +testDifferenceSpend = withSpend $ \ctx -> do + src <- sourceOf ctx "src" 6000 + (status, v) <- spend ctx src (difference 6000) + status `shouldBe` 200 + let expiry = addUTCTime (45 * 60) orderTime + r = registrationOf <$> v + (field "status" =<< v, field "amount" =<< v, field "expiresAt" =<< v) `shouldBe` (Just "open", Just (J.Number 4000), Just (J.toJSON expiry)) + (field "phase" =<< r, field "price" =<< r, field "fromBalance" =<< r) `shouldBe` (Just "unpaid", Just (J.Number 10000), Just (J.Number 6000)) + stubCalls (cStub ctx) `shouldReturn` [StubCreate btc OrderDraft {odAmount = CurrencyAmount 4000, odCurrency = "usd"}] + let invId = invoiceIdOf v + 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)) + 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)]) + +testSpendResend :: IO () +testSpendResend = withSpend $ \ctx@Ctx {cStore, cClock} -> do + src <- sourceOf ctx "src" 6000 + body <- spendBody ctx src (difference 6000) + (200, first') <- postSpend ctx src body + let invId = invoiceIdOf first' + credit cStore "src" 1000 + advance ctx 60 + spend ctx src (difference 6000) {sbOrder = aliceOrder {oTimestamp = seconds orderTime + 60}} `shouldReturn` (200, first') + advance ctx 700 + postSpend ctx src body `shouldReturn` (200, first') + holder <- invoiceRegistration ctx invId + now <- readIORef cClock + Written _ <- withTransaction cStore $ \db -> updateRegistration db holder {nrPhase = PQueued} now + (\(status, v) -> (status, invoiceIdOf v, field "phase" . registrationOf =<< v)) <$> postSpend ctx src body `shouldReturn` (200, invId, Just "queued") + other <- sourceOf ctx "other" 25000 + let paid = timedAt now $ dynamis 25000 Nothing + coveredBody <- spendBody ctx other paid + (200, answer) <- postSpend ctx other coveredBody + r <- registrationById ctx $ registrationAnswer answer + spend ctx other paid {sbOrder = (sbOrder paid) {oTimestamp = seconds now + 1}} `shouldReturn` (200, answer) + Written _ <- withTransaction cStore $ \db -> updateRegistration db r {nrPhase = PCommitted, nrRevealAfter = Just (seconds now), nrRevealBefore = Just (seconds now + 86400)} now + advance ctx 3600 + postSpend ctx other coveredBody `shouldReturn` (200, answer) + length <$> stubCalls (cStub ctx) `shouldReturn` 1 + amountOf ctx other `shouldReturn` Just 5000 + +testInvoiceBodyApart :: IO () +testInvoiceBodyApart = withSpend $ \ctx -> do + src <- sourceOf ctx "src" 6000 + fst <$> spend ctx src (difference 6000) `shouldReturn` 200 + placeOrder ctx aliceOrder `shouldReturn` refusedWith 409 "order_exists" + fst <$> placeOrder ctx dynamisOrder `shouldReturn` 200 + other <- sourceOf ctx "other" 30000 + spend ctx other (dynamis 30000 Nothing) `shouldReturn` refusedWith 409 "order_exists" + amountOf ctx other `shouldReturn` Just 30000 + +testBalanceChanged :: IO () +testBalanceChanged = withSpend $ \ctx -> do + src <- sourceOf ctx "src" 10000 + stale <- balanceOf ctx src + spend ctx src (covered 12000) `shouldReturn` balanceChanged stale + spend ctx src (difference 9000) `shouldReturn` balanceChanged stale + held <- sourceOf ctx "held" 6000 + fst <$> spend ctx held (dynamis 6000 (Just "btc")) `shouldReturn` 200 + holding <- balanceOf ctx held + (fmap bhUntil . blHold =<< holding, fmap bhOverdue . blHold =<< holding) `shouldBe` (Just (addUTCTime (45 * 60) orderTime), Just False) + spend ctx held (difference 6000) `shouldReturn` balanceChanged holding + placePaid (cStore ctx) "none" ownerA (order "source-none" 3) (at 60) `shouldReturn` Right () + spend ctx (RegistrationId "none") (covered 10000) `shouldReturn` balanceChanged Nothing + length <$> stubCalls (cStub ctx) `shouldReturn` 1 + paidFrom ctx src `shouldReturn` [] + +testMethodRule :: IO () +testMethodRule = withSpend $ \ctx -> do + src <- sourceOf ctx "src" 6000 + good <- spendBody ctx src (difference 6000) + let with :: J.Key -> J.Value -> J.Object + with k v = KM.insert k v good + mapM_ + (\body -> postSpend ctx src body `shouldReturn` refusedWith 400 "bad_request") + [ KM.delete "method" good, + with "method" "eth", + with "method" J.Null, + with "price" (J.Number 0), + with "price" (J.Number 100.5), + with "balance" (J.Number 0), + with "balance" (J.Number (-1)), + KM.delete "balance" good + ] + spend ctx src (covered 6000) {sbOrder = aliceOrder {oPrice = 6000}, sbMethod = Just "btc"} `shouldReturn` refusedWith 400 "bad_request" + spend ctx src (difference 6000) {sbMethod = Nothing} `shouldReturn` refusedWith 400 "bad_request" + mapM_ (\len -> postSpend ctx src (with "length" (J.Number len)) `shouldReturn` refusedWith 400 "invalid_name") [5, 64] + stubCalls (cStub ctx) `shouldReturn` [] + amountOf ctx src `shouldReturn` Just 6000 + +testSignerAndId :: IO () +testSignerAndId = withSpend $ \ctx -> do + src <- sourceOf ctx "src" 15000 + spend ctx src (covered 15000) {sbOrder = aliceOrder {oKey = keyB}} `shouldReturn` refusedWith 400 "bad_request" + mapM_ + (\offset -> spend ctx src (covered 15000) {sbOrder = aliceOrder {oTimestamp = fromInteger (toInteger (seconds orderTime) + offset)}} `shouldReturn` refusedWith 400 "bad_request") + [-601, 601] + spend ctx (RegistrationId "unknown") (covered 15000) `shouldReturn` refusedWith 404 "not_found" + amountOf ctx src `shouldReturn` Just 15000 + paidFrom ctx src `shouldReturn` [] + +testOrderChecks :: IO () +testOrderChecks = withSpend $ \ctx@Ctx {cNode = node, cStub} -> do + src <- sourceOf ctx "src" 30000 + answerCall node fakeController reservedNamesCall $ Returns $ uint256 (1 :: Int) + spend ctx src (covered 30000) `shouldReturn` refusedWith 409 "name_taken" + answerCall node fakeController reservedNamesCall $ Returns $ uint256 (0 :: Int) + spend ctx src (covered 30000) {sbOrder = aliceOrder {oPrice = 9000}} `shouldReturn` (409, Just $ KM.fromList [("error", "catalog_changed"), ("price", J.Number 10000)]) + setFault node "eth_getBlockByNumber" HttpFailure + spend ctx src (covered 30000) `shouldReturn` refusedWith 503 "name_check_unavailable" + clearFault node "eth_getBlockByNumber" + low <- sourceOf ctx "low" 6000 + modifyIORef' cStub $ \s -> s {ssCreateResult = Left (ProviderError "down")} + spend ctx low (difference 6000) `shouldReturn` refusedWith 503 "provider_unavailable" + modifyIORef' cStub $ \s -> s {ssCreateResult = Right sampleProviderInvoice} + fst <$> placeOrder ctx aliceOrder `shouldReturn` 200 + spend ctx src (covered 30000) {sbOrder = aliceOrder {oCommitment = commitmentOf 3}} `shouldReturn` refusedWith 409 "order_exists" + mapM (amountOf ctx) [src, low] `shouldReturn` [Just 30000, Just 6000] + mapM (paidFrom ctx) [src, low] `shouldReturn` [[], []] + +-- | Each request fails two checks, and is answered by the earlier. +testCheckOrder :: IO () +testCheckOrder = withSpend $ \ctx@Ctx {cNode = node, cStub} -> do + src <- sourceOf ctx "src" 30000 + low <- sourceOf ctx "low" 6000 + let unknown = RegistrationId "unknown" + unsealed <- KM.delete "sealed" <$> spendBody ctx unknown (covered 30000) + postSpend ctx unknown unsealed `shouldReturn` refusedWith 400 "bad_request" + spend ctx unknown (covered 30000) {sbOrder = aliceOrder {oKey = keyB}} `shouldReturn` refusedWith 404 "not_found" + answerCall node fakeController reservedNamesCall $ Returns $ uint256 (1 :: Int) + spend ctx src (covered 31000) {sbOrder = aliceOrder {oTimestamp = seconds orderTime + 601}} `shouldReturn` refusedWith 400 "bad_request" + stale <- balanceOf ctx src + spend ctx src (covered 31000) `shouldReturn` balanceChanged stale + spend ctx src (covered 30000) {sbOrder = aliceOrder {oPrice = 9000}} `shouldReturn` refusedWith 409 "name_taken" + answerCall node fakeController reservedNamesCall $ Returns $ uint256 (0 :: Int) + modifyIORef' cStub $ \s -> s {ssCreateResult = Left (ProviderError "down")} + spend ctx low (difference 6000) {sbOrder = aliceOrder {oPrice = 9000}} `shouldReturn` (409, Just $ KM.fromList [("error", "catalog_changed"), ("price", J.Number 10000)]) + modifyIORef' cStub $ \s -> s {ssCreateResult = Right sampleProviderInvoice} + fst <$> spend ctx src (covered 30000) `shouldReturn` 200 + spend ctx src (covered 30000) {sbOrder = aliceOrder {oKey = keyB}} `shouldReturn` refusedWith 400 "bad_request" + spend ctx src (covered 31000) {sbOrder = aliceOrder {oCommitment = commitmentOf 3}} `shouldReturn` refusedWith 409 "order_exists" + amountOf ctx src `shouldReturn` Just 20000 + +testSpendSizes :: IO () +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" + 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" + longest <- spendBody ctx src (covered 15000) {sbOrder = aliceOrder {oSealed = T.replicate 11095 "a"}} + LB.length (J.encode longest) `shouldSatisfy` (< 16384) + fst <$> postSpend ctx src longest `shouldReturn` 200 + +testSpendLimit :: IO () +testSpendLimit = withSpend $ \Ctx {cClient} -> do + let attempt = statusOf <$> webRequestBody cClient "POST" "/api/registration/src/spend" [(hContentType, "application/json"), ("X-Forwarded-For", "203.0.113.9")] "{}" + replicateM_ 5 $ attempt `shouldReturn` 400 + attempt `shouldReturn` 429 + +testOverdueHolderSpent :: IO () +testOverdueHolderSpent = withSpend $ \ctx@Ctx {cStore, cClock} -> do + src <- sourceOf ctx "src" 10000 + -- by card, whose invoice does not expire by itself at the provider, past its 60 minutes + (200, held) <- spend ctx src (dynamis 10000 (Just "card")) + let holderInv = invoiceIdOf held + holder <- invoiceRegistration ctx holderInv + holderRef <- providerRef ctx holderInv + advance ctx (61 * 60) + now <- readIORef cClock + poll <- heldPoll ctx holder + rid <- registrationAnswer . snd <$> spend ctx src (timedAt now $ covered 10000) + (\(status, v) -> (status, field "version" v)) <$> woken poll `shouldReturn` (200, Just (J.toJSON $ nrVersion holder + 1)) + fmap irStatus <$> getInvoice cStore holderInv `shouldReturn` Just ISExpired + (\r -> (nrLive r, nrVersion r)) <$> invoiceRegistration ctx holderInv `shouldReturn` (False, nrVersion holder + 1) + cancels ctx `shouldReturn` [holderRef] + (\r -> (nrPhase r, nrBalanceUsed r)) <$> registrationById ctx rid `shouldReturn` (PQueued, 10000) + fmap (\b -> (blAmount b, blHold b)) <$> balanceOf ctx src `shouldReturn` Just (0, Nothing) + +testHolderCancelledMeanwhile :: IO () +testHolderCancelledMeanwhile = withSpendHook $ \hook ctx@Ctx {cStore, cWeb, cClock} -> do + src <- sourceOf ctx "src" 6000 + (200, held) <- spend ctx src (difference 6000) + let holderInv = invoiceIdOf held + advance ctx (46 * 60) + now <- readIORef cClock + onCreate hook $ cancelOpenInvoice cStore (weWaiters cWeb) Nothing holderInv now `shouldReturn` True + (status, v) <- spend ctx src (timedAt now $ dynamis 6000 (Just "btc")) + status `shouldBe` 200 + next <- invoiceRegistration ctx (invoiceIdOf v) + fmap irStatus <$> getInvoice cStore holderInv `shouldReturn` Just ISExpired + fmap (fmap bhHolder . blHold) <$> balanceOf ctx src `shouldReturn` Just (Just $ nrId next) + cancels ctx `shouldReturn` [] + +testHolderFundedMeanwhile :: IO () +testHolderFundedMeanwhile = withSpendHook $ \hook ctx@Ctx {cStore, cClock} -> do + src <- sourceOf ctx "src" 6000 + (200, held) <- spend ctx src (difference 6000) + let holderInv = invoiceIdOf held + holder <- invoiceRegistration ctx holderInv + holderRef <- providerRef ctx holderInv + advance ctx (46 * 60) + now <- readIORef cClock + onCreate hook $ settleNow ctx holderInv (SigFunded (rcv 4000 (Just "0.0006")) PaidInFull) `shouldReturn` Right ISOpen + answer <- spend ctx src (timedAt now $ dynamis 6000 (Just "btc")) + current <- balanceOf ctx src + answer `shouldBe` balanceChanged current + (fmap blAmount current, fmap bhHolder . blHold =<< current) `shouldBe` (Just 6000, Just $ nrId holder) + calls <- stubCalls (cStub ctx) + length [() | StubCreate {} <- calls] `shouldBe` 2 + refs <- cancels ctx + length refs `shouldBe` 1 + refs `shouldNotBe` [holderRef] + (fmap irStatus <$> getInvoice cStore holderInv) `shouldReturn` Just ISOpen + nrLive <$> invoiceRegistration ctx holderInv `shouldReturn` True + length <$> paidFrom ctx src `shouldReturn` 1 + +testConcurrentSpends :: IO () +testConcurrentSpends = withSpend $ \ctx -> do + src <- sourceOf ctx "src" 30000 + (a, b) <- concurrently (spend ctx src (covered 30000)) (spend ctx src (dynamis 30000 Nothing)) + sort [fst a, fst b] `shouldBe` [200, 409] + [won] <- paidFrom ctx src + current <- balanceOf ctx src + fmap blAmount current `shouldBe` Just (30000 - nrPrice won) + filter ((== 409) . fst) [a, b] `shouldBe` [balanceChanged current] + +testWriteRefusedAtBalance :: IO () +testWriteRefusedAtBalance = withSpendHook $ \hook ctx@Ctx {cOpenStore} -> do + src <- sourceOf ctx "src" 6000 + other <- cOpenStore + onCreate hook $ credit other "src" 500 + answer <- spend ctx src (difference 6000) + current <- balanceOf ctx src + (fmap blAmount current, blHold =<< current) `shouldBe` (Just 6500, Nothing) + answer `shouldBe` balanceChanged current + calls <- stubCalls (cStub ctx) + [() | StubCreate {} <- calls] `shouldBe` [()] + length <$> cancels ctx `shouldReturn` 1 + paidFrom ctx src `shouldReturn` [] + +testSpendRacesRefund :: IO () +testSpendRacesRefund = withSpend $ \ctx@Ctx {cStore, cOrders, cClock} -> do + src <- sourceOf ctx "src" 10000 + now <- readIORef cClock + (spent, refunded) <- concurrently (spend ctx src (covered 10000)) (recordRefund (oeTurns cOrders) cStore "src" 10000 now) + current <- balanceOf ctx src + fmap blAmount current `shouldBe` Just 0 + case refunded of + Right _ -> do + spent `shouldBe` balanceChanged current + paidFrom ctx src `shouldReturn` [] + fmap blRefunded current `shouldBe` Just 10000 + Left refusal -> do + (fst spent, refusal) `shouldBe` (200, RefundAmount 0) + length <$> paidFrom ctx src `shouldReturn` 1 + fmap blRefunded current `shouldBe` Just 0 + +testSpendTurns :: IO () +testSpendTurns = withSpend $ \ctx@Ctx {cOrders} -> do + src <- sourceOf ctx "src" 15000 + let turns = oeTurns cOrders + inside <- newEmptyMVar + proceed <- newEmptyMVar + holding <- async $ withBalanceTurn turns src $ putMVar inside () >> takeMVar proceed + takeMVar inside + spent <- async $ spend ctx src (covered 15000) + -- the spend waits for the balance's turn while it holds the name's + waiting <- timeout pollSeconds $ atomically $ do + balanceTurn <- balanceTurnCount turns src + nameTurn <- labelTurnCount turns (labelHash "alicebakery") + check (balanceTurn == 2 && nameTurn == 1) + waiting `shouldBe` Just () + putMVar proceed () + wait holding + fst <$> wait spent `shouldReturn` 200 diff --git a/tests/Test.hs b/tests/Test.hs index ceccb86c99..361f3d83d3 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -25,6 +25,7 @@ import Bots.StoreService.NamesRevealTests import Bots.StoreService.NamesSearchTests import Bots.StoreService.NamesSenderTests import Bots.StoreService.NamesSignatureTests +import Bots.StoreService.NamesSpendTests import Bots.StoreService.NamesStoreTests import Bots.StoreService.NamesWiringTests import Bots.StoreService.NamesWorkerTests @@ -120,6 +121,7 @@ main = do namesSearchTests namesSenderTests namesSignatureTests + namesSpendTests namesStoreTests namesWiringTests namesWorkerTests