store: keep a taken order's worth as a balance

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

@@ -276,11 +276,9 @@ checkPrice ct len years price =
 unixSeconds :: UTCTime -> Integer
 unixSeconds = floor . utcTimeToPOSIXSeconds
 
--- | A paid order that lost its name, any failed order, and one whose reveal was refused for its links can move to another name.
+-- | A failed order, and one whose reveal was refused for its links, can move to another name.
 movable :: NameRegistration -> Bool
-movable NameRegistration {nrPhase, nrPayment, nrLinksRefusedAt} = case nrPhase of
-  PTaken | RPInvoice {} <- nrPayment -> True
-  PTaken | RPBalance <- nrPayment -> True
+movable NameRegistration {nrPhase, nrLinksRefusedAt} = case nrPhase of
   PFailed -> True
   PCommitted -> isJust nrLinksRefusedAt
   _ -> False

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

@@ -683,19 +683,16 @@ closeOverdue db r@NameRegistration {nrId = regId@(RegistrationId rid), nrVersion
 
 -- | Whether an order can still progress to a registration for its name. The unique live indexes allow one such order per commitment,
 -- and one per owner and label hash, so a wallet can order a name again once its registration is done.
--- An unpaid order is live while its invoice is open, which nrLive carries; a paid order that lost its name can move to another one.
+-- An unpaid order is live while its invoice is open, which nrLive carries; a taken order is final, its worth kept as a balance.
 orderLive :: NameRegistration -> Bool
-orderLive NameRegistration {nrPhase, nrPayment, nrLive} = case nrPhase of
+orderLive NameRegistration {nrPhase, nrLive} = case nrPhase of
   PUnpaid -> nrLive
   PQueued -> True
   PCommitting -> True
   PCommitted -> True
   PRegistering -> True
   PFailed -> True
-  PTaken -> case nrPayment of
-    RPInvoice {} -> True
-    RPBalance -> True
-    RPCode _ -> False
+  PTaken -> False
   PRegistered -> False
 
 -- | Writes every changeable field of a registration read at its nrVersion, unless it changed since, with live as orderLive decides.

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

@@ -49,7 +49,7 @@ import StoreService.Names.Reveal (intentOf)
 import StoreService.Names.Revert (RevertName (..))
 import StoreService.Names.Sender (PendingTx, SendError (..), Sender, awaitOutcome, inFlightTransaction, ptHash, submitTransaction)
 import StoreService.Names.Store
-import StoreService.Names.Turns (withLabelTurn)
+import StoreService.Names.Turns (withBalanceTurn, withLabelTurn)
 import StoreService.Names.View (lapseMoment, notSignedInTime, registrationAt, registrationVersion)
 
 data Worker = Worker
@@ -323,14 +323,16 @@ judge w@Worker {wkOrders = oe@OrdersEnv {oeContracts}} now r@NameRegistration {n
                 | otherwise -> failed w now r reason
           Nothing -> failed w now r reason
 
--- | The payment is kept, and a code order's code released.
+-- | A paid order keeps its whole price as a balance of its own, credited in the taken write's transaction, registration before balance,
+-- in the balance's turn after the name's; a code order's code is released.
 taken :: Worker -> UTCTime -> NameRegistration -> IO (Maybe Int64, Next)
-taken Worker {wkOrders = OrdersEnv {oeStore, oeTurns}} now r@NameRegistration {nrId, nrPayment} = case nrPayment of
-  RPInvoice {} -> written r <$> withTransaction oeStore write
-  RPBalance -> written r <$> withTransaction oeStore write
+taken Worker {wkOrders = OrdersEnv {oeStore, oeTurns}} now r@NameRegistration {nrId, nrPayment, nrPrice} = case nrPayment of
+  RPInvoice {} -> credited
+  RPBalance -> credited
   RPCode codeId -> written r . fmap fst <$> releaseCode oeTurns oeStore codeId nrId write
   where
     write db = versionWritten <$> updateRegistration db r {nrPhase = PTaken, nrError = Nothing} now
+    credited = written r <$> withBalanceTurn oeTurns nrId (withTransaction oeStore $ \db -> write db >>= traverse (\v -> v <$ creditBalance db nrId nrPrice now))
 
 -- | A code order keeps its code for Try again.
 failed :: Worker -> UTCTime -> NameRegistration -> Maybe RevertName -> IO (Maybe Int64, Next)

tests/Bots/StoreService/NamesOwnerTests.hs

@@ -83,7 +83,7 @@ namesOwnerTests = describe "StoreService names: owner" $ do
     it "lists the owner's orders newest first, a moved, an unpaid and a lapsed one read failed included, at most 50, and 404 for none" testFind
     it "refuses another signer's signature, a stale timestamp and a malformed body" testFindRefused
   describe "another name" $ do
-    it "refuses a move from registered, queued, and committed without a refused reveal" testMoveRefusedPhases
+    it "refuses a move from registered, queued, taken, and committed without a refused reveal" testMoveRefusedPhases
     it "moves a failed order, a lapsed one, and a committed one whose links were refused, to the same name with other links too" testMoveAccepted
     it "answers a body equal to the current fields with the view unchanged, counting no move, whatever its timestamp" testMoveRepeat
     it "answers the fourth move move_limit with the current view, changing nothing" testMoveLimit
@@ -386,7 +386,8 @@ testMoveRefusedPhases = withOwner $ \ctx -> do
   registeredOrder <- paidIn ctx aliceOrder registeredPhase
   committedOrder <- paidIn ctx aliceOrder {oCommitment = commitmentOf 2, oTimestamp = seconds orderTime + 1} committedPhase
   queuedOrder <- paidIn ctx dynamisOrder id
-  forM_ [registeredOrder, committedOrder, queuedOrder] $ \r -> do
+  takenOrder <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 4} takenPhase
+  forM_ [registeredOrder, committedOrder, queuedOrder, takenOrder] $ \r -> do
     (nrPhase r,) <$> move ctx keyA r to `shouldReturn` (nrPhase r, refusedWith 400 "bad_request")
     stored ctx r `shouldReturn` r
 

tests/Bots/StoreService/NamesStoreTests.hs

@@ -503,9 +503,10 @@ testLiveFollowsPhase = withServiceStore $ \st -> do
         write st r {nrPhase = phase} `shouldReturn` Written (nrVersion r + 1)
         (nrPhase &&& nrLive) <$> reg st rid `shouldReturn` (phase, expected)
   step "r1" PQueued True
-  step "r1" PTaken True
   step "r1" PFailed True
-  step "r1" PTaken True
+  step "r1" PTaken False
+  r1 <- reg st "r1"
+  write st r1 {nrPhase = PFailed} `shouldReturn` NotLive
   step "r2" PRegistering True
   step "r2" PTaken False
   placePaid st "r3" ownerA (order "carolsbakery" 3) (at 60) `shouldReturn` Right ()
@@ -520,7 +521,7 @@ testOrderLive = withServiceStore $ \st -> do
   let code = paid {nrPayment = RPCode 1}
       liveIn r phase = (phase, orderLive r {nrPhase = phase})
   map (liveIn paid) [minBound .. maxBound]
-    `shouldBe` [(PUnpaid, True), (PQueued, True), (PCommitting, True), (PCommitted, True), (PRegistering, True), (PRegistered, False), (PTaken, True), (PFailed, True)]
+    `shouldBe` [(PUnpaid, True), (PQueued, True), (PCommitting, True), (PCommitted, True), (PRegistering, True), (PRegistered, False), (PTaken, False), (PFailed, True)]
   map (liveIn code) [PTaken, PFailed, PRegistered] `shouldBe` [(PTaken, False), (PFailed, True), (PRegistered, False)]
   orderLive paid {nrLive = False} `shouldBe` False
   orderLive paid {nrLive = False, nrPhase = PQueued} `shouldBe` True
@@ -559,13 +560,13 @@ testWriteMeetsLiveOrder = withServiceStore $ \st -> do
   placePaid st "r2" ownerA held (at 60) `shouldReturn` Right ()
   placePaid st "r3" ownerB (order "carolsbakery" 3) (at 60) `shouldReturn` Right ()
   r1 <- reg st "r1"
-  write st r1 {nrPhase = PTaken} `shouldReturn` Written 2
-  taken <- reg st "r1"
-  let retarget o = withTransaction st $ \db -> retargetRegistration db taken o 10000 (at 6)
+  write st r1 {nrPhase = PFailed} `shouldReturn` Written 2
+  failed <- reg st "r1"
+  let retarget o = withTransaction st $ \db -> retargetRegistration db failed o 10000 (at 6)
   retarget held {ofCommitment = digestFixture 4} `shouldReturn` LiveOrderExists
   r3 <- reg st "r3"
   retarget (order "carolsbakery" 5) {ofCommitment = nrCommitment r3} `shouldReturn` LiveOrderExists
-  reg st "r1" `shouldReturn` taken
+  reg st "r1" `shouldReturn` failed
   retarget (order "davesbakery" 6) `shouldReturn` Written 3
 
 testRetarget :: IO ()
@@ -574,9 +575,9 @@ testRetarget = withServiceStore $ \st -> do
       o' = order "alicebakers" 2
   placePaid st "r1" ownerA o (at 60) `shouldReturn` Right ()
   r <- reg st "r1"
-  let taken =
+  let failed =
         r
-          { nrPhase = PTaken,
+          { nrPhase = PFailed,
             nrReveal = Just reveal,
             nrCommitTx = Just (TxHash $ digestFixture 8),
             nrCommitBlock = Just 100,
@@ -588,8 +589,8 @@ testRetarget = withServiceStore $ \st -> do
             nrFailedAt = Just (at 5),
             nrError = Just "failed"
           }
-  write st taken `shouldReturn` Written 2
-  withTransaction st (\db -> retargetRegistration db taken {nrVersion = 2} o' 10000 (at 6)) `shouldReturn` Written 3
+  write st failed `shouldReturn` Written 2
+  withTransaction st (\db -> retargetRegistration db failed {nrVersion = 2} o' 10000 (at 6)) `shouldReturn` Written 3
   r' <- reg st "r1"
   r'
     `shouldBe` r
@@ -602,7 +603,7 @@ testRetarget = withServiceStore $ \st -> do
         nrMoves = 1,
         nrUpdatedAt = at 6
       }
-  withTransaction st (\db -> retargetRegistration db taken {nrVersion = 2} o 10000 (at 7)) `shouldReturn` VersionChanged
+  withTransaction st (\db -> retargetRegistration db failed {nrVersion = 2} o 10000 (at 7)) `shouldReturn` VersionChanged
 
 testFind :: IO ()
 testFind = withServiceStore $ \st -> do

tests/Bots/StoreService/NamesWorkerTests.hs

@@ -10,11 +10,14 @@ import Bots.StoreService.NamesContractsTests (availableCall, maxCommitmentAgeCal
 import Bots.StoreService.NamesOrdersTests
 import Bots.StoreService.NamesOwnerTests (answerExpiry, answerFree, answerOwner, answerUnowned, byB, codeIn, committedPhase, dynamisOrder, failedPhase, labelBytes, ownerOfSelector, paidIn, rewrite, sentRegister, stored)
 import Bots.StoreService.NamesPhasesTests (held, prompt, registrationPath, woken)
-import Bots.StoreService.NamesStoreTests (reveal)
+import Bots.StoreService.NamesStoreTests (btc, insertInvoiceRow, ownerA, paidOrder, reveal)
 import Bots.StoreService.WebTests (capturingStderr, jsonObject, statusOf, webGet, webRequestBody)
 import Control.Applicative ((<|>))
 import Control.Arrow ((&&&))
+import Control.Concurrent (threadDelay)
+import qualified Control.Concurrent.Async as Async
 import Control.Concurrent.Async (wait, withAsync)
+import qualified Control.Exception as E
 import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
 import Control.Concurrent.STM (atomically, check)
 import Control.Monad (forM_, replicateM, replicateM_, void)
@@ -30,6 +33,7 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
 import Data.Word (Word64)
 import Network.HTTP.Client (defaultManagerSettings, newManager)
 import qualified Network.Wai.Handler.Warp as Warp
+import Simplex.Chat.PaymentService.Types (InvoiceId (..), InvoiceStatus (..))
 import Simplex.Messaging.Agent.Store.Common (withTransaction)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Crypto (keccak256)
@@ -43,6 +47,7 @@ import StoreService.Names.Phases (RegistrationId (..), awaitChange)
 import StoreService.Names.Registration (RegisterIntent (..), commitCalldata, registerIntentDigest, registerWithCreditCalldata, sponsorDomain)
 import StoreService.Names.Reveal (intentOf)
 import StoreService.Names.Sender
+import StoreService.Names.Signatures (OrderFields (..))
 import StoreService.Names.Store
 import StoreService.Names.Turns (labelTurnCount, withLabelTurn)
 import StoreService.Names.Worker
@@ -54,7 +59,16 @@ import System.Timeout (timeout)
 import Test.Hspec
 
 namesWorkerTests :: Spec
-namesWorkerTests = describe "StoreService names: worker" $ do
+namesWorkerTests = workerTests >> takenBalanceTests
+
+takenBalanceTests :: Spec
+takenBalanceTests = describe "StoreService names: balance life" $ describe "taken" $ do
+  it "credits a taken order paid wholly from a balance, and one paid partly, its whole price as a balance of its own, the source's left as it was" testTakenFromBalance
+  it "leaves the order as it was when the taken write's credit is refused, in one transaction" testTakenCreditRefused
+  it "wakes a held poll with the taken write, and not with a change of the order's balance" testTakenWakesPoll
+
+workerTests :: Spec
+workerTests = describe "StoreService names: worker" $ do
   describe "commit" $ do
     it "commits, waits for the reveal and revealAfter, and registers a code order, spending its code and publishing each change" testCommitWaitRegister
     it "waits for a pending commit without sending another, following its fee-bumped replacement" testPendingCommit
@@ -68,8 +82,8 @@ namesWorkerTests = describe "StoreService names: worker" $ do
     it "writes nothing when the registration changed since it was read" testLostRace
     it "writes in the name's turn" testInNameTurn
   describe "register" $ do
-    it "ends the later of two wallets' paid orders for one name taken, with its value kept" testTwoWallets
-    it "ends taken on any revert while the name is not available, releasing a code" testRevertTaken
+    it "ends the later of two wallets' paid orders for one name taken, not live, with a balance of its price" testTwoWallets
+    it "ends taken on any revert while the name is not available, releasing a code and keeping no balance" testRevertTaken
     it "keeps the phase on NameNotAvailable while the name still reads available, as for a pending competitor" testPendingCompetitor
     it "ends failed on a revert while the name is available, alerting on InsufficientAllowance and keeping a code" testRevertFailed
     it "clears the reveal on InvalidNonce, staying committed" testInvalidNonce
@@ -484,9 +498,78 @@ testTwoWallets = withWorker $ \w@W {wCtx = ctx} -> do
   dryRunsRevert w "NameNotAvailable(string)" $ abiTuple [Dynamic $ abiBytes "alicebakery"]
   published w b (steps w b) >>= done
   x <- stored ctx b
-  (nrPhase x, nrLive x, nrPrice x, nrPayment x, nrError x) `shouldBe` (PTaken, True, nrPrice b, nrPayment b, Nothing)
+  (nrPhase x, nrLive x, nrPrice x, nrPayment x, nrError x) `shouldBe` (PTaken, False, nrPrice b, nrPayment b, Nothing)
+  fmap (\Balance {blAmount, blCredited, blHold} -> (blAmount, blCredited, blHold)) <$> withTransaction (cStore ctx) (\db -> getBalance db (nrId b) orderTime)
+    `shouldReturn` Just (nrPrice b, nrPrice b, Nothing)
   length <$> sent w `shouldReturn` 1
 
+-- | The order of alicebakery, by owner A, with this commitment.
+aliceFields :: Int -> OrderFields
+aliceFields n = OrderFields {ofLabelHash = labelHash "alicebakery", ofLength = 11, ofDuration = yearsDuration 2 orderTime, ofCommitment = commitmentOf n, ofSealed = "sealed-alicebakery-" <> tshow n}
+
+aliceRegistration :: Text -> Int -> NewRegistration
+aliceRegistration rid n = NewRegistration {nrgId = RegistrationId rid, nrgOwner = ownerA, nrgOrder = aliceFields n, nrgYears = 2}
+
+-- | The amount and credited of the order's balance.
+balanceFigures :: Ctx -> RegistrationId -> IO (Maybe (Int, Int))
+balanceFigures Ctx {cStore} rid = fmap (\Balance {blAmount, blCredited} -> (blAmount, blCredited)) <$> withTransaction cStore (\db -> getBalance db rid orderTime)
+
+-- | The register's dry run reverts on a name someone else holds, so the registration ends taken.
+endsTaken :: W -> NameRegistration -> IO ()
+endsTaken w@W {wCtx = Ctx {cNode}} r = do
+  answerAvailable w False
+  setFault cNode "eth_estimateGas" $ RpcError 3 "execution reverted: ERC721: invalid token ID" Nothing
+  published w r (steps w r) >>= done
+
+testTakenFromBalance :: IO ()
+testTakenFromBalance = withWorker $ \w@W {wCtx = ctx@Ctx {cStore}} -> do
+  let price = oPrice aliceOrder
+  wholly <- paidIn ctx (byB dynamisOrder) failedPhase
+  partly <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 5} failedPhase
+  withTransaction cStore $ \db -> creditBalance db (nrId wholly) 30000 orderTime >> creditBalance db (nrId partly) 4000 orderTime
+  withTransaction cStore (\db -> createBalanceRegistration db (aliceRegistration "covered" 1) (nrId wholly) price 30000 orderTime) `shouldReturn` Right ()
+  covered <- registrationById ctx (RegistrationId "covered") >>= \r -> rewrite ctx r openPhase >>= revealed ctx keyA "alicebakery"
+  endsTaken w covered
+  (\x -> (nrPhase x, nrLive x, nrPayment x)) <$> stored ctx covered `shouldReturn` (PTaken, False, RPBalance)
+  balanceFigures ctx (nrId covered) `shouldReturn` Just (price, price)
+  balanceFigures ctx (nrId wholly) `shouldReturn` Just (30000 - price, 30000)
+  withTransaction cStore $ \db -> do
+    insertInvoiceRow db "inv-diff" (addUTCTime 3600 orderTime) "open"
+    createPaidRegistration db (aliceRegistration "diff" 2) (OTBalance (nrId partly) price 4000 (Just btc)) (paidOrder "inv-diff") {poPrice = price} orderTime `shouldReturn` Right ()
+  settleNow ctx (InvoiceId "inv-diff") settled `shouldReturn` Right ISPaid
+  balanceFigures ctx (nrId partly) `shouldReturn` Just (0, 4000)
+  diff <- registrationById ctx (RegistrationId "diff") >>= \r -> rewrite ctx r openPhase >>= revealed ctx keyA "alicebakery"
+  endsTaken w diff
+  nrPhase <$> stored ctx diff `shouldReturn` PTaken
+  balanceFigures ctx (nrId diff) `shouldReturn` Just (price, price)
+  balanceFigures ctx (nrId partly) `shouldReturn` Just (0, 4000)
+
+-- | A price the balance's CHECK refuses makes the credit fail inside the taken write's transaction.
+testTakenCreditRefused :: IO ()
+testTakenCreditRefused = withWorker $ \w@W {wCtx = ctx@Ctx {cStore, cNode}} -> do
+  r <- paidIn ctx aliceOrder openPhase >>= revealed ctx keyA "alicebakery"
+  withTransaction cStore $ \db -> DB.execute db "UPDATE sx_badge_service_name_registrations SET price = -1 WHERE registration_id = ?" [(\(RegistrationId t) -> t) $ nrId r]
+  unchanged <- stored ctx r
+  answerAvailable w False
+  setFault cNode "eth_estimateGas" $ RpcError 3 "execution reverted: ERC721: invalid token ID" Nothing
+  void (E.try (steps w r) :: IO (Either E.SomeException Next))
+  stored ctx r `shouldReturn` unchanged
+  balanceFigures ctx (nrId r) `shouldReturn` Nothing
+
+testTakenWakesPoll :: IO ()
+testTakenWakesPoll = withWorker $ \w@W {wCtx = ctx@Ctx {cStore}} -> do
+  r <- paidIn ctx aliceOrder openPhase >>= revealed ctx keyA "alicebakery"
+  waiting <- held ctx (0, 1) $ registrationPath (nrId r) <> "?seenVersion=" <> show (nrVersion r)
+  withTransaction cStore $ \db -> creditBalance db (nrId r) 500 orderTime
+  threadDelay shortWait
+  isJust <$> Async.poll waiting `shouldReturn` False
+  endsTaken w r
+  (status, view) <- woken "the registration poll" waiting
+  (status, field "phase" view) `shouldBe` (200, Just "taken")
+  balanceFigures ctx (nrId r) `shouldReturn` Just (500 + oPrice aliceOrder, 500 + oPrice aliceOrder)
+  where
+    shortWait = 500000
+
 testPendingCompetitor :: IO ()
 testPendingCompetitor = withWorker $ \w@W {wCtx = ctx} -> do
   (r, code) <- codeIn ctx 8 aliceOrder openPhase >>= traverseFst (revealed ctx keyA "alicebakery")
@@ -512,6 +595,7 @@ testRevertTaken = withWorker $ \w@W {wCtx = ctx@Ctx {cNode}} -> do
   (nrPhase x, nrLive x) `shouldBe` (PTaken, False)
   PrepaidCode {pcReservedBy, pcSpentAt} <- codeOf ctx code
   (pcReservedBy, pcSpentAt) `shouldBe` (Nothing, Nothing)
+  balanceFigures ctx (nrId r) `shouldReturn` Nothing
   sent w `shouldReturn` []
 
 testRevertFailed :: IO ()