store: alert on late payments as BTCPay reports them

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))

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