diff --git a/apps/simplex-store-service/src/StoreService/Group.hs b/apps/simplex-store-service/src/StoreService/Group.hs index 2713932875..a4423ba8ef 100644 --- a/apps/simplex-store-service/src/StoreService/Group.hs +++ b/apps/simplex-store-service/src/StoreService/Group.hs @@ -19,6 +19,7 @@ module StoreService.Group TrackerAction (..), trackerDecision, codeInTracker, + fmtTime, noOwnerHint, orphanHint, ) diff --git a/apps/simplex-store-service/src/StoreService/Service.hs b/apps/simplex-store-service/src/StoreService/Service.hs index 714e3e0f01..e39490a7b5 100644 --- a/apps/simplex-store-service/src/StoreService/Service.hs +++ b/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 show minNameLength <> "-" <> show maxNameLength <> "> [years " <> show minNameYears <> "-" <> show maxNameYears - <> "] [paid|unpaid|free], or //revoke " + <> "] [paid|unpaid|free], //revoke , or //refund []" 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 diff --git a/tests/Bots/StoreService/BotTests.hs b/tests/Bots/StoreService/BotTests.hs index c13dd1139b..8b011730e0 100644 --- a/tests/Bots/StoreService/BotTests.hs +++ b/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 [years 2-10] [paid|unpaid|free], or //revoke " +badgeCmdUsage = "Usage: //issue supporter|legend|investor [months 1-255] [paid|unpaid|free], //issue name [years 2-10] [paid|unpaid|free], //revoke , or //refund []" diff --git a/tests/Bots/StoreService/GroupIntegrationTests.hs b/tests/Bots/StoreService/GroupIntegrationTests.hs index 291cbd6ee9..bc082fe2bd 100644 --- a/tests/Bots/StoreService/GroupIntegrationTests.hs +++ b/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. diff --git a/tests/Bots/StoreService/NamesBalancesTests.hs b/tests/Bots/StoreService/NamesBalancesTests.hs index e3cf572689..e3fa233985 100644 --- a/tests/Bots/StoreService/NamesBalancesTests.hs +++ b/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) diff --git a/tests/Test.hs b/tests/Test.hs index ceccb86c99..61858d67da 100644 --- a/tests/Test.hs +++ b/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)