store: alert waiting money before stored reasons

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

@@ -394,11 +394,10 @@ alertLatePayments env@PollerEnv {peStore} now = do
       claimed <- withTransaction peStore $ \db -> claimLateAlert db alert support now
       when claimed $ logError (lateAlertText alert reason)
 
+-- | Confirmed money waiting comes before a stored reason, as in pendingCase, so its alert never asks for a refund by hand.
 lateReason :: PollerEnv -> LateAlert -> IO (Text, Maybe LateSupport)
 lateReason env@PollerEnv {peStore, peProviders} LateAlert {laPending, laState = LateCreditState {lsInvoice, lsCoin, lsSupport, lsInvoiceRate}} = case laPending of
   LPUncounted -> pure (uncounted, Nothing)
-  _ | lsSupport == Just LSHighSpeed -> pure (highSpeed, Nothing)
-  _ | lsSupport == Just LSNoConfirmation -> pure (noConfirmation, Nothing)
   LPUncredited -> case lsCoin of
     Nothing -> pure (cardWaits, Nothing)
     Just coin
@@ -407,6 +406,8 @@ lateReason env@PollerEnv {peStore, peProviders} LateAlert {laPending, laState =
             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)
+  _ | lsSupport == Just LSHighSpeed -> pure (highSpeed, Nothing)
+  _ | lsSupport == Just LSNoConfirmation -> pure (noConfirmation, Nothing)
   _ -> pure (unconfirmed, Just LSUnconfirmed)
   where
     unconfirmed = "refund by hand only a transaction confirmed on chain that BTCPay no longer monitors; one still Processing there waits"

tests/Bots/StoreService/NamesLateCreditTests.hs

@@ -68,6 +68,7 @@ namesLateCreditTests = describe "StoreService names: balance life" $ do
     it "credits nothing while the rate read fails, warning once, then credits at the next pass" testRateFails
     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 "alerts confirmed money waiting on the rate read as such, whatever reason was stored before" testWaitingOutranksStoredReason
     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
     it "credits at the next pass a late Settled invoice and a settlement whose credit step did not run" testCreditedByPass
@@ -438,6 +439,15 @@ testFloorLoggedOnce = withLate $ \l -> do
   second <- passAt l (at 72)
   count "invoice inv-floorlog is not credited" (first <> second) `shouldBe` 1
 
+-- | A reason stored by an earlier read, as one without the invoice's policy would store HighSpeed.
+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
+  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")
+
 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"]