store: record a balance's refund

apps/simplex-store-service/src/StoreService/Names/Balances.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module StoreService.Names.Balances
+  ( RefundRefusal (..),
+    RefundRecord (..),
+    recordRefund,
+  )
+where
+
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import Data.Time.Clock (UTCTime)
+import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
+import StoreService.Names.Phases (RegistrationId)
+import StoreService.Names.Store (Balance (..), BalanceHold, BalanceLink, balanceByReference, balanceChain, refundBalance)
+import StoreService.Names.Turns (Turns, withBalanceTurn)
+
+-- | RefundAmount: the balance's amount now, which is not the cents given. RefundHeld: an order holds it, overdue or not,
+-- since only the poller's sweep can close a holder and cancel its invoice at the provider.
+data RefundRefusal = RefundNoOrder | RefundNoBalance | RefundAmount Int | RefundHeld BalanceHold
+  deriving (Eq, Show)
+
+-- | The chain names every order the money came through, for support to pay it back by the methods that paid it.
+data RefundRecord = RefundRecord
+  { rdRegistration :: RegistrationId,
+    rdCents :: Int,
+    rdChain :: [BalanceLink]
+  }
+  deriving (Eq, Show)
+
+-- | The reference is the order's registration id or its name invoice's id. In the balance's turn and one transaction.
+recordRefund :: Turns -> DBStore -> Text -> Int -> UTCTime -> IO (Either RefundRefusal RefundRecord)
+recordRefund turns st ref cents now =
+  withTransaction st (\db -> balanceByReference db ref now) >>= \case
+    Nothing -> pure $ Left RefundNoOrder
+    Just (rid, _) -> withBalanceTurn turns rid $ withTransaction st refund
+  where
+    refund db =
+      balanceByReference db ref now >>= \case
+        Nothing -> pure $ Left RefundNoOrder
+        Just (rid, balance) -> case refusal balance of
+          Just r -> pure $ Left r
+          Nothing ->
+            refundBalance db rid cents now >>= \case
+              True -> Right . RefundRecord rid cents <$> balanceChain db rid
+              -- only a writer outside the turn, as a late credit, can change the balance between the read and the write
+              False -> Left . fromMaybe (RefundAmount cents) . refusal . (snd =<<) <$> balanceByReference db ref now
+    refusal :: Maybe Balance -> Maybe RefundRefusal
+    refusal = \case
+      Nothing -> Just RefundNoBalance
+      Just Balance {blHold = Just hold} -> Just $ RefundHeld hold
+      Just Balance {blAmount}
+        | blAmount /= cents || blAmount <= 0 -> Just $ RefundAmount blAmount
+        | otherwise -> Nothing

simplex-chat.cabal

@@ -443,6 +443,7 @@ executable simplex-store-service
       StoreService.Group.Command
       StoreService.Log
       StoreService.Names.Abi
+      StoreService.Names.Balances
       StoreService.Names.Chain
       StoreService.Names.Codes
       StoreService.Names.Contracts
@@ -807,6 +808,7 @@ test-suite simplex-chat-test
       StoreService.Group.Command
       StoreService.Log
       StoreService.Names.Abi
+      StoreService.Names.Balances
       StoreService.Names.Chain
       StoreService.Names.Codes
       StoreService.Names.Contracts

tests/Bots/StoreService/NamesBalancesTests.hs

@@ -26,6 +26,7 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.SimplexName (labelHash)
 import StoreService.Config (ServiceConfig (..))
+import StoreService.Names.Balances
 import StoreService.Names.Orders (ClosedOrder (..), OrderRefusal (..), OrderRequest (..), OrdersEnv (..))
 import qualified StoreService.Names.Orders as Orders
 import StoreService.Names.Phases (RegistrationId (..))
@@ -71,6 +72,8 @@ namesBalancesTests = describe "StoreService names: balances" $ do
     it "reads an overdue holder's hold as none, and closes it in the transaction of the order placed" testOverdueHolderClosed
     it "skips a named holder no longer live, and refuses with the balance when a live one cannot be closed" testNamedHolders
     it "keeps at the cleanup, and logs, an unpaid order still holding a balance" testCleanupKeepsHolder
+  describe "refunds" $ do
+    it "refuses no order, no balance, a balance held by an open or overdue holder, and another amount, then records one with its chain" testRecordRefund
   describe "late credits" $ do
     it "credits a late payment once per credit number, a taken number changing neither the rows nor the balance" testCreditLatePayment
     it "tells each case of pending money and selects confirmed money not all credited, by the order whatever the invoice's status" testLateScans
@@ -506,6 +509,31 @@ testCleanupKeepsHolder = withOrders $ \Ctx {cStore = st, cWeb} -> do
   nrLive <$> reg st "h" `shouldReturn` True
   figures st "s" due `shouldReturn` Just (10000, 10000, 0, Just $ hold "h" t0 True)
 
+-- refunds
+
+testRecordRefund :: IO ()
+testRecordRefund = withServiceStore $ \st -> do
+  turns <- newTurns
+  waiters <- newWaiters
+  source st "s" 10000
+  placeOrderRow st "plain" False 20000 (at 60)
+  holder st "h" "s" 10000 (at 60) `shouldReturn` Right ()
+  let refundOf :: Text -> Int -> UTCTime -> IO (Either RefundRefusal RefundRecord)
+      refundOf ref cents now = recordRefund turns st ref cents now
+  refundOf "nothing" 10000 t0 `shouldReturn` Left RefundNoOrder
+  refundOf "plain" 20000 t0 `shouldReturn` Left RefundNoBalance
+  refundOf "s" 10000 t0 `shouldReturn` Left (RefundHeld $ hold "h" (at 60) False)
+  refundOf "inv-s" 10000 (at 61) `shouldReturn` Left (RefundHeld $ hold "h" (at 60) True)
+  figures st "s" t0 `shouldReturn` Just (10000, 10000, 0, Just $ hold "h" (at 60) False)
+  cancelOpenInvoice st waiters Nothing (InvoiceId "inv-h") (at 2) `shouldReturn` True
+  refundOf "s" 9000 t0 `shouldReturn` Left (RefundAmount 10000)
+  chain <- withTransaction st $ \db -> balanceChain db (RegistrationId "s")
+  chain `shouldBe` [BalanceLink {lkRegistration = RegistrationId "s", lkPayment = RPInvoice btc (InvoiceId "inv-s"), lkPaid = 10000, lkFromBalance = 0, lkLateCredits = []}]
+  refundOf "inv-s" 10000 t0 `shouldReturn` Right RefundRecord {rdRegistration = RegistrationId "s", rdCents = 10000, rdChain = chain}
+  figures st "s" t0 `shouldReturn` Just (0, 10000, 10000, Nothing)
+  refundOf "s" 10000 t0 `shouldReturn` Left (RefundAmount 0)
+  turnsCount turns `shouldReturn` 0
+
 -- late credits
 
 testCreditLatePayment :: IO ()