diff --git a/apps/simplex-store-service/src/StoreService/Poller.hs b/apps/simplex-store-service/src/StoreService/Poller.hs index eb9377a0ed..4e461cfb65 100644 --- a/apps/simplex-store-service/src/StoreService/Poller.hs +++ b/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" diff --git a/tests/Bots/StoreService/NamesLateCreditTests.hs b/tests/Bots/StoreService/NamesLateCreditTests.hs index d5d24e81a6..c3fb1cb1e3 100644 --- a/tests/Bots/StoreService/NamesLateCreditTests.hs +++ b/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"]