diff --git a/apps/simplex-store-service/src/StoreService/Orders.hs b/apps/simplex-store-service/src/StoreService/Orders.hs index f790c77fff..55343bac6e 100644 --- a/apps/simplex-store-service/src/StoreService/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Orders.hs @@ -85,7 +85,7 @@ data Published = PubNothing | PubStatus InvoiceStatus | PubPayment -- | What the invoice pays for, read before any write. data Product = PBadge (Maybe ByteString) | PName NameRegistration --- | A name order's change at settlement: its new version, or a payment after it closed, which stays unpaid. +-- | A name order's change at settlement: its new version, or money received after it closed, which stays unpaid. data NameOutcome = NOWritten RegistrationId Int64 | NOLate RegistrationId settleOrder :: DBStore -> Waiters -> Maybe Phases -> InvoiceId -> PaymentSignal -> UTCTime -> IO (Either Text InvoiceStatus) @@ -94,7 +94,7 @@ settleOrder st waiters phases invId@(InvoiceId invText) signal now' = do settlementInvoice db invId >>= \case Nothing -> pure (Left "no such invoice") Just row@InvoiceRow {irStatus} -> case decide irStatus signal of - Nothing -> pure (Right (irStatus, PubNothing, Nothing)) + Nothing -> pure (Right (irStatus, PubNothing, [])) -- read the product first, so an invoice without one leaves the transaction empty, not paid with nothing to show for it Just w -> productOf db row w >>= either (pure . Left) (settle db row w) case outcome of @@ -139,7 +139,7 @@ settleOrder st waiters phases invId@(InvoiceId invText) signal now' = do where Received {rcvAmount, rcvCrypto} = received signal CurrencyAmount minor = rcvAmount - settle :: DB.Connection -> InvoiceRow -> Write -> Product -> IO (Either Text (InvoiceStatus, Published, Maybe NameOutcome)) + settle :: DB.Connection -> InvoiceRow -> Write -> Product -> IO (Either Text (InvoiceStatus, Published, [NameOutcome])) settle db row@InvoiceRow {irStatus} w@Write {wStatus, wPayment} sold = do let Received {rcvAmount, rcvCrypto, rcvDue} = received signal wrotePayment = newPayment row w @@ -148,28 +148,32 @@ settleOrder st waiters phases invId@(InvoiceId invText) signal now' = do if moved then do name <- case sold of - PBadge codeHash -> Nothing <$ mapM_ (\h -> markCodePaid db h (addUTCTime codeLifetime at)) codeHash - PName r -> nameSettled db irStatus wStatus r now + PBadge codeHash -> [] <$ mapM_ (\h -> markCodePaid db h (addUTCTime codeLifetime at)) codeHash + PName r -> nameSettled db irStatus wStatus wrotePayment r now pure (Right (fromMaybe irStatus wStatus, maybe (if wrotePayment then PubPayment else PubNothing) PubStatus wStatus, name)) else do -- another writer moved the row first, so publish what we found current <- maybe irStatus (\InvoiceRow {irStatus = s} -> s) <$> settlementInvoice db invId - pure (Right (current, PubStatus current, Nothing)) + pure (Right (current, PubStatus current, [])) -- | A paid open invoice queues its order only while the order is live; a payment of a closed one is late. --- An invoice the provider closed closes its order. -nameSettled :: DB.Connection -> InvoiceStatus -> Maybe InvoiceStatus -> NameRegistration -> UTCTime -> IO (Maybe NameOutcome) -nameSettled db before after r@NameRegistration {nrId, nrPhase} now = case after of - Just ISPaid - | nrPhase /= PUnpaid -> pure Nothing - | before /= ISOpen -> pure (Just (NOLate nrId)) - | otherwise -> - updateRegistration db r {nrPhase = PQueued} now >>= \case - Written v -> pure (Just (NOWritten nrId v)) - NotLive -> pure (Just (NOLate nrId)) - _ -> E.throwIO (RegistrationChanged nrId) - Just ISExpired -> fmap (uncurry NOWritten) <$> closeOrder db r now - _ -> pure Nothing +-- An invoice the provider closed closes its order. BTCPay reports money paid into a closed invoice as Expired or Invalid, +-- not Settled, so a new payment figure on a closed invoice is late too; the monotonic payment write reports each figure once. +nameSettled :: DB.Connection -> InvoiceStatus -> Maybe InvoiceStatus -> Bool -> NameRegistration -> UTCTime -> IO [NameOutcome] +nameSettled db before after wrotePayment r@NameRegistration {nrId, nrPhase} now + | nrPhase /= PUnpaid = pure [] + | otherwise = case after of + Just ISPaid + | before /= ISOpen -> pure [NOLate nrId] + | otherwise -> + updateRegistration db r {nrPhase = PQueued} now >>= \case + Written v -> pure [NOWritten nrId v] + NotLive -> pure [NOLate nrId] + _ -> E.throwIO (RegistrationChanged nrId) + Just ISExpired -> (<> late) . maybe [] (\(rid, v) -> [NOWritten rid v]) <$> closeOrder db r now + _ -> pure $ if before /= ISOpen then late else [] + where + late = [NOLate nrId | wrotePayment] -- | Clears a live unpaid order's live flag, as its invoice closes in the same transaction. closeOrder :: DB.Connection -> NameRegistration -> UTCTime -> IO (Maybe (RegistrationId, Int64)) diff --git a/tests/Bots/StoreService/NamesOrdersTests.hs b/tests/Bots/StoreService/NamesOrdersTests.hs index 5dd7d1cf39..d5b84d7cad 100644 --- a/tests/Bots/StoreService/NamesOrdersTests.hs +++ b/tests/Bots/StoreService/NamesOrdersTests.hs @@ -4,6 +4,7 @@ module Bots.StoreService.NamesOrdersTests (namesOrdersTests) where +import Bots.StoreService.FakeBTCPay (FakeBTCPay (..), setInvoiceState, withFakeBTCPay) import Bots.StoreService.FakeEthNode import Bots.StoreService.NamesContractsTests (alice, answerRegistered, answerRegistrar, launchPricesAnswer, nameExpiresCall, noncesCall, oracle, pricesCall, registrarOf, rentPriceAnswer, rentPriceCall, reservedNamesCall, unhex) import Bots.StoreService.NamesStoreTests (issue, order, ownerA, ownerB, placeCode, placePaid, t0, usable) @@ -14,6 +15,7 @@ import Control.Concurrent.STM (TVar) import qualified Control.Exception as E import Control.Monad (forM_, void) import Crypto.Random (ChaChaDRG) +import Data.Aeson ((.=)) import qualified Data.Aeson as J import qualified Data.Aeson.Key as K import qualified Data.Aeson.KeyMap as KM @@ -52,8 +54,9 @@ import StoreService.Names.Signatures (OrderFields (..), orderMessage, personalDi import StoreService.Names.Store import StoreService.Names.Turns (newTurns) import StoreService.Names.View (ViewReads (..), readViewChain, viewJSON) -import StoreService.Orders (expireOverdue, settleOrder) -import StoreService.Poller (cleanupUnpaid, newPollerEnv, newReadHints, unpaidRetention) +import StoreService.Orders (cancelOpenInvoice, expireOverdue, settleOrder) +import StoreService.Poller (cleanupUnpaid, drainHints, newPollerEnv, newReadHints, queueReadHint, unpaidRetention) +import StoreService.Providers.BTCPay (btcpayProvider) import StoreService.Providers (Funded (..), OrderDraft (..), PaymentSignal (..), Provider (..), ProviderError (..), ProviderInvoice (..)) import StoreService.Store.Invoices (InvoicePayment (..), InvoiceProduct (..), InvoiceRow (..), OverdueInvoice (..), ProviderRefConflict (..), getInvoice, getInvoiceByProviderRef, overdueInvoices, unpaidRefs) import StoreService.Waiters (newWaiters) @@ -87,6 +90,7 @@ namesOrdersTests = describe "StoreService names: 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 it "records a payment of the closed order as a late payment, leaving the newer order alone" testLatePaymentAfterNewOrder + it "alerts on a late payment as BTCPay reports it for an expired, cancelled or swept invoice, once" testLateBTCPayPayments it "answers cancel with funded, not_open, paid when settlement won, and expired with the payment read meanwhile" testCancelAnswers it "leaves a late payment of a cancelled invoice unpaid and alerts" testLatePayment it "queues an order settled while open and publishes its version" testSettlementQueues @@ -225,7 +229,11 @@ freshRefs counter p = p {pCreateInvoice = \method draft -> pCreateInvoice p meth _ -> pinv {piProviderRef = ref} withOrders :: (Ctx -> IO a) -> IO a -withOrders action = withServiceStore $ \cStore -> withFakeEthNode $ \cNode -> do +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 cRandom <- C.newRandom ct <- newContracts TLDSimplex =<< newChainClient cRandom (fakeChainConfig cNode) turns <- newTurns @@ -240,8 +248,8 @@ withOrders action = withServiceStore $ \cStore -> withFakeEthNode $ \cNode -> do staticDir <- prepareStaticDir root let cfg = (testServiceConfig staticDir True) {btcpay = Just testBTCPayConfig} cOrders = OrdersEnv {oeStore = cStore, oeConfig = testNamesConfig cNode, oeContracts = ct, oeTurns = turns, oePhases = phases, oeNow = readIORef cClock} - crypto = freshRefs counter (stubProvider cStub) - card = freshRefs counter (stubProvider cStub) {pProvider = PPStripe} + crypto = via $ freshRefs counter (stubProvider cStub) + card = via $ freshRefs counter (stubProvider cStub) {pProvider = PPStripe} waiters <- newWaiters hints <- newReadHints built <- newWebEnv cStore cfg waiters hints [crypto, card] Nothing @@ -583,6 +591,37 @@ testLatePaymentAfterNewOrder = withOrders $ \ctx -> do settleNow ctx newInv settled `shouldReturn` Right ISPaid (nrPhase <$> invoiceRegistration ctx newInv) `shouldReturn` PQueued +-- | The real BTCPay adapter against the fake: a payment into an expired invoice reads Expired with PaidLate, +-- into a cancelled one Invalid, and into one only we closed New and paid in part. +testLateBTCPayPayments :: IO () +testLateBTCPayPayments = withFakeBTCPay $ \fake -> do + btcpay <- btcpayProvider (fbConfig fake) + withOrdersVia (const btcpay) $ \ctx@Ctx {cStore = st, cWeb} -> do + poller <- newPollerEnv st (weWaiters cWeb) (Just $ oePhases $ cOrders ctx) (weHints cWeb) (weProviders cWeb) (poll $ weConfig cWeb) + let refOf inv = maybe (error "no invoice") irProviderRef <$> getInvoice st inv + readAt ref = queueReadHint (weHints cWeb) ref >> drainHints poller + paidLate ref fields = capturingStderr $ setInvoiceState fake ref fields >> readAt ref + alerted logs = T.isInfixOf "stays unpaid; refund the payment" logs + later = addUTCTime 3600 orderTime + (expired, _) <- placed ctx aliceOrder + expiredRef <- refOf expired + setInvoiceState fake expiredRef ["status" .= ("Expired" :: Text)] + readAt expiredRef + (irStatus <$>) <$> getInvoice st expired `shouldReturn` Just ISExpired + paidLate expiredRef ["additionalStatus" .= ("PaidLate" :: Text), "paymentMethodPaid" .= ("0.00050000" :: Text)] >>= (`shouldSatisfy` alerted) + capturingStderr (readAt expiredRef) >>= (`shouldNotSatisfy` alerted) + (cancelled, _) <- placed ctx aliceOrder {oLabel = "dynamis", oPrice = 20000, oCommitment = commitmentOf 2} + cancelledRef <- refOf cancelled + cancelOpenInvoice st (weWaiters cWeb) (Just $ oePhases $ cOrders ctx) cancelled later `shouldReturn` True + paidLate cancelledRef ["status" .= ("Invalid" :: Text), "paymentMethodPaid" .= ("0.00078000" :: Text)] >>= (`shouldSatisfy` alerted) + (swept, _) <- placed ctx aliceOrder {oOwner = ownerBText, oKey = keyB, oCommitment = commitmentOf 3} + sweptRef <- refOf swept + expireOverdue st (weWaiters cWeb) (Just $ oePhases $ cOrders ctx) later later [swept] `shouldReturn` [swept] + paidLate sweptRef ["paymentMethodPaid" .= ("0.00025000" :: Text)] >>= (`shouldSatisfy` alerted) + forM_ [expired, cancelled, swept] $ \inv -> do + r <- invoiceRegistration ctx inv + (nrPhase r, nrLive r) `shouldBe` (PUnpaid, False) + testCancelAnswers :: IO () testCancelAnswers = withOrders $ \ctx -> do let cancel = cancelAt ctx