store: stop late credit at the rate floor

apps/simplex-store-service/src/StoreService/Names/LateCredits.hs

@@ -43,7 +43,7 @@ data CreditOutcome
 creditLateInvoice :: DBStore -> (CryptoCurrency -> IO (Either ProviderError Rate)) -> InvoiceId -> UTCTime -> IO CreditOutcome
 creditLateInvoice st readRate invId now =
   withTransaction st (`lateCreditState` invId) >>= \case
-    Just s | closedUnpaid s && moneyDue s -> case lsCoin s of
+    Just s | creditable s && moneyDue s -> case lsCoin s of
       Nothing -> credit Nothing
       Just coin ->
         readRate coin >>= \case
@@ -59,13 +59,14 @@ creditLateInvoice st readRate invId now =
     credit rate = withTransaction st $ \db -> do
       lockInvoice db invId now
       lateCreditState db invId >>= \case
-        Just s | closedUnpaid s, Just c <- lateCreditOf s rate -> do
+        Just s | creditable s, Just c <- lateCreditOf s rate -> do
           applied <- creditLatePayment db c now
           pure $ if applied then COCredited c else CORefused
         _ -> pure CONothingDue
 
-closedUnpaid :: LateCreditState -> Bool
-closedUnpaid LateCreditState {lsPhase, lsLive} = lsPhase == PUnpaid && not lsLive
+-- | A closed order's money, unless a rate below the floor sent it to support for good, so a later recovery cannot credit money refunded by hand.
+creditable :: LateCreditState -> Bool
+creditable LateCreditState {lsPhase, lsLive, lsSupport} = lsPhase == PUnpaid && not lsLive && lsSupport /= Just LSRateFloor
 
 moneyDue :: LateCreditState -> Bool
 moneyDue s@LateCreditState {lsConfirmedCents, lsCreditedCents} = case lsCoin s of

apps/simplex-store-service/src/StoreService/Names/Store.hs

@@ -1152,11 +1152,14 @@ lateWait db (InvoiceId invId) =
       (Just LPConfirming, Nothing) -> Just LWConfirming
       (Just LPUnconfirmed, Nothing) -> Just LWConfirming
 
--- | Closed orders' invoices with confirmed money not all credited, for the poller's credit pass.
+-- | Closed orders' invoices with confirmed money not all credited, for the poller's credit pass; none a rate below the floor sent to support.
 uncreditedLateInvoices :: DB.Connection -> IO [InvoiceId]
 uncreditedLateInvoices db =
   map (InvoiceId . fromOnly)
-    <$> DB.query db ("SELECT ni.invoice_id" <> lateFrom <> " WHERE" <> closedUnpaid <> " AND" <> uncreditedMoney <> " ORDER BY p.created_at, ni.invoice_id") (Only PUnpaid)
+    <$> DB.query
+      db
+      ("SELECT ni.invoice_id" <> lateFrom <> " WHERE" <> closedUnpaid <> " AND" <> uncreditedMoney <> " AND (ni.late_support IS NULL OR ni.late_support <> ?) ORDER BY p.created_at, ni.invoice_id")
+      (PUnpaid, LSRateFloor)
 
 -- | Pending money whose payment row was created before the cutoff, never alerted, or alerted for less money than now received.
 lateAlertDue :: DB.Connection -> UTCTime -> IO [LateAlert]

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

@@ -372,7 +372,7 @@ creditLate env@PollerEnv {peStore} p now invId@(InvoiceId invText) = do
       when due $ logWarn ("names: late credits wait, as the current rate cannot be read; each pass tries again: " <> e)
     CORateFloor invoiceRate Rate {rateText} -> do
       due <- dueToWarn env now ("rate floor: " <> invText)
-      when due $ logError ("names: invoice " <> invText <> " is not credited: the current rate " <> rateText <> " is below half its rate " <> invoiceRate <> "; a glitch, or a real fall the owner decides on")
+      when due $ logError ("names: invoice " <> invText <> " is not credited: the current rate " <> rateText <> " is below half its rate " <> invoiceRate <> "; it is never credited by itself, and support refunds it by hand")
     CORefused -> logError ("names: the credit of invoice " <> invText <> " was refused, its credit number taken meanwhile; the next pass tries again")
   pure outcome
 
@@ -404,8 +404,8 @@ lateReason env@PollerEnv {peStore, peProviders} LateAlert {laPending, laState =
     Just coin
       | lsSupport == Just LSRateFloor ->
           getInvoice peStore lsInvoice >>= \case
-            Just InvoiceRow {irProvider} | Just p <- find ((== irProvider) . pProvider) peProviders -> either (const (rateRead, Nothing)) (\Rate {rateText} -> (rateFloor rateText, Nothing)) <$> cachedRate env p coin
-            _ -> pure (rateRead, Nothing)
+            Just InvoiceRow {irProvider} | Just p <- find ((== irProvider) . pProvider) peProviders -> (\r -> (rateFloor (either (const "unread") rateText r), Nothing)) <$> cachedRate env p coin
+            _ -> pure (rateFloor "unread", Nothing)
       | otherwise -> pure (rateRead, Nothing)
   _ -> pure (unconfirmed, Just LSUnconfirmed)
   where
@@ -414,7 +414,7 @@ lateReason env@PollerEnv {peStore, peProviders} LateAlert {laPending, laState =
     noConfirmation = "the Monero plugin shows no confirmation of this money (the invoice's settled-confirmation threshold is 0 or not given), so it is never credited by itself; refund by hand only a transaction confirmed on chain"
     rateRead = "confirmed, the credit waits on the rate read; do not refund; fix the rate read"
     cardWaits = "confirmed, the credit waits on the poller's credit pass; do not refund; check the service log"
-    rateFloor current = "confirmed; the coin's price fell by more than half since the invoice (" <> fromMaybe "?" lsInvoiceRate <> ", " <> current <> "); the owner decides: credit at the current rate, or refund by hand"
+    rateFloor current = "confirmed; the coin's price fell by more than half since the invoice (" <> fromMaybe "?" lsInvoiceRate <> ", " <> current <> "); it is never credited by itself; refund by hand only a transaction confirmed on chain"
     uncounted = "an amount BTCPay reported with more decimals than its unit; check it at the provider"
 
 lateAlertText :: LateAlert -> Text -> Text

tests/Bots/StoreService/NamesLateCreditTests.hs

@@ -66,7 +66,7 @@ namesLateCreditTests = describe "StoreService names: balance life" $ do
     it "alerts a part credit with an unconfirmed rest once, naming its units" testPartCreditAlerted
     it "logs Monero's zero figure as pending and does not alert it within the window" testMoneroZero
     it "credits nothing while the rate read fails, warning once, then credits at the next pass" testRateFails
-    it "credits nothing below the rate floor, logging an error, and alerts naming both rates and the owner's decision" testRateFloor
+    it "credits nothing below the rate floor and never after, logging an error, and alerts support naming both rates" testRateFloor
     it "logs the rate floor of an invoice once while the price moves below it" testFloorLoggedOnce
     it "reads one rate per coin per pass for several invoices, and none when nothing is due" testOneRateReadPerPass
     it "never credits a late Settled payment on an invoice made under HighSpeed, alerting it past the window" testHighSpeed
@@ -421,11 +421,12 @@ testRateFloor = withLate $ \l@Late {lStore = st} -> do
   balanceOf st "floored" `shouldReturn` Nothing
   lateWaitOf st "floored" `shouldReturn` Just LWSupport
   alertsAt l (Right floored) (pastWindow (at 70) 60)
-    >>= (`shouldSatisfy` logged "ERROR" "invoice inv-floored of order floored: 320000 satoshi received, 320000 satoshi confirmed, 0 satoshi credited; confirmed; the coin's price fell by more than half since the invoice (62500, 31000); the owner decides: credit at the current rate, or refund by hand")
-  setRate l (Right $ rateOf "31250" 31250)
+    >>= (`shouldSatisfy` logged "ERROR" "invoice inv-floored of order floored: 320000 satoshi received, 320000 satoshi confirmed, 0 satoshi credited; confirmed; the coin's price fell by more than half since the invoice (62500, 31000); it is never credited by itself; refund by hand only a transaction confirmed on chain")
+  setRate l (Right stubRate)
   void $ passAt l (at 72)
-  creditsOf st "floored" `shouldReturn` [(Just lateUnits, Just "62500", Just "31250", Just "31250", 10000)]
-  lateWaitOf st "floored" `shouldReturn` Nothing
+  creditsOf st "floored" `shouldReturn` []
+  withTransaction st uncreditedLateInvoices >>= (`shouldNotSatisfy` elem (invOf "floored"))
+  lateWaitOf st "floored" `shouldReturn` Just LWSupport
 
 testFloorLoggedOnce :: IO ()
 testFloorLoggedOnce = withLate $ \l -> do