store: add the //refund operator command

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 <> "; the poller closes it within " <> tshow graceMinutes <> " minutes; run the command again then"
+  | 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)
@@ -290,6 +295,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 <> "; the poller closes it within 10 minutes; run the command again then"
+  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) where
+module Bots.StoreService.NamesBalancesTests (namesBalancesTests, cardPaid, coveredSpend, credit, creditLate, figures, holder, 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

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