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 05cadd6bd2..588ca9dec5 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs @@ -55,10 +55,19 @@ parseInvoiceOrder o = do pure InvoiceOrder {ioRequest, ioMethod, ioPrice} order <$ checkLength ioRequest +-- | An order's answer and the work its commit leaves, both done after the name's turn, so a slow client holds no turn. +data Answer = Answer {aResponse :: Response, aAfter :: IO ()} + +answerNow :: Response -> Answer +answerNow aResponse = Answer {aResponse, aAfter = pure ()} + +sendAnswer :: Respond -> Answer -> IO ResponseReceived +sendAnswer respond Answer {aResponse, aAfter} = aAfter >> respond aResponse + -- | POST /api/invoice for a name, its body already read and its kind checked. nameInvoiceHandler :: OrdersEnv -> ServiceConfig -> [Provider] -> Waiters -> J.Object -> Respond -> IO ResponseReceived nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters body respond = - case parseInvoiceOrder body of + sendAnswer respond =<< case parseInvoiceOrder body of Left refusal -> refuse refusal Right order@InvoiceOrder {ioRequest = req@OrderRequest {orOwner, orFields}, ioMethod, ioPrice} -> checkOrderSigner req >>= \case @@ -73,11 +82,11 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters where refuse refusal = do logInfo ("POST /api/invoice (name) refused: " <> tshow refusal) - respond $ orderRefusalResponse refusal + pure $ answerNow $ orderRefusalResponse refusal answerResend r@NameRegistration {nrPayment} = case nrPayment of - RPInvoice _ invId -> getInvoice oeStore invId >>= maybe (refuse OROrderExists) (\row -> respondView row r) + RPInvoice _ invId -> getInvoice oeStore invId >>= maybe (refuse OROrderExists) (fmap answerNow . viewOf r) RPCode _ -> refuse OROrderExists - respondView row r = respond . jsonResponse status200 =<< nameInvoiceView env (confirmationsFor cfg) row r + viewOf r row = jsonResponse status200 <$> nameInvoiceView env (confirmationsFor cfg) row r newOrder order@InvoiceOrder {ioRequest = OrderRequest {orFields = OrderFields {ofLabelHash, ofLength, ofDuration}, orTimestamp}, ioMethod, ioPrice} = do now <- oeNow let years = nYears $ oeConfig env @@ -92,7 +101,7 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters Nothing -> case providerFor providers ioMethod of Nothing -> do logInfo ("POST /api/invoice (name) refused: no provider configured for " <> tshow ioMethod) - respond providerUnavailable + pure $ answerNow providerUnavailable Just provider -> createAtProvider order provider createAtProvider InvoiceOrder {ioRequest = req@OrderRequest {orOwner, orFields}, ioMethod, ioPrice} provider = do invId <- newInvoiceId @@ -101,7 +110,7 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters pCreateInvoice provider ioMethod OrderDraft {odAmount = amount, odCurrency = catalogCurrency} >>= \case Left (ProviderError e) -> do logError ("POST /api/invoice (name) failed: provider refused to create an invoice: " <> e) - respond providerUnavailable + pure $ answerNow providerUnavailable Right ProviderInvoice {piProviderRef, piDestination} -> do rid <- newRegistrationId let invoice = NewNameInvoice {nniInvoiceId = invId, nniProvider = pProvider provider, nniAmount = amount, nniCurrency = catalogCurrency, nniDestination = piDestination, nniExpiresAt = addUTCTime (invoiceWindow cfg ioMethod) now, nniCreatedAt = now} @@ -112,15 +121,14 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters >>= \case Left refusal -> do logWarn ("POST /api/invoice (name): the order lost to another, so invoice " <> piProviderRef <> " is cancelled at the provider") - cancelAtProvider provider piProviderRef - refuse refusal + (\a -> a {aAfter = cancelAtProvider provider piProviderRef}) <$> refuse refusal Right closed -> do - announceClosed env providers waiters closed row_ <- getInvoice oeStore invId registration_ <- withTransaction oeStore (`getRegistration` rid) - case (row_, registration_) of - (Just row, Just r) -> respondView row r - _ -> logError ("POST /api/invoice (name): order " <> invText invId <> " is not readable after its commit") >> respond internalError + response <- case (row_, registration_) of + (Just row, Just r) -> viewOf r row + _ -> internalError <$ logError ("POST /api/invoice (name): order " <> invText invId <> " is not readable after its commit") + pure Answer {aResponse = response, aAfter = announceClosed env providers waiters closed} -- An invoice created at the provider for an order that was not written would stay payable with nothing watching it. strandedBy :: Provider -> Text -> E.SomeException -> IO a strandedBy provider ref e = do @@ -133,13 +141,14 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters -- | POST /api/name/register, an order paid with a prepaid code, in the contract's order of checks. codeOrderHandler :: OrdersEnv -> [Provider] -> Waiters -> Request -> Respond -> IO ResponseReceived codeOrderHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} providers waiters req respond = - readBoundedBody nameBodyBytes req >>= \case - Just body | Just (J.Object o) <- J.decode body -> either refuse withCode (parseCodeOrder o) - _ -> refuse ORBadRequest + readBoundedBody nameBodyBytes req >>= ordered >>= sendAnswer respond where + ordered = \case + Just body | Just (J.Object o) <- J.decode body -> either refuse withCode (parseCodeOrder o) + _ -> refuse ORBadRequest refuse refusal = do logInfo ("POST /api/name/register refused: " <> tshow refusal) - respond $ orderRefusalResponse refusal + pure $ answerNow $ orderRefusalResponse refusal withCode (order, codeText) = issuedCode codeText >>= \case Nothing -> refuse $ ORCode CRInvalid @@ -150,7 +159,7 @@ codeOrderHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} signed order@OrderRequest {orOwner, orFields} code@PrepaidCode {pcCodeHash} = withLabelTurn oeTurns (ofLabelHash orFields) $ do now <- oeNow withTransaction oeStore (\db -> existingOrder db order (orderHash orOwner orFields (OTCode pcCodeHash)) now) >>= \case - EOResent NameRegistration {nrId} -> answer nrId + 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 @@ -165,8 +174,8 @@ codeOrderHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} rid <- newRegistrationId placeCodeOrder env order rid code >>= \case Left refusal -> refuse refusal - Right closed -> announceClosed env providers waiters closed >> answer rid - answer (RegistrationId rid) = respond $ jsonResponse status200 $ J.object ["registrationId" .= rid] + Right closed -> pure Answer {aResponse = registrationAnswer rid, aAfter = announceClosed env providers waiters closed} + registrationAnswer (RegistrationId rid) = jsonResponse status200 $ J.object ["registrationId" .= rid] parseCodeOrder :: J.Object -> Either OrderRefusal (OrderRequest, Text) parseCodeOrder o = do diff --git a/tests/Bots/StoreService/NamesOrdersTests.hs b/tests/Bots/StoreService/NamesOrdersTests.hs index 11b4b8e2f1..364347660c 100644 --- a/tests/Bots/StoreService/NamesOrdersTests.hs +++ b/tests/Bots/StoreService/NamesOrdersTests.hs @@ -35,6 +35,7 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) import Data.Word (Word64) import Network.HTTP.Client (defaultManagerSettings, newManager, responseBody) import Network.HTTP.Types (hContentType) +import Network.Wai (Application, requestHeaders) import qualified Network.Wai.Handler.Warp as Warp import Simplex.Chat.Badges.Code (NameCode (..), formatNameCode, namePrepaidCodeHash, randomNamePrepaidCode) import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..)) @@ -98,6 +99,7 @@ namesOrdersTests = describe "StoreService names: orders" $ do it "refuses sealed missing or over 11095 characters and a body over 16384 bytes, accepting the longest order" testSizes it "refuses malformed fields, an unknown kind, and an order outside 6-63 letters" testFormats it "accepts orders for one name from two wallets" testTwoWallets + it "answers after the name's turn, so a slow reader of one answer holds no other order for the name, paid or by code" testSlowReaderHoldsNoTurn describe "code orders" $ do it "places a code order as a queued live registration holding its code, answering only its id" testCodeOrder it "answers an exact resend with its id in any phase, the code spent or not, before any chain read" testCodeResend @@ -291,11 +293,13 @@ withOrdersVia via action = withServiceStore $ \cStore -> withFakeEthNode $ \cNod hints <- newReadHints built <- newWebEnv cStore cfg waiters hints [crypto, card] Nothing let cWeb = built {weOrders = Just cOrders} - app req respond = fromMaybe (webApp cWeb req respond) (namesApp (weHttp cWeb) (codeRoutes cOrders [crypto, card] waiters) req respond) mgr <- newManager defaultManagerSettings - Warp.testWithApplicationSettings (webSettings (listener cfg)) (pure app) $ \port -> + 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} +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) + -- | The routes as namesRoutes registers them, since a NamesEnv needs a running chat controller. codeRoutes :: OrdersEnv -> [Provider] -> Waiters -> [Text] -> Maybe Route codeRoutes orders providers waiters = \case @@ -898,6 +902,34 @@ testCodeLimitShared = withOrders $ \ctx@Ctx {cClient} -> do codeOrder `shouldReturn` 429 fst <$> register ctx code aliceOrder `shouldReturn` 200 +-- | A response held before it is written, as for a client that reads it slowly, must not hold the name's turn. +testSlowReaderHoldsNoTurn :: IO () +testSlowReaderHoldsNoTurn = withOrders $ \ctx@Ctx {cWeb, cOrders} -> do + (codeA, _) <- issueCode ctx 7 2 id + (codeB, _) <- issueCode ctx 7 2 id + writing <- newEmptyMVar + release <- newEmptyMVar + let app = ordersApp cWeb cOrders + slow req respond + | isJust (lookup slowReader $ requestHeaders req) = app req $ \r -> putMVar writing () >> takeMVar release >> respond r + | otherwise = app req respond + mgr <- newManager defaultManagerSettings + Warp.testWithApplication (pure slow) $ \port -> do + let c = ctx {cClient = (mgr, "http://127.0.0.1:" <> show port)} + slowPost path body = statusOf <$> webRequestBody (cClient c) "POST" path [(hContentType, "application/json"), (slowReader, "1")] (J.encode body) + whileHeld first second = do + held <- async first + takeMVar writing + timeout 2000000 second >>= (`shouldSatisfy` maybe False ((== 200) . fst)) + putMVar release () + wait held `shouldReturn` 200 + byB o = o {oOwner = ownerBText, oKey = keyB, oCommitment = commitmentOf 2} + whileHeld (signedBody (cRandom c) aliceOrder >>= slowPost "/api/invoice") (placeOrder c $ byB aliceOrder) + let dynamis = aliceOrder {oLabel = "dynamis", oCommitment = commitmentOf 3} + whileHeld (signedCodeBody c codeA dynamis >>= slowPost "/api/name/register") (register c codeB (byB dynamis) {oCommitment = commitmentOf 4}) + where + slowReader = "x-slow-reader" + testOrderAfterCancel :: IO () testOrderAfterCancel = withOrders $ \ctx -> do (invId@(InvoiceId invText), _) <- placed ctx aliceOrder