diff --git a/apps/simplex-store-service/src/StoreService/Names/Orders.hs b/apps/simplex-store-service/src/StoreService/Names/Orders.hs index bedf470508..f23383617d 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Orders.hs +++ b/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 diff --git a/apps/simplex-store-service/src/StoreService/Names/Store.hs b/apps/simplex-store-service/src/StoreService/Names/Store.hs index e5bd7a038a..03640f3b59 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Store.hs +++ b/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. diff --git a/apps/simplex-store-service/src/StoreService/Names/Worker.hs b/apps/simplex-store-service/src/StoreService/Names/Worker.hs index 6e1b4c7a03..3b0de170f3 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Worker.hs +++ b/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) diff --git a/tests/Bots/StoreService/NamesOwnerTests.hs b/tests/Bots/StoreService/NamesOwnerTests.hs index fe83bd45a8..2d3360e631 100644 --- a/tests/Bots/StoreService/NamesOwnerTests.hs +++ b/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 diff --git a/tests/Bots/StoreService/NamesStoreTests.hs b/tests/Bots/StoreService/NamesStoreTests.hs index 2832a0e124..975110643c 100644 --- a/tests/Bots/StoreService/NamesStoreTests.hs +++ b/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 diff --git a/tests/Bots/StoreService/NamesWorkerTests.hs b/tests/Bots/StoreService/NamesWorkerTests.hs index 416abd9857..043ea190fd 100644 --- a/tests/Bots/StoreService/NamesWorkerTests.hs +++ b/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 ()