store: clamp due and report closed paidInFull

apps/simplex-store-service/README.md

@@ -166,6 +166,11 @@ that arrived under `HighSpeed`. With `MediumSpeed` (the template's value) or a s
 bitcoin is credited to the order's balance once confirmed, at the lower of the invoice's rate and the
 rate when it is credited.
 
+BTCPay keeps an invoice it has closed `Expired` (or `Invalid` after a cancel) when money arrives late.
+The invoice view reports `paidInFull` on such an invoice once BTCPay reads it `PaidLate` or
+`PaidOver`, or its due is 0 or less, and reports an overpaid invoice's `cryptoAmountDue` as `0`,
+never below.
+
 **Set the Monero plugin's settled-confirmation threshold (`InvoiceSettledConfirmationThreshold`) to
 at least 1.** BTCPay's API does not show how many confirmations a Monero payment has, only that
 threshold, so late Monero is credited only on an invoice made while it was 1 or more; it is then

apps/simplex-store-service/src/StoreService/Orders.hs

@@ -61,13 +61,13 @@ paidInFull :: PaymentSignal -> Bool
 paidInFull = \case
   SigFunded _ f -> f == PaidInFull
   SigSettled {} -> True
-  SigClosed {} -> False
+  SigClosed _ f -> f == PaidInFull
 
 received :: PaymentSignal -> Received
 received = \case
   SigFunded r _ -> r
   SigSettled r _ -> r
-  SigClosed r -> r
+  SigClosed r _ -> r
 
 -- | Uses the provider's settlement instant, not now, so an outage does not push deadlines out;
 -- an implausible value (zero, milliseconds, negative) falls back to now.

apps/simplex-store-service/src/StoreService/Poller.hs

@@ -252,7 +252,7 @@ settleMoved env@PollerEnv {peStore, peWaiters, pePhases, peProviders} provider n
     reportSettled sold before after
       -- checked before the no-change case, so a refund still alerts when money lands after expiry;
       -- a name order's late payment is credited to its balance instead
-      | IPBadge {} <- sold, after == ISExpired, SigClosed Received {rcvCrypto = Just paid} <- signal = do
+      | IPBadge {} <- sold, after == ISExpired, SigClosed Received {rcvCrypto = Just paid} _ <- signal = do
           let alert = "badge poller: order " <> ref <> " expired holding " <> paid <> ", which needs a refund"
           due <- dueToWarn env now alert
           when due $ logError alert

apps/simplex-store-service/src/StoreService/Providers.hs

@@ -78,10 +78,11 @@ unitName = \case
 data Funded = PaidInFull | PaidInPart
   deriving (Eq, Show)
 
+-- | A closed invoice's Funded says whether the whole amount reached it, late or not.
 data PaymentSignal
   = SigFunded Received Funded
   | SigSettled Received UTCTime
-  | SigClosed Received
+  | SigClosed Received Funded
   deriving (Eq, Show)
 
 data ProviderInvoice = ProviderInvoice

apps/simplex-store-service/src/StoreService/Providers/BTCPay.hs

@@ -107,6 +107,10 @@ knownMethodIds = map fst methodCurrencies
 confirmingPolicies :: [SpeedPolicy]
 confirmingPolicies = [MediumSpeed, LowMediumSpeed, LowSpeed]
 
+-- | BTCPay's additional statuses of a closed invoice that the whole amount reached, late or above it.
+closedInFullStatuses :: [Text]
+closedInFullStatuses = ["PaidLate", "PaidOver"]
+
 -- The last two are the only events a payment into a closed invoice sends.
 actedOnEventTypes :: [Text]
 actedOnEventTypes = ["InvoiceProcessing", "InvoiceSettled", "InvoiceExpired", "InvoiceInvalid", "InvoiceReceivedPayment", "InvoicePaymentSettled"]
@@ -357,7 +361,7 @@ readInvoice env ref = do
       logAdditionalStatus ref giAdditionalStatus
       ms <- greenfield env what methodGet ["invoices", ref, "payment-methods"] [] Nothing
       now <- getCurrentTime
-      pure (ms >>= paymentMethodsSignal now ref giStatus giSpeedPolicy)
+      pure (ms >>= paymentMethodsSignal now ref giStatus giAdditionalStatus giSpeedPolicy)
   where
     what = "read invoice"
 
@@ -404,11 +408,11 @@ invoicesPass now invs = foldr add (Right ListPass {lpMoved = [], lpSkipped = []}
     add v (Right pass) = case J.fromJSON v of
       J.Error e -> Right pass {lpSkipped = (invoiceIdOf v, T.pack e) : lpSkipped pass}
       J.Success gi -> addInvoice gi pass
-    addInvoice GInvoice {giId, giStatus, giSpeedPolicy, giPaymentMethods} pass = case giPaymentMethods of
+    addInvoice GInvoice {giId, giStatus, giAdditionalStatus, giSpeedPolicy, giPaymentMethods} pass = case giPaymentMethods of
       Nothing ->
         Left . ProviderError $
           listWhat <> ": invoice " <> giId <> " carries no paymentMethods, so includePaymentMethods was not honoured"
-      Just ms -> case invoiceSignal now giId giStatus giSpeedPolicy ms of
+      Just ms -> case invoiceSignal now giId giStatus giAdditionalStatus giSpeedPolicy ms of
         Left (ProviderError e) -> Right pass {lpSkipped = (Just giId, e) : lpSkipped pass}
         Right Nothing -> Right pass
         Right (Just sig) -> Right pass {lpMoved = (giId, sig) : lpMoved pass}
@@ -425,14 +429,14 @@ logAdditionalStatus ref = \case
   Just s | s /= "None" -> logInfo ("btcpay: invoice " <> ref <> " additionalStatus " <> s)
   _ -> pure ()
 
--- | The status and speed policy are the invoice's, the body its payment methods.
-paymentMethodsSignal :: UTCTime -> Text -> Text -> Maybe Text -> LB.ByteString -> Either ProviderError (Maybe PaymentSignal)
-paymentMethodsSignal now ref status policy body =
-  decodeGreenfield "read invoice" body >>= invoiceSignal now ref status policy
+-- | The status, additional status and speed policy are the invoice's, the body its payment methods.
+paymentMethodsSignal :: UTCTime -> Text -> Text -> Maybe Text -> Maybe Text -> LB.ByteString -> Either ProviderError (Maybe PaymentSignal)
+paymentMethodsSignal now ref status additional policy body =
+  decodeGreenfield "read invoice" body >>= invoiceSignal now ref status additional policy
 
 -- Complete is the old API's status name and never matches, so it has no case here.
-invoiceSignal :: UTCTime -> Text -> Text -> Maybe Text -> [GPaymentMethod] -> Either ProviderError (Maybe PaymentSignal)
-invoiceSignal now ref status policy ms = do
+invoiceSignal :: UTCTime -> Text -> Text -> Maybe Text -> Maybe Text -> [GPaymentMethod] -> Either ProviderError (Maybe PaymentSignal)
+invoiceSignal now ref status additional policy ms = do
   (m@GPaymentMethod {gpmRate, gpmPaid, gpmDue, gpmPayments, gpmSettledThreshold}, cc) <- chooseMethod ref ms
   rate <- priced "rate" gpmRate
   paid <- priced "paymentMethodPaid" gpmPaid
@@ -440,11 +444,16 @@ invoiceSignal now ref status policy ms = do
       confirming = maybe False (`elem` map speedPolicyName confirmingPolicies) policy
       shown = cc /= CCXmr || maybe False (>= 1) gpmSettledThreshold
       received = receivedOf decimals confirming shown (status == "Settled") rate paid gpmDue gpmPayments
+      -- BTCPay never settles an invoice it has closed, so only these tell that the whole amount reached it
+      closedFunded
+        | maybe False (`elem` closedInFullStatuses) additional = PaidInFull
+        | wnValue paid > 0 && maybe False ((<= 0) . wnValue) gpmDue = PaidInFull
+        | otherwise = PaidInPart
   case status of
     "Settled" -> Right (Just (SigSettled received (fromMaybe now (latestSettledAt m))))
     "Processing" -> Right (Just (SigFunded received PaidInFull))
-    "Expired" -> Right (Just (SigClosed received))
-    "Invalid" -> Right (Just (SigClosed received))
+    "Expired" -> Right (Just (SigClosed received closedFunded))
+    "Invalid" -> Right (Just (SigClosed received closedFunded))
     "New" -> Right (SigFunded received PaidInPart <$ rcvCrypto received)
     other -> Left (ProviderError ("btcpay invoice " <> ref <> ": unknown status " <> other))
   where
@@ -486,7 +495,7 @@ receivedOf decimals confirming shown invoiceSettled rate paid due payments =
   Received
     { rcvAmount = toMinorUnits (wnValue paid * wnValue rate),
       rcvCrypto = if wnValue paid > 0 then Just (wnText paid) else Nothing,
-      rcvDue = wnText <$> due,
+      rcvDue = nonNegative <$> due,
       rcvUnits = fst <$> counted,
       rcvRate = Just (wnText rate),
       rcvConfirmed = case uncreditable of
@@ -495,6 +504,8 @@ receivedOf decimals confirming shown invoiceSettled rate paid due payments =
       rcvUncreditable = uncreditable
     }
   where
+    -- an overpaid invoice's due is below 0, and nothing is owed on it
+    nonNegative WireNum {wnText, wnValue} = if wnValue < 0 then "0" else wnText
     settled = filter ((== "Settled") . gpStatus) payments
     allSettled = invoiceSettled || (not (null payments) && length settled == length payments)
     counted = do

apps/simplex-store-service/src/StoreService/Providers/Stripe.hs

@@ -13,6 +13,7 @@ where
 import StoreService.Config (StripeConfig (..))
 import StoreService.Providers
   ( Confirmed (..),
+    Funded (..),
     ListPass (..),
     OrderDraft (..),
     PaymentSignal (..),
@@ -266,7 +267,7 @@ signalOf :: UTCTime -> IntentRead -> Either ProviderError (Maybe PaymentSignal)
 signalOf now IntentRead {irStatus, irAmountReceived, irChargeCreated} =
   case irStatus of
     "succeeded" -> Right (Just (SigSettled (received irAmountReceived irAmountReceived) settledAt))
-    "canceled" -> Right (Just (SigClosed (received 0 0)))
+    "canceled" -> Right (Just (SigClosed (received 0 0) PaidInPart))
     s | s `elem` openStatuses -> Right Nothing
       | otherwise -> Left (ProviderError ("stripe payment_intent: unknown status " <> s))
   where

tests/Bots/StoreService/BTCPayTests.hs

@@ -61,6 +61,8 @@ badgeBTCPayTests = describe "badge btcpay adapter" $ do
     it "falls back to the read time when a Settled invoice was marked by hand" testSettledManuallyMarked
     it "funds on Processing" testProcessing
     it "closes on Expired and on Invalid" testClosed
+    it "reports a closed invoice paid in full on PaidLate, PaidOver or a due at 0 or less, and in part otherwise" testClosedPaidInFull
+    it "reads an overpaid invoice's negative due as 0" testOverpaidDueIsZero
     it "funds on New with something received" testNewWithPayment
     it "funds on New with a payment worth less than a minor unit" testNewWithDust
     it "reports no change on New with nothing received" testNewWithNothing
@@ -93,6 +95,7 @@ badgeBTCPayTests = describe "badge btcpay adapter" $ do
     it "fails the pass when the payment methods are absent, rather than reporting health" testListFailsWithoutPaymentMethods
     it "skips an invoice it cannot even name, unaccounted for" testListSkipsWithoutId
     it "fails the pass on a response it cannot read" testListFailsOnUnreadableBody
+    it "reports a listed closed invoice paid in full from its PaidLate" testListClosedPaidLate
   describe "BTCPay-Sig" $ do
     it "accepts the indented bytes as received, for each acted-on type" testWebhookAccepts
     it "finds the header whatever its case" testWebhookHeaderCase
@@ -109,7 +112,7 @@ badgeBTCPayTests = describe "badge btcpay adapter" $ do
     it "is refused when the api key is wrong, rather than passing silently" testFakeWrongApiKey
     it "sends the documented create body, and no redirectURL" testFakeCreateBody
     it "walks New to Processing to Settled, two calls per read" testFakeLifecycle
-    it "closes on Expired and on Invalid" testFakeClosed
+    it "closes on Expired and on Invalid, in full once the whole amount or BTCPay's PaidLate says so" testFakeClosed
     it "names a status the provider invented" testFakeUnknownStatus
     it "reads paymentMethodPaid over the wire, never totalPaid" testFakePaymentMethodPaid
     it "makes a 500 at checkout a ProviderError" testFakeCreate500
@@ -200,7 +203,7 @@ rcvUnitsOf :: PaymentSignal -> Maybe Int64
 rcvUnitsOf = \case
   SigFunded r _ -> rcvUnits r
   SigSettled r _ -> rcvUnits r
-  SigClosed r -> rcvUnits r
+  SigClosed r _ -> rcvUnits r
 
 testHighSpeedConfirmsNothing :: IO ()
 testHighSpeedConfirmsNothing = do
@@ -254,6 +257,7 @@ btcPaid paid payments =
 dueAfter :: Text -> Text
 dueAfter = \case
   "0.00050000" -> "0.00000000"
+  "0.00080000" -> "-0.00030000"
   "0.00000001" -> "0.00050499"
   _ -> "0.00050000"
 
@@ -275,7 +279,11 @@ signalOf = signalUnder (Just "MediumSpeed")
 
 -- | Read from an invoice made under the speed policy given, or none.
 signalUnder :: Maybe Text -> Text -> [J.Value] -> Either ProviderError (Maybe PaymentSignal)
-signalUnder policy status methods = paymentMethodsSignal readTime ref status policy (methodsBody methods)
+signalUnder policy status methods = paymentMethodsSignal readTime ref status Nothing policy (methodsBody methods)
+
+-- | Read from an invoice with the additional status given.
+signalWith :: Text -> Text -> [J.Value] -> Either ProviderError (Maybe PaymentSignal)
+signalWith additional status methods = paymentMethodsSignal readTime ref status (Just additional) (Just "MediumSpeed") (methodsBody methods)
 
 -- | BTC at the rate the bodies carry: the cents, crypto and due received, and the satoshi received and confirmed, with the confirmed cents.
 btcReceived :: Word32 -> Maybe Text -> Text -> Int64 -> Int64 -> Word32 -> Received
@@ -317,9 +325,27 @@ testProcessing =
 testClosed :: IO ()
 testClosed = do
   signalOf "Expired" [btcPaid "0.00050000" [payment "Processing" 1700000000]]
-    `shouldBe` Right (Just (SigClosed halfMilliBtcUnconfirmed))
+    `shouldBe` Right (Just (SigClosed halfMilliBtcUnconfirmed PaidInFull))
   signalOf "Invalid" [btcPaid "0.00000000" []]
-    `shouldBe` Right (Just (SigClosed (nothingReceived "0.00050000")))
+    `shouldBe` Right (Just (SigClosed (nothingReceived "0.00050000") PaidInPart))
+
+-- | BTCPay keeps a late-paid invoice Expired, or Invalid after a cancel, and says the whole amount arrived only by these.
+testClosedPaidInFull :: IO ()
+testClosedPaidInFull = do
+  let verdict additional status paid = (\case Right (Just (SigClosed _ f)) -> Just f; _ -> Nothing) (signalWith additional status [btcPaid paid [payment "Settled" 1700000000]])
+  verdict "PaidLate" "Expired" "0.00025000" `shouldBe` Just PaidInFull
+  verdict "PaidOver" "Invalid" "0.00025000" `shouldBe` Just PaidInFull
+  verdict "None" "Expired" "0.00050000" `shouldBe` Just PaidInFull
+  verdict "Marked" "Invalid" "0.00080000" `shouldBe` Just PaidInFull
+  verdict "PaidPartial" "Expired" "0.00025000" `shouldBe` Just PaidInPart
+  verdict "None" "Invalid" "0.00025000" `shouldBe` Just PaidInPart
+  verdict "None" "Expired" "0.00000000" `shouldBe` Just PaidInPart
+
+testOverpaidDueIsZero :: IO ()
+testOverpaidDueIsZero = do
+  let overpaid = btcReceived 8640 (Just "0.00080000") "0" 80000 80000 8640
+  signalOf "Settled" [btcPaid "0.00080000" []] `shouldBe` Right (Just (SigSettled overpaid readTime))
+  signalWith "PaidOver" "Expired" [btcPaid "0.00080000" []] `shouldBe` Right (Just (SigClosed overpaid {rcvConfirmed = Confirmed {cfCents = CurrencyAmount 0, cfUnits = Just 0}} PaidInFull))
 
 testNewWithPayment :: IO ()
 testNewWithPayment =
@@ -399,7 +425,7 @@ testUnknownPaymentMethod = do
 
 testUnreadableResponse :: IO ()
 testUnreadableResponse =
-  paymentMethodsSignal readTime ref "Settled" (Just "MediumSpeed") "<html>502 Bad Gateway</html>" `shouldSatisfy` namesInError "could not read the response"
+  paymentMethodsSignal readTime ref "Settled" Nothing (Just "MediumSpeed") "<html>502 Bad Gateway</html>" `shouldSatisfy` namesInError "could not read the response"
 
 namesInError :: Text -> Either ProviderError a -> Bool
 namesInError what = \case
@@ -498,6 +524,14 @@ testListFailsOnUnreadableBody :: IO ()
 testListFailsOnUnreadableBody =
   listSignals readTime "<html>502 Bad Gateway</html>" `shouldSatisfy` namesInError "could not read the response"
 
+testListClosedPaidLate :: IO ()
+testListClosedPaidLate = do
+  let paidLate = case listEntry ref "Expired" (Just [btcPaid "0.00025000" []]) of
+        J.Object o -> J.Object (KM.insert "additionalStatus" (J.String "PaidLate") o)
+        other -> other
+      quarter = btcReceived 2700 (Just "0.00025000") "0.00050000" 25000 0 0
+  lpMoved <$> listSignals readTime (J.encode [paidLate]) `shouldBe` Right [(ref, SigClosed quarter PaidInFull)]
+
 testReadsPaymentMethodPaid :: IO ()
 testReadsPaymentMethodPaid = do
   signalOf "Settled" [btcPaid "0.00050000" [payment "Settled" 1700000000]]
@@ -547,7 +581,7 @@ testNumberAsWellAsString = do
   let asNumbers =
         "[{\"paymentMethodId\":\"BTC-CHAIN\",\"rate\":108000.12,\"paymentMethodPaid\":0.00050000,\
         \\"payments\":[{\"status\":\"Settled\",\"receivedDate\":1700000000}]}]"
-  case paymentMethodsSignal readTime ref "Settled" (Just "MediumSpeed") asNumbers of
+  case paymentMethodsSignal readTime ref "Settled" Nothing (Just "MediumSpeed") asNumbers of
     Right (Just (SigSettled r t)) -> do
       rcvAmount r `shouldBe` CurrencyAmount 5400
       rcvCrypto r `shouldBe` Just "0.00050000"
@@ -755,9 +789,11 @@ testFakeClosed :: IO ()
 testFakeClosed = withProvider $ \fake p -> do
   ProviderInvoice {piProviderRef = invRef} <- createdInvoice p (SPMCrypto CCBtc)
   setInvoiceState fake invRef ["status" .= ("Expired" :: Text), "paymentMethodPaid" .= ("0.00050000" :: Text)]
-  pReadInvoice p invRef `shouldReturn` Right (Just (SigClosed halfMilliBtcUnconfirmed))
+  pReadInvoice p invRef `shouldReturn` Right (Just (SigClosed halfMilliBtcUnconfirmed PaidInFull))
   setInvoiceState fake invRef ["status" .= ("Invalid" :: Text), "paymentMethodPaid" .= ("0.00000000" :: Text)]
-  pReadInvoice p invRef `shouldReturn` Right (Just (SigClosed (nothingReceived "0.00050000")))
+  pReadInvoice p invRef `shouldReturn` Right (Just (SigClosed (nothingReceived "0.00050000") PaidInPart))
+  setInvoiceState fake invRef ["status" .= ("Expired" :: Text), "additionalStatus" .= ("PaidLate" :: Text), "paymentMethodPaid" .= ("0.00025000" :: Text), "due" .= ("0.00025000" :: Text)]
+  pReadInvoice p invRef `shouldReturn` Right (Just (SigClosed (btcReceived 2700 (Just "0.00025000") "0.00025000" 25000 0 0) PaidInFull))
 
 testFakeUnknownStatus :: IO ()
 testFakeUnknownStatus = withProvider $ \fake p -> do

tests/Bots/StoreService/NamesBalancesTests.hs

@@ -36,7 +36,7 @@ import StoreService.Names.Store
 import StoreService.Names.Turns (balanceTurnCount, newTurns, turnsCount, withBalanceTurn, withLabelTurn)
 import StoreService.Orders (cancelOpenInvoice, expireOverdue, settleOrder)
 import StoreService.Poller (cleanupUnpaid, newPollerEnv, unpaidRetention)
-import StoreService.Providers (PaymentSignal (..))
+import StoreService.Providers (Funded (..), PaymentSignal (..))
 import StoreService.Waiters (newWaiters)
 import StoreService.Web.Server (WebEnv (..))
 import System.Timeout (timeout)
@@ -477,7 +477,7 @@ testClosesRelease = withServiceStore $ \st -> do
     holder st ("h-" <> c) ("s-" <> c) 10000 (at 60) `shouldReturn` Right ()
   cancelOpenInvoice st waiters Nothing (InvoiceId "inv-h-cancel") (at 2) `shouldReturn` True
   expireOverdue st waiters Nothing (at 61) (at 61) [InvoiceId "inv-h-sweep"] `shouldReturn` [InvoiceId "inv-h-sweep"]
-  settleOrder st waiters Nothing (InvoiceId "inv-h-settled") (SigClosed (rcv 0 Nothing)) (at 2) `shouldReturn` Right ISExpired
+  settleOrder st waiters Nothing (InvoiceId "inv-h-settled") (SigClosed (rcv 0 Nothing) PaidInPart) (at 2) `shouldReturn` Right ISExpired
   next <- reg st "h-next"
   withTransaction st (\db -> closeOverdue db next (at 61)) `shouldReturn` Just (nrVersion next + 1)
   forM_ closes $ \c -> do

tests/Bots/StoreService/NamesLateCreditTests.hs

@@ -174,7 +174,7 @@ stubRate = rateOf "60000.5" 60000.5
 closedOrder :: Late -> Text -> Bool -> IO ()
 closedOrder l@Late {lStore} r card = do
   placeOrderRow lStore r card 20000 (at 60)
-  settleAt l r (SigClosed nothingPaid) (at 61) `shouldReturn` Right ISExpired
+  settleAt l r (SigClosed nothingPaid PaidInPart) (at 61) `shouldReturn` Right ISExpired
   NameRegistration {nrPhase, nrLive} <- reg lStore r
   (nrPhase, nrLive) `shouldBe` (PUnpaid, False)
 
@@ -306,9 +306,9 @@ testLateCredited :: IO ()
 testLateCredited = withLate $ \l@Late {lStore = st} -> do
   source st "paid" 10000
   holder st "credited" "paid" 10000 (at 60) `shouldReturn` Right ()
-  settleAt l "credited" (SigClosed nothingPaid) (at 61) `shouldReturn` Right ISExpired
+  settleAt l "credited" (SigClosed nothingPaid PaidInPart) (at 61) `shouldReturn` Right ISExpired
   figures st "paid" t0 `shouldReturn` Just (10000, 10000, 0, Nothing)
-  logs <- readSignal l "credited" (SigClosed (btcPaid lateUnits lateUnits))
+  logs <- readSignal l "credited" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart)
   logs `shouldSatisfy` logged "INFO" "invoice inv-credited credited 19200 cents to the balance of registration credited for 320000 units at 60000.5 (invoice 62500, current 60000.5)"
   logs `shouldNotSatisfy` logged "ERROR" "inv-credited"
   balanceOf st "credited" `shouldReturn` Just (19200, 19200, 0)
@@ -319,18 +319,18 @@ testRisingPrice :: IO ()
 testRisingPrice = withLate $ \l@Late {lStore = st} -> do
   closedOrder l "x" False
   setRate l (Right $ rateOf "70000" 70000)
-  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart)
   creditsOf st "x" `shouldReturn` [(Just lateUnits, Just "62500", Just "70000", Just "62500", 20000)]
   balanceOf st "x" `shouldReturn` Just (20000, 20000, 0)
 
 testGrowingReports :: IO ()
 testGrowingReports = withLate $ \l@Late {lStore = st} -> do
   closedOrder l "x" False
-  void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000))
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000) PaidInPart)
   balanceOf st "x" `shouldReturn` Just (9600, 9600, 0)
-  void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000))
-  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
-  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000) PaidInPart)
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart)
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart)
   map (\(units, _, _, _, cents) -> (units, cents)) <$> creditsOf st "x" `shouldReturn` [(Just 160000, 9600), (Just 160000, 9600)]
   balanceOf st "x" `shouldReturn` Just (19200, 19200, 0)
 
@@ -338,7 +338,7 @@ testCloseAndCancel :: IO ()
 testCloseAndCancel = withLate $ \l@Late {lStore = st, lWaiters} -> do
   placeOrderRow st "p" False 20000 (at 60)
   settleAt l "p" (SigFunded (btcPaid lateUnits 160000) PaidInPart) (at 10) `shouldReturn` Right ISOpen
-  void $ readSignal l "p" (SigClosed (btcPaid lateUnits 160000))
+  void $ readSignal l "p" (SigClosed (btcPaid lateUnits 160000) PaidInPart)
   nrLive <$> reg st "p" `shouldReturn` False
   balanceOf st "p" `shouldReturn` Just (9600, 9600, 0)
   placeOrderRow st "c" False 20000 (at 60)
@@ -353,11 +353,11 @@ testCloseAndCancel = withLate $ \l@Late {lStore = st, lWaiters} -> do
 testUnconfirmedThenSettled :: IO ()
 testUnconfirmedThenSettled = withLate $ \l@Late {lStore = st} -> do
   closedOrder l "x" False
-  logs <- readSignal l "x" (SigClosed (btcPaid lateUnits 0))
+  logs <- readSignal l "x" (SigClosed (btcPaid lateUnits 0) PaidInPart)
   logs `shouldSatisfy` logged "INFO" "invoice inv-x holds money of its closed order not yet confirmed"
   balanceOf st "x" `shouldReturn` Nothing
-  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
-  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart)
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart)
   length <$> creditsOf st "x" `shouldReturn` 1
   balanceOf st "x" `shouldReturn` Just (19200, 19200, 0)
 
@@ -367,7 +367,7 @@ testNeverConfirmed = withLate $ \l@Late {lStore = st} -> do
   closedOrder l "never" False
   let seenAt = at (60 * 24 * 5)
       alert = "invoice inv-never of order never: 320000 satoshi received, 0 satoshi confirmed, 0 satoshi credited; refund by hand only a transaction confirmed on chain that BTCPay no longer monitors; one still Processing there waits"
-  settleAt l "never" (SigClosed (btcPaid lateUnits 0)) seenAt `shouldReturn` Right ISExpired
+  settleAt l "never" (SigClosed (btcPaid lateUnits 0) PaidInPart) seenAt `shouldReturn` Right ISExpired
   alertsAt l (Right stubRate) (pastWindow seenAt (-60)) >>= (`shouldNotSatisfy` T.isInfixOf "invoice inv-never of order never")
   lateWaitOf st "never" `shouldReturn` Just LWConfirming
   logs <- alertsAt l (Right stubRate) (pastWindow seenAt 60)
@@ -379,7 +379,7 @@ testNeverConfirmed = withLate $ \l@Late {lStore = st} -> do
 testPartCreditAlerted :: IO ()
 testPartCreditAlerted = withLate $ \l@Late {lStore = st} -> do
   closedOrder l "part" False
-  settleAt l "part" (SigClosed (btcPaid lateUnits 160000)) (at 100) `shouldReturn` Right ISExpired
+  settleAt l "part" (SigClosed (btcPaid lateUnits 160000) PaidInPart) (at 100) `shouldReturn` Right ISExpired
   void $ passAt l (at 101)
   balanceOf st "part" `shouldReturn` Just (9600, 9600, 0)
   logs <- alertsAt l (Right stubRate) (pastWindow (at 100) 60)
@@ -401,8 +401,8 @@ testRateFails = withLate $ \l@Late {lStore = st} -> do
   closedOrder l "fail1" False
   closedOrder l "fail2" False
   setRate l (Left $ ProviderError "rates down for fail1")
-  logs <- readSignal l "fail1" (SigClosed (btcPaid lateUnits lateUnits))
-  settleAt l "fail2" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
+  logs <- readSignal l "fail1" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart)
+  settleAt l "fail2" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70) `shouldReturn` Right ISExpired
   more <- passAt l (at 71)
   count "late credits wait, as the current rate cannot be read; each pass tries again: rates down for fail1" (logs <> more) `shouldBe` 1
   lateWaitOf st "fail1" `shouldReturn` Just LWCrediting
@@ -417,7 +417,7 @@ testRateFloor = withLate $ \l@Late {lStore = st} -> do
   closedOrder l "floored" False
   let floored = rateOf "31000" 31000
   setRate l (Right floored)
-  settleAt l "floored" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
+  settleAt l "floored" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70) `shouldReturn` Right ISExpired
   logs <- passAt l (at 71)
   logs `shouldSatisfy` logged "ERROR" "invoice inv-floored is not credited: the current rate 31000 is below half its rate 62500"
   balanceOf st "floored" `shouldReturn` Nothing
@@ -433,7 +433,7 @@ testRateFloor = withLate $ \l@Late {lStore = st} -> do
 testFloorLoggedOnce :: IO ()
 testFloorLoggedOnce = withLate $ \l -> do
   closedOrder l "floorlog" False
-  settleAt l "floorlog" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
+  settleAt l "floorlog" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70) `shouldReturn` Right ISExpired
   setRate l (Right $ rateOf "31000" 31000)
   first <- passAt l (at 71)
   setRate l (Right $ rateOf "30000" 30000)
@@ -445,24 +445,24 @@ testWaitingOutranksStoredReason :: IO ()
 testWaitingOutranksStoredReason = withLate $ \l@Late {lStore = st} -> do
   closedOrder l "outranked" False
   withTransaction st $ \db -> setLateSupport db (invOf "outranked") LSHighSpeed
-  settleAt l "outranked" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
+  settleAt l "outranked" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70) `shouldReturn` Right ISExpired
   alertsAt l (Left $ ProviderError "rates down for outranked") (pastWindow (at 70) 60)
     >>= (`shouldSatisfy` logged "ERROR" "invoice inv-outranked of order outranked: 320000 satoshi received, 320000 satoshi confirmed, 0 satoshi credited; confirmed, the credit waits on the rate read; do not refund; fix the rate read")
 
 testRateProblemsNamed :: IO ()
 testRateProblemsNamed = withLate $ \l@Late {lStore = st} -> do
   closedOrder l "noprovider" False
-  settleAt l "noprovider" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
+  settleAt l "noprovider" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70) `shouldReturn` Right ISExpired
   withTransaction st $ \db -> DB.execute_ db "UPDATE sx_badge_service_invoices SET provider = 'apple' WHERE invoice_id = 'inv-noprovider'"
   closedOrder l "norate" False
-  settleAt l "norate" (SigClosed (btcPaid lateUnits lateUnits) {rcvRate = Nothing}) (at 70) `shouldReturn` Right ISExpired
+  settleAt l "norate" (SigClosed (btcPaid lateUnits lateUnits) {rcvRate = Nothing} PaidInPart) (at 70) `shouldReturn` Right ISExpired
   logs <- (<>) <$> passAt l (at 71) <*> passAt l (at 72)
   count "invoice inv-noprovider has late money to credit, but no provider" logs `shouldBe` 1
   logs `shouldSatisfy` logged "ERROR" "invoice inv-norate has confirmed late money, but no invoice rate was recorded to credit it at"
 
 testOneRateReadPerPass :: IO ()
 testOneRateReadPerPass = withLate $ \l@Late {lStore = st} -> do
-  mapM_ (\r -> closedOrder l r False >> settleAt l r (SigClosed (btcPaid lateUnits lateUnits)) (at 70)) ["x", "y", "z"]
+  mapM_ (\r -> closedOrder l r False >> settleAt l r (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70)) ["x", "y", "z"]
   closedOrder l "card" True
   settleAt l "card" (SigSettled (cardPaid 20000 20000) (at 70)) (at 70) `shouldReturn` Right ISPaid
   void $ passAt l (at 71)
@@ -487,7 +487,7 @@ testCreditedByPass = withLate $ \l@Late {lStore = st} -> do
   closedOrder l "settled" False
   settleAt l "settled" (SigSettled (btcPaid lateUnits lateUnits) (at 70)) (at 70) `shouldReturn` Right ISPaid
   closedOrder l "crashed" False
-  settleAt l "crashed" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
+  settleAt l "crashed" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70) `shouldReturn` Right ISExpired
   mapM (balanceOf st) ["settled", "crashed"] `shouldReturn` [Nothing, Nothing]
   void $ passAt l (at 71)
   mapM (balanceOf st) ["settled", "crashed"] `shouldReturn` replicate 2 (Just (19200, 19200, 0))
@@ -495,7 +495,7 @@ testCreditedByPass = withLate $ \l@Late {lStore = st} -> do
 testLiveAgain :: IO ()
 testLiveAgain = withLate $ \l@Late {lStore = st} -> do
   closedOrder l "x" False
-  settleAt l "x" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
+  settleAt l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70) `shouldReturn` Right ISExpired
   let liveAgain _ = do
         withTransaction st $ \db -> DB.execute_ db "UPDATE sx_badge_service_name_registrations SET live = 1 WHERE registration_id = 'x'"
         pure (Right stubRate)
@@ -506,21 +506,21 @@ testLiveAgain = withLate $ \l@Late {lStore = st} -> do
 testTwoInstancesAlert :: IO ()
 testTwoInstancesAlert = withLate $ \l -> do
   closedOrder l "twice" False
-  settleAt l "twice" (SigClosed (btcPaid lateUnits 0)) (at 70) `shouldReturn` Right ISExpired
+  settleAt l "twice" (SigClosed (btcPaid lateUnits 0) PaidInPart) (at 70) `shouldReturn` Right ISExpired
   let first = "invoice inv-twice of order twice: 320000 satoshi received"
   logs <- (<>) <$> alertsAt l (Right stubRate) (pastWindow (at 70) 60) <*> alertsAt l (Right stubRate) (pastWindow (at 70) 60)
   count first logs `shouldBe` 1
-  settleAt l "twice" (SigClosed (btcPaid 400000 0)) (at 80) `shouldReturn` Right ISExpired
+  settleAt l "twice" (SigClosed (btcPaid 400000 0) PaidInPart) (at 80) `shouldReturn` Right ISExpired
   alertsAt l (Right stubRate) (pastWindow (at 70) 120) >>= (`shouldSatisfy` logged "ERROR" "invoice inv-twice of order twice: 400000 satoshi received, 0 satoshi confirmed")
 
 testFallingSum :: IO ()
 testFallingSum = withLate $ \l@Late {lStore = st} -> do
   closedOrder l "x" False
-  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
-  void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000))
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart)
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000) PaidInPart)
   confirmed <- withTransaction st $ \db -> DB.query db "SELECT confirmed_units FROM sx_badge_service_payments WHERE invoice_id = 'inv-x'" ()
   confirmed `shouldBe` [Only (Just lateUnits)]
-  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart)
   length <$> creditsOf st "x" `shouldReturn` 1
   balanceOf st "x" `shouldReturn` Just (19200, 19200, 0)
 
@@ -531,7 +531,7 @@ testHintPastWindow = withLate $ \l@Late {lStore = st} -> do
   let longAgo = addUTCTime (negate $ settleWindow + 3600) now
   withTransaction st $ \db -> DB.execute db "UPDATE sx_badge_service_invoices SET created_at = ? WHERE invoice_id = 'inv-x'" (Only longAgo)
   unpaidRefs st (addUTCTime (negate settleWindow) now) >>= (`shouldNotSatisfy` elem ("crypto", refOf "x"))
-  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart)
   balanceOf st "x" `shouldReturn` Just (19200, 19200, 0)
 
 testStripeCredited :: IO ()
@@ -576,9 +576,9 @@ testXmrLate = withLate $ \l@Late {lStore = st} -> do
 testCreditWhileHeld :: IO ()
 testCreditWhileHeld = withLate $ \l@Late {lStore = st} -> do
   closedOrder l "x" False
-  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart)
   holder st "h" "x" 19200 (at 60) `shouldReturn` Right ()
-  void $ readSignal l "x" (SigClosed (btcPaid 400000 400000))
+  void $ readSignal l "x" (SigClosed (btcPaid 400000 400000) PaidInPart)
   figures st "x" (at 10) `shouldReturn` Just (24000, 24000, 0, Just BalanceHold {bhHolder = RegistrationId "h", bhUntil = at 60, bhOverdue = False, bhFunded = False})
   settleAt l "h" (SigSettled (btcPaid 330000 330000) (at 10)) (at 10) `shouldReturn` Right ISPaid
   figures st "x" (at 10) `shouldReturn` Just (4800, 24000, 0, Nothing)
@@ -590,8 +590,8 @@ coveredSpend st r src price seen = withTransaction st $ \db -> createBalanceRegi
 testSpendBeforeCredit :: IO ()
 testSpendBeforeCredit = withLate $ \l@Late {lStore = st} -> do
   closedOrder l "x" False
-  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
-  void $ readSignal l "x" (SigClosed (btcPaid 400000 400000))
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart)
+  void $ readSignal l "x" (SigClosed (btcPaid 400000 400000) PaidInPart)
   coveredSpend st "c" "x" 10000 19200 `shouldReturn` Left RRBalanceChanged
   coveredSpend st "c" "x" 10000 24000 `shouldReturn` Right ()
   balanceOf st "x" `shouldReturn` Just (14000, 24000, 0)
@@ -600,9 +600,9 @@ testCreditRefundTwice :: IO ()
 testCreditRefundTwice = withLate $ \l@Late {lStore = st} -> do
   turns <- newTurns
   closedOrder l "x" False
-  void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000))
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000) PaidInPart)
   void (recordRefund turns st "x" 9600 (at 80) >>= either (fail . show) pure)
-  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart)
   void (recordRefund turns st "inv-x" 9600 (at 81) >>= either (fail . show) pure)
   balanceOf st "x" `shouldReturn` Just (0, 19200, 19200)
   invariantHolds st "x"
@@ -611,7 +611,7 @@ testSpendAndRefundLate :: IO ()
 testSpendAndRefundLate = withLate $ \l@Late {lStore = st} -> do
   turns <- newTurns
   closedOrder l "x" False
-  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart)
   coveredSpend st "c" "x" 10000 19200 `shouldReturn` Right ()
   nrBalanceSource <$> reg st "c" `shouldReturn` Just (RegistrationId "x")
   recordRefund turns st "x" 10000 (at 80) >>= (`shouldSatisfy` \case Left (RefundAmount 9200) -> True; _ -> False)
@@ -654,14 +654,14 @@ testZeroBalances = withLate $ \Late {lStore = st} -> do
 testLateWaits :: IO ()
 testLateWaits = withLate $ \l@Late {lStore = st} -> do
   mapM_ (\r -> closedOrder l r False) ["confirming", "crediting", "highspeed", "units", "floor", "alerted"]
-  settleAt l "crediting" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
-  settleAt l "highspeed" (SigClosed (btcPaid lateUnits 0) {rcvUncreditable = Just UCHighSpeed}) (at 70) `shouldReturn` Right ISExpired
-  settleAt l "units" (SigClosed (btcPaid 0 0) {rcvAmount = CurrencyAmount 20000, rcvCrypto = Just "0.003200001", rcvUnits = Nothing, rcvUncreditable = Just UCUncounted}) (at 70) `shouldReturn` Right ISExpired
-  settleAt l "alerted" (SigClosed (btcPaid lateUnits 0)) (at 70) `shouldReturn` Right ISExpired
+  settleAt l "crediting" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70) `shouldReturn` Right ISExpired
+  settleAt l "highspeed" (SigClosed (btcPaid lateUnits 0) {rcvUncreditable = Just UCHighSpeed} PaidInPart) (at 70) `shouldReturn` Right ISExpired
+  settleAt l "units" (SigClosed (btcPaid 0 0) {rcvAmount = CurrencyAmount 20000, rcvCrypto = Just "0.003200001", rcvUnits = Nothing, rcvUncreditable = Just UCUncounted} PaidInPart) (at 70) `shouldReturn` Right ISExpired
+  settleAt l "alerted" (SigClosed (btcPaid lateUnits 0) PaidInPart) (at 70) `shouldReturn` Right ISExpired
   void $ alertsAt l (Right stubRate) (pastWindow (at 70) 60)
-  settleAt l "confirming" (SigClosed (btcPaid lateUnits 0)) (pastWindow (at 70) 60) `shouldReturn` Right ISExpired
+  settleAt l "confirming" (SigClosed (btcPaid lateUnits 0) PaidInPart) (pastWindow (at 70) 60) `shouldReturn` Right ISExpired
   setRate l (Right $ rateOf "31000" 31000)
-  void $ readSignal l "floor" (SigClosed (btcPaid lateUnits lateUnits))
+  void $ readSignal l "floor" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart)
   placeOrderRow st "open" False 20000 (at 60)
   settleAt l "open" (SigFunded (btcPaid lateUnits 0) PaidInFull) (at 70) `shouldReturn` Right ISOpen
   let waits = mapM (\r -> (r,) <$> lateWaitOf st r)
@@ -675,7 +675,7 @@ testLateWaits = withLate $ \l@Late {lStore = st} -> do
                      ("open", Nothing)
                    ]
   setRate l (Right stubRate)
-  void $ readSignal l "alerted" (SigClosed (btcPaid lateUnits lateUnits))
+  void $ readSignal l "alerted" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart)
   void $ passAt l (at 71)
   waits ["crediting", "floor", "alerted"] `shouldReturn` [("crediting", Nothing), ("floor", Just LWSupport), ("alerted", Nothing)]
 
@@ -706,7 +706,7 @@ testConcurrentCredits = withServiceStores $ \open -> do
     let due :: Text -> IO ()
         due r = do
           closedOrder l r False
-          settleAt l r (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
+          settleAt l r (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70) `shouldReturn` Right ISExpired
     forM_ [1 .. rounds] $ \n -> do
       let r = "x" <> T.pack (show n)
       due r
@@ -741,12 +741,12 @@ testCreditAgainstSettlement = withServiceStores $ \open -> do
   withLateOn st $ \l -> forM_ [1 .. rounds] $ \n -> do
     let r = "x" <> T.pack (show n)
     closedOrder l r False
-    settleAt l r (SigClosed (btcPaid lateUnits 160000)) (at 70) `shouldReturn` Right ISExpired
+    settleAt l r (SigClosed (btcPaid lateUnits 160000) PaidInPart) (at 70) `shouldReturn` Right ISExpired
     arrived <- newTVarIO 0
     let readRate :: CryptoCurrency -> IO (Either ProviderError Rate)
         readRate _ = Right stubRate <$ meet arrived
         raise :: IO (Either Text InvoiceStatus)
-        raise = meet arrived >> settleOrder other otherWaiters Nothing (invOf r) (SigClosed (btcPaid lateUnits lateUnits)) (at 80)
+        raise = meet arrived >> settleOrder other otherWaiters Nothing (invOf r) (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 80)
     (credited, raised) <- concurrently (creditLateInvoice st readRate (invOf r) (at 80)) raise
     (n, raised) `shouldBe` (n, Right ISExpired)
     credited `shouldSatisfy` \case COCredited _ -> True; _ -> False

tests/Bots/StoreService/NamesOrdersTests.hs

@@ -1302,7 +1302,7 @@ testOneLateAlert = withOrders $ \ctx@Ctx {cStore = st, cWeb} -> do
   poller <- newPoller
   setSignals (cStub ctx) [(ref, SigFunded paid PaidInPart)]
   refunds <$> readWith poller `shouldReturn` 0
-  setSignals (cStub ctx) [(ref, SigClosed paid)]
+  setSignals (cStub ctx) [(ref, SigClosed paid PaidInPart)]
   logs <- readWith poller
   refunds logs `shouldBe` 1
   logs `shouldSatisfy` T.isInfixOf "it stays unpaid, and its money is credited to its balance once confirmed, else alerted"
@@ -1342,7 +1342,7 @@ testCancelAlertsFunded = withOrdersCancelling (SigFunded paid PaidInPart) $ \ctx
     (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))
+  capturingStderr (settleNow ctx invId (SigClosed paid PaidInPart) `shouldReturn` Right ISExpired) >>= (`shouldNotSatisfy` T.isInfixOf (alertOf invId))
   (nrPhase &&& nrLive) <$> invoiceRegistration ctx invId `shouldReturn` (PUnpaid, False)
   where
     paid = rcv 5000 (Just "0.00078")
@@ -1414,7 +1414,7 @@ testSettlementLocksInvoice = withOrders $ \ctx -> do
 testExpiryCloses :: IO ()
 testExpiryCloses = withOrders $ \ctx -> do
   (closedByProvider, _) <- placed ctx aliceOrder
-  settleNow ctx closedByProvider (SigClosed (rcv 0 Nothing)) `shouldReturn` Right ISExpired
+  settleNow ctx closedByProvider (SigClosed (rcv 0 Nothing) PaidInPart) `shouldReturn` Right ISExpired
   r <- invoiceRegistration ctx closedByProvider
   (nrPhase r, nrLive r, nrVersion r) `shouldBe` (PUnpaid, False, 2)
   (swept, _) <- placed ctx aliceOrder {oLabel = "dynamis", oPrice = 20000, oCommitment = commitmentOf 2}
@@ -1455,7 +1455,7 @@ testPassSweepsAroundFailures = do
     withConnection st $ \db -> DB.execute db "UPDATE sx_badge_service_name_registrations SET phase = 'lost' WHERE registration_id = ? AND phase = ?" (poisonedId, "unpaid" :: Text)
     poisonedRef <- refOf poisoned
     refOf unread >>= writeIORef unreadable
-    setSignals (cStub ctx) [(poisonedRef, SigClosed (rcv 0 Nothing))]
+    setSignals (cStub ctx) [(poisonedRef, SigClosed (rcv 0 Nothing) PaidInPart)]
     poller <- newPollerEnv st (weWaiters cWeb) (Just $ oePhases $ cOrders ctx) (weHints cWeb) (weProviders cWeb) (poll $ weConfig cWeb)
     void $ capturingStderr $ runOnePass poller
     mapM (fmap (irStatus <$>) . getInvoice st) [poisoned, unread, good] `shouldReturn` map Just [ISOpen, ISOpen, ISExpired]
@@ -1471,7 +1471,7 @@ testCleanupIn ctx@Ctx {cStore = st} = do
   mapM_ (uncurry place) [("gone", 1), ("funded", 2), ("late", 3), ("unread", 4)]
   placePaid st "recent" ownerA (order "alicebakery5" 5) (addUTCTime 3600 due) `shouldReturn` Right ()
   settleOrder st (weWaiters $ cWeb ctx) Nothing (InvoiceId "inv-funded") (SigFunded (rcv 100 (Just "0.00001")) PaidInPart) t0 `shouldReturn` Right ISOpen
-  setSignals (cStub ctx) [(ref "late", SigClosed (rcv 5000 (Just "0.00078")))]
+  setSignals (cStub ctx) [(ref "late", SigClosed (rcv 5000 (Just "0.00078")) PaidInPart)]
   failing <- newIORef False
   let reading p = p {pReadInvoice = \r -> readIORef failing >>= \f -> if f && r == ref "unread" then pure (Left $ ProviderError "down") else pReadInvoice p r}
       providers = map reading (weProviders $ cWeb ctx)

tests/Bots/StoreService/StripeTests.hs

@@ -7,6 +7,7 @@ module Bots.StoreService.StripeTests (badgeStripeTests) where
 import StoreService.Config (StripeConfig (..))
 import StoreService.Providers
   ( Confirmed (..),
+    Funded (..),
     ListPass (..),
     OrderDraft (..),
     PaymentSignal (..),
@@ -176,7 +177,7 @@ testFakeCancel = withProvider $ \fake p -> do
   ProviderInvoice {piProviderRef = pid} <- createdInvoice p (SPMCard CPStripe)
   pCancelInvoice p pid `shouldReturn` Right ()
   fakeIntentStatus fake pid `shouldReturn` Just "canceled"
-  pReadInvoice p pid `shouldReturn` Right (Just (SigClosed nothingReceived))
+  pReadInvoice p pid `shouldReturn` Right (Just (SigClosed nothingReceived PaidInPart))
   pCancelInvoice p pid >>= (`shouldSatisfy` namesInError "payment_intent_unexpected_state")
 
 testFakeReadExpands :: IO ()
@@ -193,7 +194,7 @@ testFakeCanceled = withProvider $ \fake p -> do
   ProviderInvoice {piProviderRef = pid} <- createdInvoice p (SPMCard CPStripe)
   setIntentState fake pid ["status" .= ("canceled" :: Text)]
   -- A nonzero received amount here would write a phantom payment for money the buyer never sent.
-  pReadInvoice p pid `shouldReturn` Right (Just (SigClosed nothingReceived))
+  pReadInvoice p pid `shouldReturn` Right (Just (SigClosed nothingReceived PaidInPart))
 
 testFakeCreate500 :: IO ()
 testFakeCreate500 = withProvider $ \fake p -> do
@@ -236,7 +237,7 @@ testConfirmedOnlySucceeded = do
   now <- getCurrentTime
   let read' status = signalOf now IntentRead {irId = "pi_test_x", irStatus = status, irAmountReceived = 5400, irChargeCreated = Nothing}
   read' "succeeded" `shouldBe` Right (Just (SigSettled (cardReceived 5400 5400) now))
-  read' "canceled" `shouldBe` Right (Just (SigClosed (cardReceived 0 0)))
+  read' "canceled" `shouldBe` Right (Just (SigClosed (cardReceived 0 0) PaidInPart))
   withProvider $ \_ p -> isNothing (pCurrentRate p) `shouldBe` True
 
 -- | A status=open query returns only open intents, which carry no signal, so the poll lists by
@@ -274,7 +275,7 @@ testFakeListsOpen = withProvider $ \_ p -> do
           rcv `shouldBe` fiftyFourDollarsReceived
           settledAt `shouldSatisfy` \t -> t >= askedAt && t <= answeredAt
         other -> failWith ("pi_test_a should settle at read time, got " <> show other)
-      lookup "pi_test_b" lpMoved `shouldBe` Just (SigClosed nothingReceived)
+      lookup "pi_test_b" lpMoved `shouldBe` Just (SigClosed nothingReceived PaidInPart)
     Left e -> failWith ("expected a list pass, got " <> show e)
 
 testFakeListSkipsIdless :: IO ()

tests/Bots/StoreService/WebTests.hs

@@ -224,6 +224,7 @@ badgeWebTests = do
     it "omits the confirmations where no provider is configured" testViewOmitsConfirmationsWithoutBTCPay
     it "carries the provider's paid-in-full verdict, which the amounts cannot give" testViewCarriesTheProvidersPaidVerdict
     it "never withdraws a paid-in-full verdict on a later read" testPaidVerdictIsNotWithdrawnByALaterRead
+    it "carries a closed invoice's paid-in-full verdict, the status staying expired" testViewCarriesAClosedPaidVerdict
     it "answers an unknown id with 404 not_found and nothing else" testUnknownInvoiceIsOpaque
     it "releases a held wait when a payment lands without settling" testHeldWaitWakesOnAPaymentThatDoesNotSettle
     it "leaves a held wait alone when a pass writes nothing" testHeldWaitIsNotWokenByAPassThatWroteNothing
@@ -909,7 +910,7 @@ stubProvider ref =
         lost <- ssCancelLost <$> readIORef ref
         if lost
           then do
-            atomicModifyIORef' ref $ \s -> (s {ssInvoices = Map.insert providerRef (SigClosed (rcv 0 Nothing)) (ssInvoices s)}, ())
+            atomicModifyIORef' ref $ \s -> (s {ssInvoices = Map.insert providerRef (SigClosed (rcv 0 Nothing) PaidInPart) (ssInvoices s)}, ())
             pure (Left (ProviderError "the response was lost"))
           else maybe (Right ()) Left . ssCancelError <$> readIORef ref,
       pListOpen = do
@@ -2303,7 +2304,7 @@ testFundedRecordsWithoutMoving = bounded "funded records only" $ withServiceStor
 testClosedExpiresAnOpenInvoice :: IO ()
 testClosedExpiresAnOpenInvoice = bounded "closed expires" $ withServiceStore $ \st -> do
   iid <- seedOpen st
-  settle st iid (SigClosed (rcv 200 (Just "0.00020000"))) settleAt `shouldReturn` Right ISExpired
+  settle st iid (SigClosed (rcv 200 (Just "0.00020000")) PaidInPart) settleAt `shouldReturn` Right ISExpired
   invoiceStatus st iid `shouldReturn` ISExpired
   p <- paymentRow st iid
   ipAmount p `shouldBe` Just (CurrencyAmount 200)
@@ -2313,7 +2314,7 @@ testClosedExpiresAnOpenInvoice = bounded "closed expires" $ withServiceStore $ \
 testClosedWithNothingWritesNoPayment :: IO ()
 testClosedWithNothingWritesNoPayment = bounded "closed on nothing" $ withServiceStore $ \st -> do
   iid <- seedOpen st
-  settle st iid (SigClosed (rcv 0 Nothing)) settleAt `shouldReturn` Right ISExpired
+  settle st iid (SigClosed (rcv 0 Nothing) PaidInPart) settleAt `shouldReturn` Right ISExpired
   invoiceStatus st iid `shouldReturn` ISExpired
   Just row <- getInvoice st iid
   irPayment row `shouldBe` Nothing
@@ -2322,8 +2323,8 @@ testClosedWithNothingWritesNoPayment = bounded "closed on nothing" $ withService
 testClosedReplayIsIdempotent :: IO ()
 testClosedReplayIsIdempotent = bounded "closed replay" $ withServiceStore $ \st -> do
   iid <- seedOpen st
-  settle st iid (SigClosed (rcv 200 (Just "0.00020000"))) settleAt `shouldReturn` Right ISExpired
-  settle st iid (SigClosed (rcv 200 (Just "0.00020000"))) replayAt `shouldReturn` Right ISExpired
+  settle st iid (SigClosed (rcv 200 (Just "0.00020000")) PaidInPart) settleAt `shouldReturn` Right ISExpired
+  settle st iid (SigClosed (rcv 200 (Just "0.00020000")) PaidInPart) replayAt `shouldReturn` Right ISExpired
   invoiceStatus st iid `shouldReturn` ISExpired
   p <- paymentRow st iid
   ipAmount p `shouldBe` Just (CurrencyAmount 200)
@@ -2344,7 +2345,7 @@ testPaidRefusesEverySignal = bounded "paid refuses" $ withServiceStore $ \st ->
     )
     [ SigSettled (rcv 900 (Just "0.00090000")) replayAt,
       SigFunded (rcv 900 (Just "0.00090000")) PaidInPart,
-      SigClosed (rcv 900 (Just "0.00090000"))
+      SigClosed (rcv 900 (Just "0.00090000")) PaidInPart
     ]
   invoiceStatus st iid `shouldReturn` ISPaid
   bcExpiresAt <$> settledCode st iid `shouldReturn` deadline
@@ -2706,7 +2707,7 @@ testEverySignalSettles = bounded "every signal settles" $ withStubPoller raceHol
     ref
     [ ("p-settled", settledSignal),
       ("p-funded", SigFunded (rcv 200 (Just "0.00020000")) PaidInPart),
-      ("p-closed", SigClosed (rcv 100 (Just "0.00010000")))
+      ("p-closed", SigClosed (rcv 100 (Just "0.00010000")) PaidInPart)
     ]
   runOnePass poller
   invoiceStatus (weStore env) paid `shouldReturn` ISPaid
@@ -2852,7 +2853,7 @@ testSweepWritesStatusAlone = bounded "sweep writes status alone" $ withStubPolle
   invoiceStatus (weStore env) iid `shouldReturn` ISExpired
   Just row <- getInvoice (weStore env) iid
   irPayment row `shouldBe` Nothing
-  setSignals ref [("p-1", SigClosed (rcv 200 (Just "0.00020000")))]
+  setSignals ref [("p-1", SigClosed (rcv 200 (Just "0.00020000")) PaidInPart)]
   runOnePass poller
   invoiceStatus (weStore env) iid `shouldReturn` ISExpired
   p <- paymentRow (weStore env) iid
@@ -3793,6 +3794,17 @@ testPaidVerdictIsNotWithdrawnByALaterRead = bounded "verdict sticks" $ withCheck
   o <- jsonObject =<< webGet client (invoicePath iid)
   fieldOf o "paidInFull" `shouldBe` Just (J.Bool True)
 
+testViewCarriesAClosedPaidVerdict :: IO ()
+testViewCarriesAClosedPaidVerdict = bounded "closed in full" $ withCheckout $ \_ env client -> do
+  iid <- seedOpenInvoice env
+  let readVerdict = (\o -> (fieldOf o "status", fieldOf o "paidInFull", fieldOf o "amountPaid")) <$> (jsonObject =<< webGet client (invoicePath iid))
+  settleOrder (weStore env) (weWaiters env) Nothing iid (SigClosed (rcv 250 (Just "0.00025000")) PaidInPart) someCreated
+    `shouldReturn` Right ISExpired
+  readVerdict `shouldReturn` (Just (J.String "expired"), Just (J.Bool False), Just (J.Number 250))
+  settleOrder (weStore env) (weWaiters env) Nothing iid (SigClosed (rcv 500 (Just "0.00050000")) PaidInFull) someCreated
+    `shouldReturn` Right ISExpired
+  readVerdict `shouldReturn` (Just (J.String "expired"), Just (J.Bool True), Just (J.Number 500))
+
 testExpireOverdueSparesAZeroAmount :: IO ()
 testExpireOverdueSparesAZeroAmount = withServiceStore $ \st -> do
   seedBadgePrice st "price1"