diff --git a/apps/simplex-store-service/src/StoreService/Orders.hs b/apps/simplex-store-service/src/StoreService/Orders.hs index a1b2c4ad76..73c756a32c 100644 --- a/apps/simplex-store-service/src/StoreService/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Orders.hs @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} module StoreService.Orders ( RegistrationChanged (..), @@ -88,7 +89,7 @@ data Product = PBadge (Maybe ByteString) | PName NameRegistration data NameOutcome = NOWritten RegistrationId Int64 | NOLate RegistrationId settleOrder :: DBStore -> Waiters -> Maybe Phases -> InvoiceId -> PaymentSignal -> UTCTime -> IO (Either Text InvoiceStatus) -settleOrder st waiters phases invId@(InvoiceId invText) signal now' = do +settleOrder st waiters phases invId signal now' = do outcome <- withTransaction st $ \db -> settlementInvoice db invId >>= \case Just InvoiceRow {irStatus} @@ -111,7 +112,7 @@ settleOrder st waiters phases invId@(InvoiceId invText) signal now' = do NOWritten rid v -> publishRegistration phases (rid, v) NOLate _ -> pure () forM_ name $ \case - NOLate (RegistrationId rid) -> logError ("names: invoice " <> invText <> " was paid after its order closed, so registration " <> rid <> " stays unpaid; refund the payment") + NOLate rid -> latePayment invId rid NOWritten {} -> pure () pure (Right status) where @@ -199,14 +200,30 @@ closeInvoiceOrder db invId now = Just InvoiceRow {irProduct = IPName rid} -> getRegistration db rid >>= maybe (pure Nothing) (\r -> closeOrder db r now) _ -> pure Nothing +latePayment :: InvoiceId -> RegistrationId -> IO () +latePayment (InvoiceId invText) (RegistrationId rid) = + logError ("names: invoice " <> invText <> " was paid after its order closed, so registration " <> rid <> " stays unpaid; refund the payment") + -- | False when the invoice was no longer open. Throws RegistrationChanged, changing nothing, when its order changed meanwhile. +-- The provider has taken the cancel, so a name invoice a payment landed on meanwhile expires too, and its payment is late. cancelOpenInvoice :: DBStore -> Waiters -> Maybe Phases -> InvoiceId -> UTCTime -> IO Bool cancelOpenInvoice st waiters phases invId now = do closed <- withTransaction st $ \db -> do - cancelled <- updateInvoiceStatus db invId ISOpen ISExpired now - if cancelled then Just <$> closeInvoiceOrder db invId now else pure Nothing - forM_ closed $ \order -> atomically $ publish waiters invId ISExpired >> mapM_ (publishRegistration phases) order + -- On Postgres, a settlement holding the row is waited for, and the read below sees its payment. + lockInvoice db invId now + settlementInvoice db invId >>= \case + Just row@InvoiceRow {irStatus = ISOpen} -> do + cancelled <- updateInvoiceStatus db invId ISOpen ISExpired now + if cancelled then Just . (,lateOf row) <$> closeInvoiceOrder db invId now else pure Nothing + _ -> pure Nothing + forM_ closed $ \(order, late) -> do + atomically $ publish waiters invId ISExpired >> mapM_ (publishRegistration phases) order + mapM_ (latePayment invId) late pure (isJust closed) + where + lateOf InvoiceRow {irProduct, irPayment} = case irProduct of + IPName rid | maybe False paymentHolds irPayment -> Just rid + _ -> Nothing -- | Of the given invoices, expires those still open, with no money received, and past the cutoff, closing their orders. -- Each in its own transaction, so an invoice that fails is logged and skipped, and the others still expire. diff --git a/tests/Bots/StoreService/NamesOrdersTests.hs b/tests/Bots/StoreService/NamesOrdersTests.hs index 9efac23221..c380ecfeae 100644 --- a/tests/Bots/StoreService/NamesOrdersTests.hs +++ b/tests/Bots/StoreService/NamesOrdersTests.hs @@ -98,6 +98,7 @@ namesOrdersTests = describe "StoreService names: orders" $ do it "alerts on a late payment as BTCPay reports it for an expired, cancelled or swept invoice, once" testLateBTCPayPayments it "alerts once on money read while open when the provider then closes the invoice, also after a restart" testOneLateAlert it "answers cancel with funded, not_open, paid when settlement won, and expired with the payment read meanwhile" testCancelAnswers + it "alerts once when a cancel expires an invoice a payment landed on while the provider was told" testCancelAlertsFunded 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 it "takes the invoice's row before recording a payment that moves no status" testSettlementLocksInvoice @@ -731,6 +732,21 @@ testCancelAnswers = withOrders $ \ctx -> do where cancelAt c (InvoiceId t) = post c ("/api/invoice/" <> T.unpack t <> "/cancel") "" +-- | Cancel takes the invoice row and decides on the payment it then reads, as settlement does. +testCancelAlertsFunded :: IO () +testCancelAlertsFunded = withOrdersCancelling (SigFunded paid PaidInPart) $ \ctx -> do + (invId, _) <- placed ctx aliceOrder + logs <- capturingStderr $ do + (status, v) <- post ctx ("/api/invoice/" <> T.unpack (invoiceText invId) <> "/cancel") "" + (status, field "status" =<< v, field "cryptoAmountPaid" =<< v) `shouldBe` (200, Just "expired", Just "0.00078") + length (T.breakOnAll (alertOf invId) logs) `shouldBe` 1 + capturingStderr (settleNow ctx invId (SigClosed paid) `shouldReturn` Right ISExpired) >>= (`shouldNotSatisfy` T.isInfixOf (alertOf invId)) + (nrPhase &&& nrLive) <$> invoiceRegistration ctx invId `shouldReturn` (PUnpaid, False) + where + paid = rcv 5000 (Just "0.00078") + invoiceText (InvoiceId t) = t + alertOf invId = "invoice " <> invoiceText invId <> " was paid after its order closed" + testNamesOff :: IO () testNamesOff = withOrders $ \ctx -> do (invId@(InvoiceId t), _) <- placed ctx aliceOrder