store: merge the refund command

apps/simplex-store-service/README.md

@@ -128,6 +128,15 @@ The BTCPay API key needs four permissions, each scoped to the one store:
 `canmodifyinvoices` so `POST /api/invoice/:id/cancel` can invalidate an invoice at BTCPay
 rather than only in this store.
 
+**Do not set `speed_policy = HighSpeed` when names are sold** (`[names]` configured). Under it
+BTCPay can mark a payment `Settled` with no confirmation, so the service never credits crypto that
+reaches a name invoice after the invoice closed: the money stays pending, the poller alerts about it
+once it is older than its read window (about 72 hours), and support settles it by hand. The service
+judges each invoice by the policy it was created with, so changing the setting later credits nothing
+that arrived under `HighSpeed`. With `MediumSpeed` (the template's value) or a slower policy, late
+money is credited to the order's balance once confirmed, at the lower of the invoice's rate and the
+rate when it is credited.
+
 Give the service a BTCPay store of its own, and a Stripe account of its own if card payments are
 on. The poller lists every invoice and payment intent of the last three days or so, and one it did
 not create and cannot read is reported in a warning once an hour until it falls out of that window.
@@ -766,7 +775,8 @@ were already given out, and the command answers with an error. A multi-use code
 be revoked, which stops the uses that remain.
 
 Core parses `//...` into `CustomChatCommand` and leaves it to the service's `preCmdHook`, which is
-why issuing codes lives in the service rather than in core.
+why issuing codes lives in the service rather than in core. `//refund`, the other command of this
+console, is in [Refunding a name balance](#refunding-a-name-balance).
 
 ### From the group
 
@@ -776,7 +786,8 @@ and above, `/revoke <code>` for admins and owners. `months` is 1 to 255, `uses`
 `count` 1 to 100; a value outside these gets the usage reply. The name forms are
 `/issue name <length> [years <Y>]` and `/bulk name <length> [years <Y>] count <B>`, with the
 bounds of `//issue name`; a name code issued in the group is single-use and `free`. `/revoke`
-takes badge codes only: withdraw a name code with `//revoke` in `--run-cli` mode. A member's role
+takes badge codes only: withdraw a name code with `//revoke` in `--run-cli` mode. The group has no
+`/refund`. A member's role
 is checked as the service last saw it, so a command sent by a moderator just demoted or removed can still run if it
 reaches the service first; revoke any code the service posts for them after the change. `uses`
 above 1 makes a multi-use code, tracked by a group message showing its remaining uses and the time
@@ -835,3 +846,57 @@ join link still works and its messages hold every code posted there.
 
 The configured `display_name` and `description` apply only to the group the service creates. Editing
 them later is logged as not applied and changes nothing.
+
+## Refunding a name balance
+
+A paid name order keeps its money as a balance when it ends `taken` (another buyer registered the
+name first), when it moves to a cheaper name (the difference), and when a payment reaches its invoice
+after the invoice closed. The buyer spends a balance on another name from Your names, or asks for it
+back: the page tells them to write to chat@simplex.chat with the order's reference, which is its
+invoice id, or its registration id for an order without an invoice. Nothing is refunded
+automatically, and the service never learns where to send money. Support records each refund in
+`--run-cli` mode with the service stopped, like the other `//` commands:
+
+```
+//refund <reference>
+//refund <reference> <cents>
+```
+
+1. Run `//refund <reference>` with the reference the buyer sent. It records nothing and answers the
+   balance, what paid for it and the command that refunds it:
+
+   ```
+   Order <id>: balance $100.00 (credited $100.00, refunded $0.00). Paid by: order <id>: $100.00 by btc on invoice <invoice id>. To record its refund: //refund <reference> 10000
+   ```
+
+   `Paid by` starts at this order and follows every balance the money came through back to the
+   first order: each order with what its invoice paid and by which method (`card`, `btc` or
+   `xmr`), the part paid from the balance of the next order listed, and, marked `late`, money
+   credited after its invoice closed.
+2. Run the command the answer ends with. The cents must equal the whole balance: a refund zeroes it,
+   and part of a balance is never refunded. Other cents record nothing, and the answer gives the
+   balance.
+3. The answer, `Recorded a refund of $100.00 for order <id>. Refund it now, by: …`, repeats the
+   chain. Pay the balance's amount in US dollars back now, by the methods it lists. The refund is
+   recorded first so that the buyer cannot spend the money while it is paid
+   back. The service logs each recorded refund at info with the order's registration id and the
+   cents.
+
+A balance that an open order holds is never refunded: that order is buying another name with it and
+its invoice is waiting for the difference. The command names the order and its invoice's expiry
+instead:
+
+- `its invoice open until <time>`: if the buyer pays it, the balance is spent; if not, it is released
+  once the invoice expires and the poller, in service mode, closes the order. Run the command again
+  then.
+- `its invoice expired at <time>; start the service so the poller closes that order, 10 minutes
+  after the expiry at the earliest, then stop it and run //refund again`: the poller runs only in
+  service mode. Its first pass from 10 minutes after the expiry closes the order and releases the
+  hold; a card order closes only once Stripe accepts the cancel.
+- `whose invoice expired at <time> holding money`: a payment reached the invoice; the hold stays
+  until that payment settles, which spends the balance, or the provider closes the invoice, which
+  releases it.
+
+The command also answers when the reference matches no order, when the order has no balance, and
+when the cents are not the balance. A refunded balance shows `amount` 0 and its `refunded` total in
+Your names; a later late payment credits it again, and a second refund adds to `refunded`.

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

@@ -19,6 +19,7 @@ module StoreService.Group
     TrackerAction (..),
     trackerDecision,
     codeInTracker,
+    fmtTime,
     noOwnerHint,
     orphanHint,
   )

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

@@ -21,17 +21,20 @@ where
 import StoreService.Catalog (defaultCatalog)
 import StoreService.Codes (issueFailedText, issueOneCode, singleUse)
 import StoreService.Config (BadgeIssuerKey (..), ChainConfig (..), NamesConfig (..), ServiceConfig (..), minNameYears, readServiceConfig)
-import StoreService.Group (GroupEvent, ensureManagedGroup, groupEvent, hasTracker, refreshTracker, revokeWithTracker, runGroupLane)
+import StoreService.Group (GroupEvent, ensureManagedGroup, fmtTime, groupEvent, hasTracker, refreshTracker, revokeWithTracker, runGroupLane)
 import StoreService.Group.Command (badgeTypeP, codeP, maxMonths, maxNameYears, nameCodeP, textTokenP)
+import StoreService.Names.Balances (RefundRecord (..), RefundRefusal (..), recordRefund)
 import StoreService.Names.Codes (issueNameCode, revokeNameCode)
 import StoreService.Names.Env (NamesEnv (..), newNamesEnv)
 import StoreService.Names.Orders (ordersEnv)
+import StoreService.Names.Phases (RegistrationId (..))
 import StoreService.Names.Records (runRecordEdits)
 import StoreService.Names.Sender (runSender)
+import StoreService.Names.Store (Balance (..), BalanceHold (..), BalanceLink (..), LateCredit (..), RegistrationPayment (..), balanceByReference, balanceChain, methodText)
 import StoreService.Names.Turns (Turns, newTurns)
 import StoreService.Names.Worker (newWorker, runCodeSweep, runWorkers)
 import StoreService.Options
-import StoreService.Poller (newPollerEnv, newReadHints, runPoller)
+import StoreService.Poller (expiryGrace, newPollerEnv, newReadHints, runPoller)
 import StoreService.Providers (Provider)
 import StoreService.Providers.BTCPay (btcpayProvider)
 import StoreService.Providers.Stripe (stripeProvider)
@@ -51,11 +54,11 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import Data.Char (isSpace)
 import Data.Either (fromRight)
-import Data.Functor (($>))
+import Data.Functor (($>), (<&>))
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, isJust, maybeToList)
 import qualified Data.Text as T
-import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Time.Clock (NominalDiffTime, UTCTime, getCurrentTime)
 import Data.Word (Word32)
 import Simplex.Chat.Badges
 import Simplex.Chat.Badges.Code
@@ -67,6 +70,7 @@ import Simplex.Chat.Bot.Store (withDB, withDB')
 import Simplex.Chat.Controller
 import Simplex.Chat.Core (sendChatCmd, simplexChatCore)
 import Simplex.Chat.Options (printDbOpts)
+import Simplex.Chat.PaymentService.Types (InvoiceId (..))
 import Simplex.Chat.Terminal (terminalChatConfig)
 import Simplex.Chat.Terminal.Main (simplexChatCLI')
 import Simplex.Chat.Types (AgentInvId (..), User (..))
@@ -74,7 +78,7 @@ import Simplex.Messaging.Agent.Store.Common (DBStore)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.BBS (bbsPublicKey)
 import Simplex.Messaging.Encoding.String (strEncode)
-import Simplex.Messaging.Util (raceAny_, safeDecodeUtf8, tshow)
+import Simplex.Messaging.Util (catchOwn, raceAny_, safeDecodeUtf8, tshow)
 import Simplex.Messaging.Version (isCompatible)
 import System.Directory (getAppUserDataDirectory)
 import System.Exit (exitFailure)
@@ -234,19 +238,20 @@ runBadgeCmd turns cc cmd
       issuedReply formatBadgeCode <$> issueBadgeCode cc issueOpts
   | Right (len, years, paymentStatus) <- A.parseOnly issueNameCmdP cmd =
       issuedReply (formatNameCode . NCPrepaid) <$> issueNameCode cc len years paymentStatus
-  | Right code <- A.parseOnly revokeCmdP cmd = revokedReply <$> revokeWithTracker cc code
-  | Right code <- A.parseOnly revokeNameCmdP cmd = revokedReply <$> revokeNameCode turns cc code
+  | Right code <- A.parseOnly revokeCmdP cmd = textReply <$> revokeWithTracker cc code
+  | Right code <- A.parseOnly revokeNameCmdP cmd = textReply <$> revokeNameCode turns cc code
+  | Right (ref, cents_) <- A.parseOnly refundCmdP cmd = textReply <$> maybe (showRefund cc ref) (refundBalanceCmd turns cc ref) cents_
   | otherwise =
       pure $ chatCmdError $
         "Usage: //issue supporter|legend|investor [months 1-" <> show maxMonths <> "] [paid|unpaid|free], //issue name <length "
           <> show minNameLength <> "-" <> show maxNameLength <> "> [years " <> show minNameYears <> "-" <> show maxNameYears
-          <> "] [paid|unpaid|free], or //revoke <code>"
+          <> "] [paid|unpaid|free], //revoke <code>, or //refund <reference> [<cents>]"
   where
     issuedReply :: (c -> T.Text) -> Either String c -> Either ChatError ChatResponse
     issuedReply format = \case
       Right code -> Right CRCustomChatResponse {user_ = Nothing, response = "Code: " <> format code}
       Left _ -> chatCmdError (T.unpack issueFailedText)
-    revokedReply = \case
+    textReply = \case
       Right response -> Right CRCustomChatResponse {user_ = Nothing, response}
       Left e -> chatCmdError (T.unpack e)
 
@@ -261,6 +266,93 @@ revokeNameCmdP = "revoke " *> prepaidCodeP <* (A.skipSpace *> A.endOfInput)
         Just (NCPrepaid code) -> pure code
         _ -> fail "not a prepaid name code"
 
+-- | The reference, and the cents of the balance to refund; without them the balance is shown.
+refundCmdP :: A.Parser (T.Text, Maybe Int)
+refundCmdP = do
+  ref <- "refund " *> (safeDecodeUtf8 <$> A.takeWhile1 (not . isSpace))
+  cents_ <- optional (A.space *> (A.decimal :: A.Parser Integer))
+  A.skipSpace
+  A.endOfInput
+  (ref,) <$> mapM checkCents cents_
+  where
+    -- Integer, as in issueCmdP, so a figure past Int is refused rather than wrapped.
+    checkCents n
+      | n >= 1 && n <= toInteger (maxBound :: Int) = pure (fromInteger n)
+      | otherwise = fail "cents out of range"
+
+-- | Left is a refusal or a failure; both sides are the text to show the operator.
+showRefund :: ChatController -> T.Text -> IO (Either T.Text T.Text)
+showRefund cc ref = do
+  now <- getCurrentTime
+  withDB' "showRefund" cc (\db -> balanceByReference db ref now >>= mapM (withChain db)) <&> \case
+    Right Nothing -> Left $ "No order has the reference " <> ref <> "."
+    Right (Just (RegistrationId rid, Nothing)) -> Left $ "Order " <> rid <> " has no balance."
+    Right (Just (RegistrationId rid, Just (balance@Balance {blAmount, blCredited, blRefunded}, chain))) ->
+      Right $
+        "Order " <> rid <> ": balance " <> dollars blAmount <> " (credited " <> dollars blCredited <> ", refunded " <> dollars blRefunded
+          <> "). Paid by: " <> chainText chain <> ". " <> nextStep now balance
+    Left _ -> Left "The balance could not be read."
+  where
+    withChain db (rid, balance_) = (rid,) <$> mapM (\balance -> (balance,) <$> balanceChain db rid) balance_
+    nextStep now Balance {blAmount, blHold} = case blHold of
+      Just hold -> "It cannot be refunded now: " <> heldText now hold <> "."
+      Nothing
+        | blAmount > 0 -> "To record its refund: //refund " <> ref <> " " <> tshow blAmount
+        | otherwise -> "Nothing to refund."
+
+-- | The refund is recorded before support pays it, so the balance cannot be spent meanwhile.
+refundBalanceCmd :: Turns -> ChatController -> T.Text -> Int -> IO (Either T.Text T.Text)
+refundBalanceCmd turns ChatController {chatStore} ref cents = do
+  now <- getCurrentTime
+  ((Right <$> recordRefund turns chatStore ref cents now) `catchOwn` (pure . Left)) >>= \case
+    Right (Right RefundRecord {rdRegistration = RegistrationId rid, rdCents, rdChain}) -> do
+      -- The registration id, not the reference, since an invoice id is kept out of the logs.
+      logInfo $ "names: recorded a refund of " <> tshow rdCents <> " cents for order " <> rid
+      pure $ Right $ "Recorded a refund of " <> dollars rdCents <> " for order " <> rid <> ". Refund it now, by: " <> chainText rdChain <> "."
+    Right (Left refusal) -> pure $ Left $ "Nothing recorded: " <> refusalText now refusal <> "."
+    Left e -> Left "The refund could not be recorded." <$ logError ("names: recording a refund failed: " <> tshow e)
+  where
+    refusalText now = \case
+      RefundNoOrder -> "no order has the reference " <> ref
+      RefundNoBalance -> "the order of " <> ref <> " has no balance"
+      RefundAmount amount -> "the balance is " <> dollars amount <> " now, not " <> dollars cents
+      RefundHeld hold -> heldText now hold
+
+heldText :: UTCTime -> BalanceHold -> T.Text
+heldText now BalanceHold {bhHolder = RegistrationId holder, bhUntil, bhOverdue}
+  | bhOverdue = heldBy <> "its invoice expired at " <> fmtTime bhUntil <> "; start the service so the poller closes that order, " <> tshow graceMinutes <> " minutes after the expiry at the earliest, then stop it and run //refund again"
+  | bhUntil < now = heldBy <> "whose invoice expired at " <> fmtTime bhUntil <> " holding money; it holds until that payment settles or the invoice closes; run the command again then"
+  | otherwise = heldBy <> "its invoice open until " <> fmtTime bhUntil <> "; run the command again then"
+  where
+    heldBy = "held by order " <> holder <> ", "
+    graceMinutes = round (expiryGrace / minute) :: Int
+    minute = 60 :: NominalDiffTime
+
+-- | From the balance's own order back to the first; a part paid from a balance names the next order, whose balance paid it.
+chainText :: [BalanceLink] -> T.Text
+chainText chain = T.intercalate "; " $ zipWith linkText chain (map (Just . lkRegistration) (drop 1 chain) <> [Nothing])
+  where
+    linkText BalanceLink {lkRegistration = RegistrationId rid, lkPayment, lkPaid, lkFromBalance, lkLateCredits} source_ =
+      "order " <> rid <> ": " <> case paid lkPayment lkPaid lkLateCredits <> fromBalance lkFromBalance source_ of
+        [] -> "no payment recorded"
+        parts -> T.intercalate ", " parts
+    paid payment cents lateCredits = case payment of
+      RPInvoice method (InvoiceId invId) ->
+        let by = " by " <> methodText method <> " on invoice " <> invId
+            late = sum $ map lcCents lateCredits
+         in [dollars cents <> by | cents > 0] <> [dollars late <> " late" <> by | late > 0]
+      RPCode _ -> ["a prepaid code"]
+      RPBalance -> []
+    fromBalance cents = \case
+      Just (RegistrationId source) | cents > 0 -> [dollars cents <> " from the balance of order " <> source]
+      _ -> []
+
+dollars :: Int -> T.Text
+dollars cents = "$" <> tshow whole <> "." <> T.justifyRight 2 '0' (tshow part)
+  where
+    (whole, part) = cents `quotRem` centsPerDollar
+    centsPerDollar = 100
+
 issueNameCmdP :: A.Parser (Int, Int, BadgeCodePaymentStatus)
 issueNameCmdP = do
   (len, years) <- "issue " *> nameCodeP

tests/Bots/StoreService/BotTests.hs

@@ -218,13 +218,16 @@ issueCode cc badgeType months = issueCodeAs cc badgeType months "free"
 revokeCodeAs :: HasCallStack => ChatController -> BadgeCode -> IO (Either T.Text T.Text)
 revokeCodeAs cc code = revokeRaw cc (formatBadgeCode code)
 
--- | Left is a refusal or a failure the service answers as a command error.
 revokeRaw :: HasCallStack => ChatController -> T.Text -> IO (Either T.Text T.Text)
-revokeRaw cc args =
-  sendChatCmdStr cc ("//revoke " <> T.unpack args) >>= \case
+revokeRaw cc args = operatorCmd cc ("//revoke " <> args)
+
+-- | Left is a refusal or a failure the service answers as a command error.
+operatorCmd :: HasCallStack => ChatController -> T.Text -> IO (Either T.Text T.Text)
+operatorCmd cc cmd =
+  sendChatCmdStr cc (T.unpack cmd) >>= \case
     Right (CRCustomChatResponse _ response) -> pure (Right response)
     Left (ChatError (CECommandError e)) -> pure (Left (T.pack e))
-    r -> error $ "revoke failed: " <> show (() <$ r)
+    r -> error $ T.unpack cmd <> " failed: " <> show (() <$ r)
 
 issueCodeAs :: HasCallStack => ChatController -> BadgeType -> Int -> String -> IO BadgeCode
 issueCodeAs cc badgeType months status =
@@ -1590,4 +1593,4 @@ testRevokeRejectsTrailingInput ps =
 
 -- The text is spelled out rather than taken from the service, so a change there fails here.
 badgeCmdUsage :: Text
-badgeCmdUsage = "Usage: //issue supporter|legend|investor [months 1-255] [paid|unpaid|free], //issue name <length 6-63> [years 2-10] [paid|unpaid|free], or //revoke <code>"
+badgeCmdUsage = "Usage: //issue supporter|legend|investor [months 1-255] [paid|unpaid|free], //issue name <length 6-63> [years 2-10] [paid|unpaid|free], //revoke <code>, or //refund <reference> [<cents>]"

tests/Bots/StoreService/GroupIntegrationTests.hs

@@ -8,25 +8,28 @@
 {-# LANGUAGE TupleSections #-}
 
 -- Members' messages reach a console over separate connections in no fixed order, so gating is asserted from the bot's store.
-module Bots.StoreService.GroupIntegrationTests (badgeGroupIntegrationTests, namesBootTests, namesCodesChatTests, namesWorkerBootTests) where
+module Bots.StoreService.GroupIntegrationTests (badgeGroupIntegrationTests, namesBootTests, namesCodesChatTests, namesRefundChatTests, namesWorkerBootTests) where
 
 import StoreService.Config (BadgeIssuerKey (..), GroupConfig (..))
 import StoreService.Group (GroupAction (..), GroupEvent (..), codeInTracker, ensureManagedGroup)
-import StoreService.Group.Command (maxUses)
+import StoreService.Group.Command (CmdAction (..), groupCmdAction, maxUses)
 import StoreService.Names.Abi (selector, uint256)
 import StoreService.Names.Codes (issueNameCode, reserveCode, revokeNameCode)
 import StoreService.Names.Phases (RegistrationId (..))
-import StoreService.Names.Store (PrepaidCode (..), getPrepaidCode, spendPrepaidCode)
+import StoreService.Names.Store (NamePhase (..), NameRegistration (..), PrepaidCode (..), VersionWrite (..), getPrepaidCode, spendPrepaidCode)
 import StoreService.Names.Turns (newTurns, withCodeTurn)
 import StoreService.Options (StoreServiceOpts (..))
+import StoreService.Orders (cancelOpenInvoice, expireOverdue)
 import StoreService.Service (ServiceState (..), storeService, newServiceState)
 import StoreService.Store (ManagedGroup (..), getManagedGroup)
-import Bots.StoreService.BotTests (badgeBotName, badgeCmdUsage, badgeProfile, badgeTypeOf, credentialOf, entryOf, issueCode, issueRaw, mkStoreServiceOpts, newPurchaseKeys, redeemWithQueue, requestObject, revokeRaw, serviceDbPrefix, shouldAnswerError, statementOf, stopStoreService, testIssuerKeyIdx)
+import StoreService.Waiters (newWaiters)
+import Bots.StoreService.BotTests (badgeBotName, badgeCmdUsage, badgeProfile, badgeTypeOf, credentialOf, entryOf, issueCode, issueRaw, mkStoreServiceOpts, newPurchaseKeys, operatorCmd, redeemWithQueue, requestObject, revokeRaw, serviceDbPrefix, shouldAnswerError, statementOf, stopStoreService, testIssuerKeyIdx, withStoreService)
 import Bots.StoreService.ConfigTests (chainSection, controllerAddr, namesSection)
 import Bots.StoreService.FakeEthNode (CallAnswer (..), FakeEthNode (..), answerCall, awaitSent, withFakeEthNode)
-import Bots.StoreService.WebTests (digestFixture)
+import Bots.StoreService.WebTests (capturingStderr, digestFixture)
 import Bots.StoreService.NamesSearchTests (aliceHex)
-import Bots.StoreService.NamesStoreTests (order, ownerA, placeCode, placePaid)
+import qualified Bots.StoreService.NamesBalancesTests as Balances
+import Bots.StoreService.NamesStoreTests (order, ownerA, placeCode, placePaid, reg, t0, write)
 import ChatClient
 import ChatTests.DBUtils
 import ChatTests.Utils
@@ -49,6 +52,7 @@ import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Calendar (fromGregorian)
 import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, getCurrentTime)
+import Data.Time.Format (defaultTimeLocale, formatTime)
 import Network.HTTP.Client (RequestBody (..), defaultManagerSettings, httpLbs, method, newManager, parseRequest, requestBody, responseBody, responseHeaders, responseStatus)
 import Network.HTTP.Types.Status (statusCode)
 import Network.Socket (Family (..), SockAddr (..), SocketType (..), close, connect, defaultProtocol, socket, tupleToHostAddress)
@@ -61,12 +65,13 @@ import Simplex.Chat.Controller (ChatCommand (APIDeleteChatItem), ChatConfig (..)
 import Simplex.Chat.Core (sendChatCmd, sendChatCmdStr)
 import Simplex.Chat.Messages (ChatRef (ChatRef), ChatType (CTGroup))
 import Simplex.Chat.Messages.CIContent (CIDeleteMode (CIDMInternal))
+import Simplex.Chat.PaymentService.Types (InvoiceId (..))
 import Simplex.Chat.Types (AgentInvId (..))
 import Simplex.Chat.Types.Preferences (ChatBotCommand (..), FullDeleteGroupPreference (..), GroupFeatureEnabled (..), GroupFeatureI (..), GroupPreferences (..), HistoryGroupPreference (..), SGroupFeature (..), commands_, emptyGroupPrefs, getGroupPreference)
 import Simplex.Chat.Types.Shared (GroupMemberRole (..))
 import Simplex.Messaging.Agent (disposeAgentClient)
 import Simplex.Messaging.Agent.Protocol (AConnShortLink (..), ConnShortLink (..), ContactConnType (..))
-import Simplex.Messaging.Agent.Store.Common (withTransaction)
+import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.BBS (bbsKeyGen)
@@ -307,6 +312,132 @@ testRevokeTakesCodeTurn ps = do
     revokeAfter reserved (releaseTurn reserving) `shouldReturn` Right "Revoked. The order holding it keeps it."
     finished (thAction reserving) `shouldReturn` Right (Right ())
 
+namesRefundChatTests :: SpecWith TestParams
+namesRefundChatTests = describe "StoreService names: operator refund" $ do
+  it "shows a balance with what paid for it, and records refunds by registration or invoice id, adding them up" testRefundRecorded
+  it "refuses an unknown reference, an order without a balance and another amount, and answers the usage to a malformed command" testRefundRefusals
+  it "refuses a balance held by an open order, naming it and its expiry, and records it once that order's invoice is cancelled" testRefundOpenHolder
+  it "refuses a balance held by an overdue order, naming its expiry, and records it once the sweep closed that order" testRefundOverdueHolder
+  it "refuses a balance held by an order whose invoice holds money past its expiry" testRefundFundedHolder
+  it "lists every order of a chain of three that the balance came through" testRefundChain
+  it "stops the chain of a late-paid difference order at itself, its cents marked late" testRefundLateChain
+  it "is not a group command" $ \_ -> groupCmdAction GROwner "/refund s 10000" `shouldBe` IgnoreMsg
+
+refundRaw :: HasCallStack => ChatController -> Text -> IO (Either Text Text)
+refundRaw cc args = operatorCmd cc ("//refund " <> args)
+
+minuteText :: UTCTime -> Text
+minuteText = T.pack . formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC"
+
+testRefundRecorded :: HasCallStack => TestParams -> IO ()
+testRefundRecorded ps = withStoreService ps $ \_ _ cc -> do
+  let st = chatStore cc
+      paidBy = "order s: $100.00 by btc on invoice inv-s"
+  Balances.source st "s" 10000
+  refundRaw cc "s" `shouldReturn` Right ("Order s: balance $100.00 (credited $100.00, refunded $0.00). Paid by: " <> paidBy <> ". To record its refund: //refund s 10000")
+  logs <- capturingStderr $ refundRaw cc "inv-s 10000" `shouldReturn` Right ("Recorded a refund of $100.00 for order s. Refund it now, by: " <> paidBy <> ".")
+  logs `shouldSatisfy` T.isInfixOf "names: recorded a refund of 10000 cents for order s"
+  Balances.figures st "s" t0 `shouldReturn` Just (0, 10000, 10000, Nothing)
+  refundRaw cc "inv-s" `shouldReturn` Right ("Order s: balance $0.00 (credited $100.00, refunded $100.00). Paid by: " <> paidBy <> ". Nothing to refund.")
+  Balances.credit st "s" 2505
+  refundRaw cc "s 2505" `shouldReturn` Right ("Recorded a refund of $25.05 for order s. Refund it now, by: " <> paidBy <> ".")
+  Balances.figures st "s" t0 `shouldReturn` Just (0, 12505, 12505, Nothing)
+
+testRefundRefusals :: HasCallStack => TestParams -> IO ()
+testRefundRefusals ps = withStoreService ps $ \_ _ cc -> do
+  let st = chatStore cc
+  Balances.placeOrderRow st "plain" False 20000 t0
+  Balances.source st "s" 10000
+  refundRaw cc "nothing" `shouldReturn` Left "No order has the reference nothing."
+  refundRaw cc "nothing 10000" `shouldReturn` Left "Nothing recorded: no order has the reference nothing."
+  refundRaw cc "inv-plain" `shouldReturn` Left "Order plain has no balance."
+  refundRaw cc "inv-plain 20000" `shouldReturn` Left "Nothing recorded: the order of inv-plain has no balance."
+  refundRaw cc "s 9000" `shouldReturn` Left "Nothing recorded: the balance is $100.00 now, not $90.00."
+  refundRaw cc "s 10001" `shouldReturn` Left "Nothing recorded: the balance is $100.00 now, not $100.01."
+  forM_ ["", "s 0", "s -5", "s 100.00", "s 10000 junk", "s 99999999999999999999"] $ \args ->
+    (args,) <$> refundRaw cc args `shouldReturn` (args, Left badgeCmdUsage)
+  Balances.figures st "s" t0 `shouldReturn` Just (10000, 10000, 0, Nothing)
+
+-- | The source s with a balance of $100.00 and the order h holding it, whose invoice expires at the given time.
+heldSource :: ChatController -> UTCTime -> IO ()
+heldSource cc expiry = do
+  Balances.source (chatStore cc) "s" 10000
+  Balances.holder (chatStore cc) "h" "s" 10000 expiry `shouldReturn` Right ()
+
+heldRefusals :: HasCallStack => ChatController -> Text -> IO ()
+heldRefusals cc held = do
+  refundRaw cc "s" `shouldReturn` Right ("Order s: balance $100.00 (credited $100.00, refunded $0.00). Paid by: order s: $100.00 by btc on invoice inv-s. It cannot be refunded now: " <> held <> ".")
+  refundRaw cc "inv-s 10000" `shouldReturn` Left ("Nothing recorded: " <> held <> ".")
+  Balances.figures (chatStore cc) "s" t0 >>= (`shouldSatisfy` \case Just (10000, 10000, 0, Just _) -> True; _ -> False)
+
+recordedS :: Either Text Text
+recordedS = Right "Recorded a refund of $100.00 for order s. Refund it now, by: order s: $100.00 by btc on invoice inv-s."
+
+testRefundOpenHolder :: HasCallStack => TestParams -> IO ()
+testRefundOpenHolder ps = withStoreService ps $ \_ _ cc -> do
+  now <- getCurrentTime
+  let expiry = addUTCTime 3600 now
+  heldSource cc expiry
+  heldRefusals cc $ "held by order h, its invoice open until " <> minuteText expiry <> "; run the command again then"
+  waiters <- newWaiters
+  cancelOpenInvoice (chatStore cc) waiters Nothing (InvoiceId "inv-h") now `shouldReturn` True
+  refundRaw cc "s 10000" `shouldReturn` recordedS
+
+testRefundOverdueHolder :: HasCallStack => TestParams -> IO ()
+testRefundOverdueHolder ps = withStoreService ps $ \_ _ cc -> do
+  now <- getCurrentTime
+  let expiry = addUTCTime (-120) now
+  heldSource cc expiry
+  heldRefusals cc $ "held by order h, its invoice expired at " <> minuteText expiry <> "; start the service so the poller closes that order, 10 minutes after the expiry at the earliest, then stop it and run //refund again"
+  waiters <- newWaiters
+  expireOverdue (chatStore cc) waiters Nothing now now [InvoiceId "inv-h"] `shouldReturn` [InvoiceId "inv-h"]
+  refundRaw cc "s 10000" `shouldReturn` recordedS
+
+testRefundFundedHolder :: HasCallStack => TestParams -> IO ()
+testRefundFundedHolder ps = withStoreService ps $ \_ _ cc -> do
+  now <- getCurrentTime
+  let expiry = addUTCTime (-120) now
+  heldSource cc expiry
+  Balances.payment (chatStore cc) "inv-h" (Balances.cardPaid 100 0) now
+  heldRefusals cc $ "held by order h, whose invoice expired at " <> minuteText expiry <> " holding money; it holds until that payment settles or the invoice closes; run the command again then"
+
+testRefundChain :: HasCallStack => TestParams -> IO ()
+testRefundChain ps = withStoreService ps $ \_ _ cc -> do
+  let st = chatStore cc
+  Balances.source st "a" 20000
+  Balances.holder st "b" "a" 20000 t0 `shouldReturn` Right ()
+  b <- reg st "b"
+  withTransaction st (`Balances.settleHolder` b) `shouldReturn` True
+  taken st "b"
+  Balances.credit st "b" 40000
+  Balances.coveredSpend st "c" "b" 10000 40000 `shouldReturn` Right ()
+  taken st "c"
+  Balances.credit st "c" 10000
+  refundRaw cc "c"
+    `shouldReturn` Right
+      ( "Order c: balance $100.00 (credited $100.00, refunded $0.00). Paid by: order c: $100.00 from the balance of order b; "
+          <> "order b: $200.00 by btc on invoice inv-b, $200.00 from the balance of order a; order a: $200.00 by btc on invoice inv-a. "
+          <> "To record its refund: //refund c 10000"
+      )
+  where
+    taken :: DBStore -> Text -> IO ()
+    taken st r = do
+      queued <- reg st r
+      write st queued {nrPhase = PTaken} `shouldReturn` Written (nrVersion queued + 1)
+
+testRefundLateChain :: HasCallStack => TestParams -> IO ()
+testRefundLateChain ps = withStoreService ps $ \_ _ cc -> do
+  let st = chatStore cc
+      paidBy = "order d: $24.00 late by btc on invoice inv-d"
+  Balances.source st "s" 15000
+  Balances.holder st "d" "s" 15000 t0 `shouldReturn` Right ()
+  waiters <- newWaiters
+  cancelOpenInvoice st waiters Nothing (InvoiceId "inv-d") t0 `shouldReturn` True
+  Balances.creditLate st (Balances.lateCredit "d" 1 (Just 40000) 2400) `shouldReturn` True
+  refundRaw cc "inv-d" `shouldReturn` Right ("Order d: balance $24.00 (credited $24.00, refunded $0.00). Paid by: " <> paidBy <> ". To record its refund: //refund inv-d 2400")
+  refundRaw cc "inv-d 2400" `shouldReturn` Right ("Recorded a refund of $24.00 for order d. Refund it now, by: " <> paidBy <> ".")
+  Balances.figures st "s" t0 `shouldReturn` Just (15000, 15000, 0, Nothing)
+
 data TurnHolder a = TurnHolder {thAction :: Async a, thRelease :: MVar ()}
 
 -- | Runs the action until its body is inside the turn, where the body waits for the release.

tests/Bots/StoreService/NamesBalancesTests.hs

@@ -5,7 +5,7 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeOperators #-}
 
-module Bots.StoreService.NamesBalancesTests (namesBalancesTests, fieldsN, figures, holdPrice, holder, invariantHolds, placeOrderRow, source) where
+module Bots.StoreService.NamesBalancesTests (namesBalancesTests, cardPaid, coveredSpend, credit, creditLate, fieldsN, figures, holdPrice, holder, invariantHolds, lateCredit, payment, placeOrderRow, settleHolder, source) where
 
 import Bots.StoreService.NamesOrdersTests (Ctx (..), withOrders)
 import Bots.StoreService.NamesStoreTests (at, btc, invoiceStatus, newReg, ownerA, ownerB, paidOrder, reg, signature, t0, write)

tests/Test.hs

@@ -160,6 +160,7 @@ main = do
           describe "StoreService names: boot" namesBootTests
           describe "StoreService names: worker" namesWorkerBootTests
           namesCodesChatTests
+          namesRefundChatTests
           namesProfilesChatTests
           describe "Remote session" remoteTests
 #if !defined(dbPostgres)