diff --git a/apps/simplex-store-service/src/StoreService/Web/Http.hs b/apps/simplex-store-service/src/StoreService/Web/Http.hs index 097a98a442..7f647c8187 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Http.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Http.hs @@ -36,6 +36,8 @@ module StoreService.Web.Http nameBodyBytes, parseCodeHash, invoicePairs, + invoiceAt, + expiryMoment, destinationPairs, amountJSON, confirmationsFor, @@ -71,7 +73,7 @@ import Simplex.Chat.PaymentService.Types (CardProvider (..), CurrencyAmount (..) import Simplex.Messaging.Util (safeDecodeUtf8) import StoreService.Config (BTCPayConfig (..), ListenerConfig (..), ServiceConfig (..), SpeedPolicy (..), StripeConfig (..), defaultExpiryMinutes, defaultSessionMinutes) import StoreService.Providers (Provider (..)) -import StoreService.Store.Invoices (InvoicePayment (..), InvoiceRow (..), cryptoCurrencyText, invoiceStatusText) +import StoreService.Store.Invoices (InvoicePayment (..), InvoiceRow (..), cryptoCurrencyText, invoiceStatusText, paymentHolds) import Text.Read (readMaybe) data HttpEnv = HttpEnv @@ -301,6 +303,18 @@ parseCodeHash t where canonical = T.filter (/= '=') . safeDecodeUtf8 . B64U.encode +-- | An open name invoice past its expiry with no money received reads expired before the sweep marks it. +invoiceAt :: UTCTime -> InvoiceRow -> InvoiceRow +invoiceAt now row = case expiryMoment row of + Just expiry | now > expiry -> row {irStatus = ISExpired} + _ -> row + +-- | A funded open invoice stays open until it settles. +expiryMoment :: InvoiceRow -> Maybe UTCTime +expiryMoment InvoiceRow {irStatus, irExpiresAt, irPayment} + | irStatus == ISOpen && not (maybe False paymentHolds irPayment) = Just irExpiresAt + | otherwise = Nothing + -- | The fields every invoice view has, a badge's and a name's. invoicePairs :: Maybe Int -> InvoiceRow -> [Pair] invoicePairs confirmations InvoiceRow {irAmount, irCurrency, irDestination, irExpiresAt, irStatus, irPayment} = 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 588ca9dec5..38fc5a70c6 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs @@ -35,8 +35,9 @@ 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, invoicePairs, invoiceWindow, jsonError, jsonResponse, nameBodyBytes, notFound, 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) +import StoreService.Web.Names.Registration (registrationAt) data InvoiceOrder = InvoiceOrder { ioRequest :: OrderRequest, @@ -76,15 +77,15 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters now <- oeNow let hash = orderHash orOwner orFields (OTInvoice ioMethod $ fromIntegral ioPrice) withTransaction oeStore (\db -> existingOrder db req hash now) >>= \case - EOResent r -> answerResend r + EOResent r -> answerResend now r EOMeets -> refuse OROrderExists EONew _ -> newOrder order where refuse refusal = do logInfo ("POST /api/invoice (name) refused: " <> tshow refusal) pure $ answerNow $ orderRefusalResponse refusal - answerResend r@NameRegistration {nrPayment} = case nrPayment of - RPInvoice _ invId -> getInvoice oeStore invId >>= maybe (refuse OROrderExists) (fmap answerNow . viewOf r) + answerResend now r@NameRegistration {nrPayment} = case nrPayment of + RPInvoice _ invId -> getInvoice oeStore invId >>= maybe (refuse OROrderExists) (fmap answerNow . viewOf (registrationAt now r) . invoiceAt now) RPCode _ -> refuse OROrderExists 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 @@ -222,11 +223,12 @@ nameInvoiceView OrdersEnv {oeStore, oeConfig, oeContracts} confirmations row@Inv -- | The registration's current view, for a request that lost the race to change it. registrationChangedResponse :: OrdersEnv -> RegistrationId -> IO Response -registrationChangedResponse OrdersEnv {oeStore, oeConfig, oeContracts} rid = +registrationChangedResponse OrdersEnv {oeStore, oeConfig, oeContracts, oeNow} rid = withTransaction oeStore (`getRegistration` rid) >>= \case Nothing -> pure notFound Just r -> do - view <- registrationView oeStore oeConfig oeContracts r + now <- oeNow + view <- registrationView oeStore oeConfig oeContracts (registrationAt now r) pure $ jsonResponse status409 $ J.object ["error" .= ("registration_changed" :: Text), "registration" .= view] orderRefusalResponse :: OrderRefusal -> Response diff --git a/apps/simplex-store-service/src/StoreService/Web/Server.hs b/apps/simplex-store-service/src/StoreService/Web/Server.hs index 68b50a6c0c..660fc00062 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Server.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Server.hs @@ -268,18 +268,6 @@ readName OrdersEnv {oeStore, oeNow} row rid = do now <- oeNow fmap (\r -> (now, invoiceAt now row, registrationAt now r)) <$> withTransaction oeStore (`getRegistration` rid) --- | An open name invoice past its expiry with no money received reads expired before the sweep marks it. -invoiceAt :: UTCTime -> InvoiceRow -> InvoiceRow -invoiceAt now row = case expiryMoment row of - Just expiry | now > expiry -> row {irStatus = ISExpired} - _ -> row - --- | A funded open invoice stays open until it settles. -expiryMoment :: InvoiceRow -> Maybe UTCTime -expiryMoment InvoiceRow {irStatus, irExpiresAt, irPayment} - | irStatus == ISOpen && not (maybe False paymentHolds irPayment) = Just irExpiresAt - | otherwise = Nothing - -- | The counter a hold watches starts at zero, so a payment recorded before this request arrived cannot wake it. samePayment :: Request -> InvoiceRow -> Bool samePayment req row = maybe True (== paymentMark row) (paidParam req) diff --git a/tests/Bots/StoreService/NamesOrdersTests.hs b/tests/Bots/StoreService/NamesOrdersTests.hs index 97c74d3708..260f40278a 100644 --- a/tests/Bots/StoreService/NamesOrdersTests.hs +++ b/tests/Bots/StoreService/NamesOrdersTests.hs @@ -101,6 +101,7 @@ namesOrdersTests = describe "StoreService names: orders" $ do it "answers an exact resend with its invoice, also with a new timestamp and signature, and after the timestamp window" testExactResend it "answers an exact resend after its order went past unpaid, before any chain read" testResendPastUnpaid it "answers an exact resend of an expired order with its expired invoice" testResendExpired + it "reads an exact resend's unpaid invoice past its expiry as expired, and its lapsed commitment as failed, writing neither" testResendReadsTime it "refuses a resend differing in any one field, or a new commitment, with a bare order_exists" testOneFieldDiffers it "refuses an order carrying another wallet's commitment without disclosing anything" testForeignCommitment it "refuses a bad signature, or another signer's" testBadSignature @@ -450,7 +451,7 @@ testExactResend = withOrders $ \ctx -> do advance ctx 60 resigned <- placed ctx aliceOrder {oTimestamp = seconds orderTime + 60} resigned `shouldBe` (invId, first') - advance ctx 3600 + advance ctx 600 postOrder ctx body `shouldReturn` (200, Just first') length <$> stubCalls (cStub ctx) `shouldReturn` 1 length <$> registrationsOf ctx ownerA `shouldReturn` 1 @@ -475,6 +476,28 @@ testResendExpired = withOrders $ \ctx -> do (field "invoiceId" =<< v) `shouldBe` Just (J.String invId) (field "status" =<< v) `shouldBe` Just "expired" +testResendReadsTime :: IO () +testResendReadsTime = do + withOrders $ \ctx -> do + (invId, _) <- placed ctx aliceOrder + advance ctx (45 * 60 + 1) + (status, v) <- placeOrder ctx aliceOrder + (status, field "status" =<< v, field "phase" . registrationOf =<< v) `shouldBe` (200, Just "expired", Just "unpaid") + fmap irStatus <$> getInvoice (cStore ctx) invId `shouldReturn` Just ISOpen + withOrders $ \ctx@Ctx {cStore, cClock} -> do + (invId, _) <- placed ctx aliceOrder + settleNow ctx invId settled `shouldReturn` Right ISPaid + r <- invoiceRegistration ctx invId + now <- readIORef cClock + let lapse = seconds now + 600 + Written version <- withTransaction cStore $ \db -> + updateRegistration db r {nrPhase = PCommitted, nrRevealAfter = Just (lapse - 3600), nrRevealBefore = Just lapse} now + let resend = (\(status, v) -> (status, field "status" =<< v, (field "phase" &&& field "error") . registrationOf <$> v)) <$> placeOrder ctx aliceOrder + resend `shouldReturn` (200, Just "paid", Just (Just "committed", Just J.Null)) + advance ctx 601 + resend `shouldReturn` (200, Just "paid", Just (Just "failed", Just "The name was not signed in time")) + (nrPhase &&& nrVersion) <$> invoiceRegistration ctx invId `shouldReturn` (PCommitted, version) + testOneFieldDiffers :: IO () testOneFieldDiffers = withOrders $ \ctx -> do void $ placed ctx aliceOrder