diff --git a/apps/simplex-store-service/src/StoreService/Names/LateCredits.hs b/apps/simplex-store-service/src/StoreService/Names/LateCredits.hs index ea251b64ae..1187ddddd6 100644 --- a/apps/simplex-store-service/src/StoreService/Names/LateCredits.hs +++ b/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 diff --git a/apps/simplex-store-service/src/StoreService/Names/Store.hs b/apps/simplex-store-service/src/StoreService/Names/Store.hs index feece95196..f28117b8b7 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Store.hs +++ b/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] diff --git a/apps/simplex-store-service/src/StoreService/Poller.hs b/apps/simplex-store-service/src/StoreService/Poller.hs index 5d6502f4a8..eb9377a0ed 100644 --- a/apps/simplex-store-service/src/StoreService/Poller.hs +++ b/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 diff --git a/tests/Bots/StoreService/NamesLateCreditTests.hs b/tests/Bots/StoreService/NamesLateCreditTests.hs index 1cb5171bad..d5d24e81a6 100644 --- a/tests/Bots/StoreService/NamesLateCreditTests.hs +++ b/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