store: merge owner-signed find, name and code

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

@@ -15,12 +15,14 @@ module StoreService.Names.Codes
     reserveCode,
     releaseCode,
     spendCode,
+    spendLandedCode,
     issueNameCode,
     revokeNameCode,
   )
 where
 
 import Control.Applicative ((<|>))
+import qualified Control.Exception as E
 import Data.ByteString (ByteString)
 import Data.Functor ((<&>))
 import Data.Int (Int64)
@@ -36,7 +38,7 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB
 import StoreService.Config (minNameYears)
 import StoreService.Group.Command (maxNameYears)
 import StoreService.Names.Phases (RegistrationId)
-import StoreService.Names.Store (CodeHashTaken (..), NewPrepaidCode (..), PrepaidCode (..), getPrepaidCode, getPrepaidCodeById, insertPrepaidCode, releasePrepaidCode, reservePrepaidCode, revokePrepaidCode, spendPrepaidCode)
+import StoreService.Names.Store (CodeHashTaken (..), NewPrepaidCode (..), PrepaidCode (..), getPrepaidCode, getPrepaidCodeById, insertPrepaidCode, releasePrepaidCode, reservePrepaidCode, revokePrepaidCode, spendLandedPrepaidCode, spendPrepaidCode)
 import StoreService.Names.Turns (Turns, withCodeTurn)
 import StoreService.Store (RevokeResult (..))
 
@@ -102,24 +104,31 @@ reserveRefusal db now codeHash rid len = maybe CRInvalid (fromMaybe CRReserved .
 readPrepaidCode :: DBStore -> NamePrepaidCode -> IO (Maybe PrepaidCode)
 readPrepaidCode st code = withTransaction st (`getPrepaidCode` namePrepaidCodeHash code)
 
--- | In the code's turn and one transaction, the code is checked and reserved for the registration, then
--- the write runs. A write that refuses gives the code back.
+newtype ReservationRefused = ReservationRefused CodeRefusal
+  deriving (Show)
+
+instance E.Exception ReservationRefused
+
+-- | In the code's turn and one transaction, the code is checked, the write runs, then the code is reserved for the
+-- registration, so the registration's row is locked before the code's. A refused reservation rolls the write back.
 reserveCode :: Turns -> DBStore -> UTCTime -> ByteString -> RegistrationId -> Int -> (DB.Connection -> IO (Either e a)) -> IO (Either CodeRefusal (Either e a))
 reserveCode turns st now codeHash rid len write =
-  withCodeTurn turns codeHash $ withTransaction st $ \db ->
-    getPrepaidCode db codeHash >>= \case
-      Nothing -> pure $ Left CRInvalid
-      Just code@PrepaidCode {pcId, pcReservedBy}
-        | Just refusal <- codeRefusal now rid len code -> pure $ Left refusal
-        | pcReservedBy == Just rid -> Right <$> write db
-        | otherwise ->
-            reservePrepaidCode db pcId rid now >>= \case
-              -- Only a writer outside this process, which takes no turn here, can refuse it.
-              False -> Left <$> reserveRefusal db now codeHash rid len
-              True ->
-                write db >>= \case
-                  refused@(Left _) -> Right refused <$ releasePrepaidCode db pcId rid
-                  written -> pure $ Right written
+  withCodeTurn turns codeHash $ either (\(ReservationRefused refusal) -> Left refusal) id <$> E.try (withTransaction st reserve)
+  where
+    reserve db =
+      getPrepaidCode db codeHash >>= \case
+        Nothing -> pure $ Left CRInvalid
+        Just code@PrepaidCode {pcId, pcReservedBy}
+          | Just refusal <- codeRefusal now rid len code -> pure $ Left refusal
+          | otherwise ->
+              write db >>= \case
+                written@(Right _)
+                  | pcReservedBy /= Just rid ->
+                      reservePrepaidCode db pcId rid now >>= \case
+                        True -> pure $ Right written
+                        -- Only a writer outside this process, which takes no turn here, can refuse it.
+                        False -> E.throwIO . ReservationRefused =<< reserveRefusal db now codeHash rid len
+                written -> pure $ Right written
 
 -- | The write runs first, and the code is released only if it succeeds. False when the registration did not hold the code.
 releaseCode :: Turns -> DBStore -> Int64 -> RegistrationId -> (DB.Connection -> IO (Either e a)) -> IO (Either e (a, Bool))
@@ -129,6 +138,11 @@ releaseCode turns st codeId rid = afterWrite turns st codeId (\db -> releasePrep
 spendCode :: Turns -> DBStore -> UTCTime -> Int64 -> RegistrationId -> (DB.Connection -> IO (Either e a)) -> IO (Either e (a, Bool))
 spendCode turns st now codeId rid = afterWrite turns st codeId (\db -> spendPrepaidCode db codeId rid now)
 
+-- | As spendCode, for a registration whose register went through: a code it no longer holds is spent too while still usable.
+-- False when the code was released and then spent, revoked or expired meanwhile.
+spendLandedCode :: Turns -> DBStore -> UTCTime -> Int64 -> RegistrationId -> (DB.Connection -> IO (Either e a)) -> IO (Either e (a, Bool))
+spendLandedCode turns st now codeId rid = afterWrite turns st codeId (\db -> spendLandedPrepaidCode db codeId rid now)
+
 afterWrite :: Turns -> DBStore -> Int64 -> (DB.Connection -> IO Bool) -> (DB.Connection -> IO (Either e a)) -> IO (Either e (a, Bool))
 afterWrite turns st codeId change write = do
   codeHash_ <- withTransaction st $ \db -> fmap pcCodeHash <$> getPrepaidCodeById db codeId

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
 
 -- | The checks every order runs, by paid invoice or prepaid code, in the contract's order.
 module StoreService.Names.Orders
@@ -10,11 +11,16 @@ module StoreService.Names.Orders
     OrderRefusal (..),
     ExistingOrder (..),
     ClosedOrder (..),
+    WriteRefusal (..),
+    Landing (..),
     maxSealedChars,
     signedRequestSeconds,
     parseOrderRequest,
+    parseOrderFields,
+    textField,
     integerField,
     checkLength,
+    checkSigner,
     checkOrderSigner,
     existingOrder,
     placeOrder,
@@ -24,22 +30,37 @@ module StoreService.Names.Orders
     checkDuration,
     checkNameFree,
     checkPrice,
+    movable,
+    issuable,
+    orderFieldsOf,
+    checkMoveMeets,
+    checkMovePrice,
+    retargetOrder,
+    confirmLanded,
+    issuedCodeHash,
+    checkTakenCodeLength,
+    issueTakenCode,
   )
 where
 
+import Control.Applicative ((<|>))
 import qualified Control.Exception as E
-import Control.Monad (unless, when)
+import Control.Monad (forM, unless, when)
+import Control.Monad.Except (ExceptT (..), runExceptT)
 import qualified Data.Aeson as J
 import qualified Data.Aeson.KeyMap as KM
 import Data.Bifunctor (first)
 import Data.ByteString (ByteString)
 import Data.Int (Int64)
+import Data.Maybe (isJust)
 import Data.Scientific (toBoundedInteger)
+import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock (UTCTime, getCurrentTime)
 import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
 import Data.Word (Word64)
 import Simplex.Chat.Badges.Code (maxNameLength, minNameLength)
+import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..))
 import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Crypto.Secp256k1 (RecoverableSignature)
@@ -47,14 +68,14 @@ import Simplex.Messaging.Eth.Address (Address, recoverAddress)
 import Simplex.Messaging.SimplexName (LabelHash (..))
 import Simplex.Messaging.Util (tshow)
 import StoreService.Config (NamesConfig (..))
-import StoreService.Log (logWarn)
-import StoreService.Names.Codes (CodeRefusal (..), codeRefusal, reserveRefusal)
-import StoreService.Names.Contracts (Contracts, NameStatus (..), chainPriceCents, nameStatus, secondsPerYear)
+import StoreService.Log (logError, logWarn)
+import StoreService.Names.Codes (CodeRefusal (..), codeRefusal, reserveCode, reserveRefusal, spendLandedCode)
+import StoreService.Names.Contracts (Contracts, NameStatus (..), chainPriceCents, codeLengthFor, nameExpires, nameStatus, ownerOfToken, secondsPerYear)
 import StoreService.Names.Env (NamesEnv (..))
-import StoreService.Names.Phases (Phases, RegistrationId)
-import StoreService.Names.Abi (bytes32FromHex)
+import StoreService.Names.Phases (Phases, RegistrationId (..))
+import StoreService.Names.Abi (bytes32FromHex, hex)
 import StoreService.Names.Signatures (OrderFields (..), orderMessage, parseChecksumAddress, parseSignature, personalDigest)
-import StoreService.Names.Store (LiveOrder (..), NameRegistration (..), NewRegistration (..), PrepaidCode (..), RegistrationRefused (..), closeOverdue, createCodeRegistration, getLiveOrders, getPrepaidCode, getRegistrationByOrderHash, isLabelRegistering)
+import StoreService.Names.Store (CodeHashTaken, LiveOrder (..), NamePhase (..), NameRegistration (..), NewPrepaidCode (..), NewRegistration (..), PrepaidCode (..), RegistrationPayment (..), RegistrationRefused (..), NameTransaction (..), TxFor (..), TxStatus (..), VersionWrite (..), closeOverdue, createCodeRegistration, getLiveOrders, getPrepaidCode, getPrepaidCodeById, getRegistrationByOrderHash, insertPrepaidCode, isLabelRegistering, registrationTransactions, retargetRegistration, setIssuedCode, updateRegistration)
 import StoreService.Names.Turns (Turns, withCodeTurn)
 
 data OrdersEnv = OrdersEnv
@@ -86,6 +107,11 @@ data OrderRefusal
   | ORNameCheckUnavailable
   | ORCatalogChanged Int
   | ORCode CodeRefusal
+  | ORPriceTooHigh Int
+  | ORCodeLengthChanged Int
+  | ORCodeUnavailable
+  | ORCodeConflict
+  | ORProviderUnavailable
   deriving (Eq, Show)
 
 newtype OrderRefused = OrderRefused OrderRefusal
@@ -99,6 +125,20 @@ data ExistingOrder = EOResent NameRegistration | EONew [NameRegistration] | EOMe
 -- | An overdue order a new order closed, at its new version; its invoice is now expired.
 data ClosedOrder = ClosedOrder {coRegistration :: NameRegistration, coVersion :: Int64}
 
+-- | Why an owner's write changed nothing: the registration changed since it was read, or a refusal.
+data WriteRefusal = WRChanged | WRRefused OrderRefusal
+  deriving (Eq, Show)
+
+-- | What /retry's first check found on the order's current name: no register through, the order registered at a new version,
+-- the order changed since it was read, or a failed chain read.
+data Landing = LNotLanded | LRegistered Int64 | LChanged | LUnread
+  deriving (Eq, Show)
+
+newtype TakenCodeConflict = TakenCodeConflict CodeHashTaken
+  deriving (Show)
+
+instance E.Exception TakenCodeConflict
+
 maxSealedChars :: Int
 maxSealedChars = 11095
 
@@ -109,20 +149,27 @@ signedRequestSeconds = 600
 -- | Every format check; the length's range is checkLength's, after the formats a kind of order adds.
 parseOrderRequest :: J.Object -> Maybe OrderRequest
 parseOrderRequest o = do
-  ofLabelHash <- LabelHash <$> (bytes32FromHex =<< text "labelHash")
+  orOwner <- either (const Nothing) Just . parseChecksumAddress =<< textField o "owner"
+  (orFields, orTimestamp, orSignature) <- parseOrderFields o
+  pure OrderRequest {orOwner, orFields, orTimestamp, orSignature}
+
+-- | The signed fields of an order, or of another name for one, with their timestamp and signature.
+parseOrderFields :: J.Object -> Maybe (OrderFields, Word64, RecoverableSignature)
+parseOrderFields o = do
+  ofLabelHash <- LabelHash <$> (bytes32FromHex =<< textField o "labelHash")
   ofLength <- integerField =<< KM.lookup "length" o
   ofDuration <- integerField =<< KM.lookup "duration" o
-  orOwner <- either (const Nothing) Just . parseChecksumAddress =<< text "owner"
-  ofCommitment <- bytes32FromHex =<< text "commitment"
-  ofSealed <- text "sealed"
+  ofCommitment <- bytes32FromHex =<< textField o "commitment"
+  ofSealed <- textField o "sealed"
   unless (T.length ofSealed <= maxSealedChars) Nothing
-  orTimestamp <- integerField =<< KM.lookup "timestamp" o
-  orSignature <- either (const Nothing) Just . parseSignature =<< text "signature"
-  pure OrderRequest {orOwner, orFields = OrderFields {ofLabelHash, ofLength, ofDuration, ofCommitment, ofSealed}, orTimestamp, orSignature}
-  where
-    text k = case KM.lookup k o of
-      Just (J.String t) -> Just t
-      _ -> Nothing
+  timestamp <- integerField =<< KM.lookup "timestamp" o
+  signature <- either (const Nothing) Just . parseSignature =<< textField o "signature"
+  pure (OrderFields {ofLabelHash, ofLength, ofDuration, ofCommitment, ofSealed}, timestamp, signature)
+
+textField :: J.Object -> J.Key -> Maybe Text
+textField o k = case KM.lookup k o of
+  Just (J.String t) -> Just t
+  _ -> Nothing
 
 -- | A JSON integer within the type's range; a fraction, an exponent past it, or any other value is Nothing.
 integerField :: (Integral a, Bounded a) => J.Value -> Maybe a
@@ -130,16 +177,20 @@ integerField = \case
   J.Number n -> toBoundedInteger n
   _ -> Nothing
 
-checkLength :: OrderRequest -> Either OrderRefusal ()
-checkLength OrderRequest {orFields = OrderFields {ofLength}} =
+checkLength :: OrderFields -> Either OrderRefusal ()
+checkLength OrderFields {ofLength} =
   unless (ofLength >= minNameLength && ofLength <= maxNameLength) $ Left ORInvalidName
 
-checkOrderSigner :: OrderRequest -> IO (Either OrderRefusal ())
-checkOrderSigner OrderRequest {orOwner, orFields, orTimestamp, orSignature} =
-  recoverAddress orSignature (personalDigest $ orderMessage orFields orTimestamp) >>= \case
-    Right signer | signer == orOwner -> pure $ Right ()
+-- | The owner's EIP-191 signature over the message.
+checkSigner :: Address -> ByteString -> RecoverableSignature -> IO (Either OrderRefusal ())
+checkSigner owner msg signature =
+  recoverAddress signature (personalDigest msg) >>= \case
+    Right signer | signer == owner -> pure $ Right ()
     _ -> pure $ Left ORBadRequest
 
+checkOrderSigner :: OrderRequest -> IO (Either OrderRefusal ())
+checkOrderSigner OrderRequest {orOwner, orFields, orTimestamp, orSignature} = checkSigner orOwner (orderMessage orFields orTimestamp) orSignature
+
 existingOrder :: DB.Connection -> OrderRequest -> ByteString -> UTCTime -> IO ExistingOrder
 existingOrder db req hash now =
   getRegistrationByOrderHash db hash >>= \case
@@ -225,3 +276,129 @@ 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.
+movable :: NameRegistration -> Bool
+movable NameRegistration {nrPhase, nrPayment, nrLinksRefusedAt} = case nrPhase of
+  PTaken | RPInvoice {} <- nrPayment -> True
+  PFailed -> True
+  PCommitted -> isJust nrLinksRefusedAt
+  _ -> False
+
+-- | Only a paid order that lost its name turns into a code.
+issuable :: NameRegistration -> Bool
+issuable NameRegistration {nrPhase, nrPayment} = case (nrPhase, nrPayment) of
+  (PTaken, RPInvoice {}) -> True
+  _ -> False
+
+orderFieldsOf :: NameRegistration -> OrderFields
+orderFieldsOf NameRegistration {nrLabelHash, nrLength, nrDuration, nrCommitment, nrSealed} =
+  OrderFields {ofLabelHash = nrLabelHash, ofLength = nrLength, ofDuration = nrDuration, ofCommitment = nrCommitment, ofSealed = nrSealed}
+
+-- | Any other live order of the new commitment, or of the owner and the new label hash, refuses the move.
+checkMoveMeets :: DBStore -> NameRegistration -> OrderFields -> UTCTime -> IO (Either OrderRefusal ())
+checkMoveMeets st NameRegistration {nrId = rid, nrOwner} OrderFields {ofLabelHash, ofCommitment} now = do
+  orders <- withTransaction st $ \db -> getLiveOrders db ofCommitment nrOwner ofLabelHash now
+  pure $ if any ((/= rid) . nrId . loRegistration) orders then Left OROrderExists else Right ()
+
+-- | The new name's chain price for the order's years, at most what the order is worth, becomes its price.
+checkMovePrice :: Contracts -> NameRegistration -> Int -> IO (Either OrderRefusal Int)
+checkMovePrice ct NameRegistration {nrPrice, nrYears} len =
+  chainPriceCents ct len nrYears >>= \case
+    Left e -> Left ORNameCheckUnavailable <$ logWarn ("names: a move's price read failed: " <> tshow e)
+    Right price
+      | price > nrPrice -> pure $ Left $ ORPriceTooHigh price
+      | otherwise -> pure $ Right price
+
+-- | The move's write, a compare-and-set on the version read. A code order's code is checked and reserved again in the code's turn.
+retargetOrder :: OrdersEnv -> NameRegistration -> OrderFields -> Int -> IO (Either WriteRefusal Int64)
+retargetOrder OrdersEnv {oeStore, oeTurns, oeNow} r@NameRegistration {nrId, nrPayment} fields@OrderFields {ofLength} price = do
+  now <- oeNow
+  let write db = versionWritten <$> retargetRegistration db r fields price now
+  case nrPayment of
+    RPInvoice {} -> withTransaction oeStore write
+    RPCode codeId ->
+      withTransaction oeStore (`getPrepaidCodeById` codeId) >>= \case
+        Nothing -> pure $ Left $ WRRefused $ ORCode CRInvalid
+        Just PrepaidCode {pcCodeHash} -> either (Left . WRRefused . ORCode) id <$> reserveCode oeTurns oeStore now pcCodeHash nrId ofLength write
+
+versionWritten :: VersionWrite -> Either WriteRefusal Int64
+versionWritten = \case
+  Written v -> Right v
+  VersionChanged -> Left WRChanged
+  LiveOrderExists -> Left $ WRRefused OROrderExists
+  NotLive -> Left $ WRRefused ORBadRequest
+
+-- | /retry's first check, on the order's current name: a register mined with status 1, or the owner holding the name, went through
+-- with only its confirmation lost. The order then becomes registered by a compare-and-set on the version read, a code order spending its code.
+-- The caller holds the turn of the order's label hash and passes the order as registrationAt reads it.
+confirmLanded :: OrdersEnv -> NameRegistration -> IO Landing
+confirmLanded OrdersEnv {oeStore, oeContracts, oeTurns, oeNow} r@NameRegistration {nrId, nrOwner, nrLabelHash, nrPayment, nrRegisterTx, nrRegisterBlock} = do
+  txs <- withTransaction oeStore (`registrationTransactions` nrId)
+  let mined = [(ntHash, ntMinedBlock) | NameTransaction {ntFor = TxRegister _, ntStatus = TSMined, ntHash, ntMinedBlock} <- txs]
+  runExceptT (landed mined) >>= \case
+    Left e -> LUnread <$ logWarn ("names: a register check's chain read failed: " <> tshow e)
+    Right Nothing -> pure LNotLanded
+    Right (Just (tx, expiry)) -> either (const LChanged) LRegistered <$> markRegistered tx expiry
+  where
+    landed mined = do
+      registerTx <- case mined of
+        tx : _ -> pure $ Just $ Just tx
+        [] -> (\holder -> if holder == Just nrOwner then Just Nothing else Nothing) <$> ExceptT (ownerOfToken oeContracts nrLabelHash)
+      forM registerTx $ \tx -> (tx,) <$> ExceptT (nameExpires oeContracts nrLabelHash)
+    markRegistered tx expiry = do
+      now <- oeNow
+      let registered =
+            r
+              { nrPhase = PRegistered,
+                nrRegisterTx = (fst <$> tx) <|> nrRegisterTx,
+                nrRegisterBlock = (snd =<< tx) <|> nrRegisterBlock,
+                nrExpiresAt = Just expiry,
+                nrRegisteredAt = Just now,
+                nrFailedAt = Nothing,
+                nrError = Nothing
+              }
+          write db = versionWritten <$> updateRegistration db registered now
+      case nrPayment of
+        RPInvoice {} -> withTransaction oeStore write
+        RPCode codeId -> spendLandedCode oeTurns oeStore now codeId nrId write >>= traverse (paidWith codeId)
+    paidWith codeId (v, spent) = do
+      unless spent $ do
+        code <- withTransaction oeStore (`getPrepaidCodeById` codeId)
+        logError $
+          "names: registration " <> ridText nrId <> " turned out registered with prepaid code " <> maybe (tshow codeId) (hex . pcCodeHash) code
+            <> ", which was released and then spent, revoked or expired: the name was paid with it"
+      pure v
+    ridText (RegistrationId t) = t
+
+-- | The hash of the code a taken order was turned into.
+issuedCodeHash :: DBStore -> NameRegistration -> IO (Maybe ByteString)
+issuedCodeHash st NameRegistration {nrIssuedCodeId} = case nrIssuedCodeId of
+  Just codeId -> fmap pcCodeHash <$> withTransaction st (`getPrepaidCodeById` codeId)
+  Nothing -> pure Nothing
+
+-- | The code's minLength for the order's price and years must be the length the page derived the code with.
+checkTakenCodeLength :: Contracts -> NameRegistration -> Int -> IO (Either OrderRefusal ())
+checkTakenCodeLength ct NameRegistration {nrPrice, nrYears} sent =
+  codeLengthFor ct nrPrice nrYears >>= \case
+    Left e -> Left ORProviderUnavailable <$ logWarn ("names: a taken code's length read failed: " <> tshow e)
+    Right Nothing -> pure $ Left ORCodeUnavailable
+    Right (Just len)
+      | len /= sent -> pure $ Left $ ORCodeLengthChanged len
+      | otherwise -> pure $ Right ()
+
+-- | The order becomes code_issued by a compare-and-set on the version read, then its code is inserted and linked, in one
+-- transaction, so the registration's row is locked before the code's. A hash another code has rolls the order's write back.
+issueTakenCode :: OrdersEnv -> NameRegistration -> ByteString -> Int -> IO (Either WriteRefusal Int64)
+issueTakenCode OrdersEnv {oeStore, oeNow} r@NameRegistration {nrId, nrYears} codeHash minLength = do
+  now <- oeNow
+  let code = NewPrepaidCode {npcCodeHash = codeHash, npcMinLength = minLength, npcYears = nrYears, npcPaymentStatus = CPSPaid, npcExpiresAt = Nothing}
+      issue db =
+        updateRegistration db r {nrPhase = PCodeIssued} now >>= \case
+          Written v ->
+            insertPrepaidCode db code now >>= \case
+              Right codeId -> Right v <$ setIssuedCode db nrId codeId
+              Left taken -> E.throwIO $ TakenCodeConflict taken
+          -- a code_issued order is not live, so only a changed version refuses the write
+          _ -> pure $ Left WRChanged
+  either (\(TakenCodeConflict _) -> Left $ WRRefused ORCodeConflict) id <$> E.try (withTransaction oeStore issue)

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

@@ -57,6 +57,7 @@ data OrderFields = OrderFields
     ofCommitment :: ByteString,
     ofSealed :: Text
   }
+  deriving (Eq)
 
 signatureHexLength :: Int
 signatureHexLength = 130

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

@@ -41,6 +41,7 @@ module StoreService.Names.Store
     closeOverdue,
     updateRegistration,
     retargetRegistration,
+    setIssuedCode,
     findRegistrations,
     isLabelRegistering,
     activeRegistrations,
@@ -53,6 +54,7 @@ module StoreService.Names.Store
     reservePrepaidCode,
     releasePrepaidCode,
     spendPrepaidCode,
+    spendLandedPrepaidCode,
     revokePrepaidCode,
     insertTransaction,
     recordTransactionOutcome,
@@ -615,6 +617,10 @@ retargetRegistration db r OrderFields {ofLabelHash, ofLength, ofDuration, ofComm
         nrError = Nothing
       }
 
+-- | Links the code a taken order was turned into, in the transaction that wrote its code_issued phase and version.
+setIssuedCode :: DB.Connection -> RegistrationId -> Int64 -> IO ()
+setIssuedCode db (RegistrationId rid) codeId = DB.execute db "UPDATE sx_badge_service_name_registrations SET issued_code_id = ? WHERE registration_id = ?" (codeId, rid)
+
 -- | Newest first, at most findLimit.
 findRegistrations :: DB.Connection -> Address -> IO [NameRegistration]
 findRegistrations db owner =
@@ -756,6 +762,21 @@ spendPrepaidCode db codeId (RegistrationId rid) now =
       "UPDATE sx_badge_service_name_prepaid_codes SET spent_at = ? WHERE name_prepaid_code_id = ? AND reserved_by = ? AND spent_at IS NULL"
       (truncateToSecond now, codeId, rid)
 
+-- | For a registration whose register went through: spends the code it holds, or one released and still usable; False otherwise.
+spendLandedPrepaidCode :: DB.Connection -> Int64 -> RegistrationId -> UTCTime -> IO Bool
+spendLandedPrepaidCode db codeId (RegistrationId rid) now' =
+  (> 0)
+    <$> executeChanging
+      db
+      [sql|
+        UPDATE sx_badge_service_name_prepaid_codes SET reserved_by = ?, reserved_at = COALESCE(reserved_at, ?), spent_at = ?
+        WHERE name_prepaid_code_id = ? AND spent_at IS NULL
+          AND (reserved_by = ? OR (reserved_by IS NULL AND revoked_at IS NULL AND code_payment_status <> ? AND (expires_at IS NULL OR expires_at > ?)))
+      |]
+      (rid, now, now, codeId, rid, CPSUnpaid, now)
+  where
+    now = truncateToSecond now'
+
 -- | A reserved code can be revoked, and its order keeps it; a spent one cannot.
 revokePrepaidCode :: DB.Connection -> ByteString -> UTCTime -> IO RevokeResult
 revokePrepaidCode db codeHash now = do

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

@@ -9,9 +9,10 @@ import Network.HTTP.Types (Method)
 import Network.Wai (Request, ResponseReceived, pathInfo)
 import StoreService.Names.Env (NamesEnv (..))
 import StoreService.Names.Orders (ordersEnv)
-import StoreService.Web.Http (HttpEnv, Limit, Respond, codeLimit, holdMicros, limited, only, previewLimit, readLimit, recordsLimit, searchLimit)
+import StoreService.Web.Http (HttpEnv, Limit, Respond, codeLimit, createLimit, findLimit, holdMicros, limited, only, previewLimit, readLimit, recordsLimit, searchLimit)
 import StoreService.Web.Names.Codes (codeCheckHandler)
 import StoreService.Web.Names.Orders (codeOrderHandler)
+import StoreService.Web.Names.Owner (findHandler, retargetHandler, takenCodeHandler)
 import StoreService.Web.Names.Records (recordsHandler)
 import StoreService.Web.Names.Registration (registrationHandler)
 import StoreService.Web.Names.Search (previewHandler, searchHandler)
@@ -30,7 +31,11 @@ namesRoutes env@NamesEnv {neConfig, neStore, neContracts, neProfiles, neRecords,
   ["api", "link", "preview"] -> Just Route {rMethod = "POST", rLimit = previewLimit, rHandler = previewHandler neProfiles}
   -- below every fixed /api/name/<word> route, which it would otherwise match
   ["api", "name", hash] -> Just Route {rMethod = "GET", rLimit = searchLimit, rHandler = searchHandler neConfig neStore neContracts neProfiles hash}
+  -- above /api/registration/:id, which it would otherwise match
+  ["api", "registration", "find"] -> Just Route {rMethod = "POST", rLimit = findLimit, rHandler = findHandler (ordersEnv env)}
   ["api", "registration", rid] -> Just Route {rMethod = "GET", rLimit = readLimit, rHandler = registrationHandler (ordersEnv env) holdMicros rid}
+  ["api", "registration", rid, "name"] -> Just Route {rMethod = "POST", rLimit = createLimit, rHandler = retargetHandler (ordersEnv env) rid}
+  ["api", "registration", rid, "code"] -> Just Route {rMethod = "POST", rLimit = createLimit, rHandler = takenCodeHandler (ordersEnv env) rid}
   _ -> Nothing
 
 -- | Nothing for a path no route knows. The limit is taken only once the route and the method match.

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

@@ -2,7 +2,19 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module StoreService.Web.Names.Orders (nameInvoiceHandler, codeOrderHandler, nameInvoiceView, orderRefusalResponse, registrationChangedResponse) where
+module StoreService.Web.Names.Orders
+  ( Answer (..),
+    answerNow,
+    sendAnswer,
+    firstRefusal,
+    nameInvoiceHandler,
+    codeOrderHandler,
+    nameInvoiceView,
+    orderRefusalResponse,
+    registrationChangedResponse,
+    registrationRefusalResponse,
+  )
+where
 
 import Control.Concurrent.STM (atomically)
 import qualified Control.Exception as E
@@ -35,7 +47,7 @@ import StoreService.Orders (publishRegistration)
 import StoreService.Providers (OrderDraft (..), Provider (..), ProviderError (..), ProviderInvoice (..), expiresItself)
 import StoreService.Store.Invoices (InvoiceRow (..), NewNameInvoice (..), getInvoice, insertNameInvoice, newInvoiceId, truncateToSecond)
 import StoreService.Waiters (Waiters, publish)
-import StoreService.Web.Http (Respond, badRequest, confirmationsFor, internalError, invalidName, invoiceAt, invoicePairs, invoiceWindow, jsonError, jsonResponse, nameBodyBytes, notFound, providerFor, providerNamed, providerUnavailable, readBoundedBody)
+import StoreService.Web.Http (Respond, badRequest, codeConflict, confirmationsFor, internalError, invalidName, invoiceAt, invoicePairs, invoiceWindow, jsonError, jsonResponse, nameBodyBytes, notFound, providerFor, providerNamed, providerUnavailable, readBoundedBody)
 import StoreService.Web.Names.Codes (codeRefusalResponse)
 import StoreService.Web.Names.Registration (registrationAt)
 
@@ -54,7 +66,7 @@ parseInvoiceOrder o = do
       _ -> Nothing
     ioPrice <- integerField =<< KM.lookup "price" o
     pure InvoiceOrder {ioRequest, ioMethod, ioPrice}
-  order <$ checkLength ioRequest
+  order <$ checkLength (orFields ioRequest)
 
 -- | An order's answer and the work its commit leaves, both done after the name's turn, so a slow client holds no turn.
 data Answer = Answer {aResponse :: Response, aAfter :: IO ()}
@@ -180,12 +192,8 @@ codeOrderHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow}
 
 parseCodeOrder :: J.Object -> Either OrderRefusal (OrderRequest, Text)
 parseCodeOrder o = do
-  order@(req, _) <- maybe (Left ORBadRequest) Right $ (,) <$> parseOrderRequest o <*> codeText
-  order <$ checkLength req
-  where
-    codeText = case KM.lookup "code" o of
-      Just (J.String t) -> Just t
-      _ -> Nothing
+  order@(req, _) <- maybe (Left ORBadRequest) Right $ (,) <$> parseOrderRequest o <*> textField o "code"
+  order <$ checkLength (orFields req)
 
 -- | After the commit, the closed orders' invoices and versions are published, and their invoices cancelled at the provider,
 -- best effort, as the poller's sweep would cancel them.
@@ -223,13 +231,17 @@ nameInvoiceView OrdersEnv {oeStore, oeConfig, oeContracts} confirmations row@Inv
 
 -- | The registration's current view, for a request that lost the race to change it.
 registrationChangedResponse :: OrdersEnv -> RegistrationId -> IO Response
-registrationChangedResponse OrdersEnv {oeStore, oeConfig, oeContracts, oeNow} rid =
+registrationChangedResponse env = registrationRefusalResponse env "registration_changed"
+
+-- | A refusal with the registration's current view, so the page follows its state.
+registrationRefusalResponse :: OrdersEnv -> Text -> RegistrationId -> IO Response
+registrationRefusalResponse OrdersEnv {oeStore, oeConfig, oeContracts, oeNow} tag rid =
   withTransaction oeStore (`getRegistration` rid) >>= \case
     Nothing -> pure notFound
     Just r -> do
       now <- oeNow
       view <- registrationView oeStore oeConfig oeContracts (registrationAt now r)
-      pure $ jsonResponse status409 $ J.object ["error" .= ("registration_changed" :: Text), "registration" .= view]
+      pure $ jsonResponse status409 $ J.object ["error" .= tag, "registration" .= view]
 
 orderRefusalResponse :: OrderRefusal -> Response
 orderRefusalResponse = \case
@@ -240,3 +252,8 @@ orderRefusalResponse = \case
   ORNameCheckUnavailable -> jsonError status503 "name_check_unavailable"
   ORCatalogChanged price -> jsonResponse status409 $ J.object ["error" .= ("catalog_changed" :: Text), "price" .= price]
   ORCode refusal -> codeRefusalResponse refusal
+  ORPriceTooHigh price -> jsonResponse status409 $ J.object ["error" .= ("price_too_high" :: Text), "price" .= price]
+  ORCodeLengthChanged len -> jsonResponse status409 $ J.object ["error" .= ("code_length_changed" :: Text), "codeLength" .= len]
+  ORCodeUnavailable -> jsonError status409 "code_unavailable"
+  ORCodeConflict -> codeConflict
+  ORProviderUnavailable -> providerUnavailable

apps/simplex-store-service/src/StoreService/Web/Names/Owner.hs

@@ -0,0 +1,202 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | The requests only the owner code can sign: find, another name, and a code for a taken order.
+module StoreService.Web.Names.Owner (findHandler, retargetHandler, takenCodeHandler) where
+
+import Control.Concurrent.STM (atomically)
+import Data.Aeson ((.=))
+import qualified Data.Aeson as J
+import qualified Data.Aeson.KeyMap as KM
+import Data.ByteString (ByteString)
+import Data.Int (Int64)
+import Data.Text (Text)
+import Data.Word (Word64)
+import Network.HTTP.Types (status200)
+import Network.Wai (Request, Response, ResponseReceived)
+import Simplex.Chat.PaymentService.Types (InvoiceId (..))
+import Simplex.Messaging.Agent.Store.Common (withTransaction)
+import Simplex.Messaging.Crypto.Secp256k1 (RecoverableSignature)
+import Simplex.Messaging.Encoding.String (textEncode)
+import Simplex.Messaging.Eth.Address (Address)
+import Simplex.Messaging.SimplexName (LabelHash (..))
+import Simplex.Messaging.Util (eitherToMaybe, tshow)
+import StoreService.Config (NamesConfig (..))
+import StoreService.Log (logError, logInfo)
+import StoreService.Names.Abi (hex)
+import StoreService.Names.Orders
+import StoreService.Names.Phases (RegistrationId (..), publish)
+import StoreService.Names.Signatures (OrderFields (..), findMessage, parseAnyCaseAddress, parseSignature, retargetMessage, takenCodeMessage)
+import StoreService.Names.Store (NamePhase (..), NameRegistration (..), RegistrationPayment (..), findRegistrations, getRegistration)
+import StoreService.Names.Turns (withLabelTurn, withLabelTurns)
+import StoreService.Names.View (registrationView)
+import StoreService.Web.Http (Respond, internalError, jsonResponse, maxBodyBytes, nameBodyBytes, notFound, parseCodeHash, readBoundedBody)
+import StoreService.Web.Names.Orders (Answer (..), answerNow, firstRefusal, orderRefusalResponse, registrationChangedResponse, registrationRefusalResponse, sendAnswer)
+import StoreService.Web.Names.Registration (registrationAt)
+
+data FindRequest = FindRequest
+  { frOwner :: Address,
+    frTimestamp :: Word64,
+    frSignature :: RecoverableSignature
+  }
+
+data TakenCodeRequest = TakenCodeRequest
+  { tcHashText :: Text,
+    tcHash :: ByteString,
+    tcLength :: Int,
+    tcTimestamp :: Word64,
+    tcSignature :: RecoverableSignature
+  }
+
+-- | POST /api/registration/find, the owner's orders newest first.
+findHandler :: OrdersEnv -> Request -> Respond -> IO ResponseReceived
+findHandler OrdersEnv {oeStore, oeNow} req respond =
+  readBoundedBody maxBodyBytes req >>= requested >>= sendAnswer respond
+  where
+    requested = \case
+      Just body | Just (J.Object o) <- J.decode body, Just request <- parseFind o -> found request
+      _ -> refuse ORBadRequest
+    found FindRequest {frOwner, frTimestamp, frSignature} = do
+      now <- oeNow
+      firstRefusal [checkSigner frOwner (findMessage frOwner frTimestamp) frSignature, pure $ checkTimestamp now frTimestamp] >>= \case
+        Just refusal -> refuse refusal
+        Nothing ->
+          withTransaction oeStore (`findRegistrations` frOwner) >>= \case
+            [] -> pure $ answerNow notFound
+            rs -> pure $ answerNow $ jsonResponse status200 $ J.object ["registrations" .= map (foundJSON . registrationAt now) rs]
+    refuse = refused "POST /api/registration/find"
+
+parseFind :: J.Object -> Maybe FindRequest
+parseFind o = do
+  frOwner <- eitherToMaybe . parseAnyCaseAddress =<< textField o "owner"
+  frTimestamp <- integerField =<< KM.lookup "timestamp" o
+  frSignature <- eitherToMaybe . parseSignature =<< textField o "signature"
+  pure FindRequest {frOwner, frTimestamp, frSignature}
+
+foundJSON :: NameRegistration -> J.Value
+foundJSON NameRegistration {nrId = RegistrationId rid, nrPayment, nrPhase, nrCreatedAt, nrLabelHash = LabelHash lh, nrSealed} =
+  J.object
+    [ "registrationId" .= rid,
+      "invoiceId" .= invoiceId,
+      "phase" .= (textEncode nrPhase :: Text),
+      "createdAt" .= nrCreatedAt,
+      "labelHash" .= hex lh,
+      "sealed" .= nrSealed
+    ]
+  where
+    invoiceId = case nrPayment of
+      RPInvoice _ (InvoiceId t) -> Just t
+      RPCode _ -> Nothing
+
+-- | POST /api/registration/:id/name, another name or other links, under the turns of both names.
+retargetHandler :: OrdersEnv -> Text -> Request -> Respond -> IO ResponseReceived
+retargetHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} ridText req respond =
+  readBoundedBody nameBodyBytes req >>= requested >>= sendAnswer respond
+  where
+    rid = RegistrationId ridText
+    requested = \case
+      Just body | Just (J.Object o) <- J.decode body, Just request@(fields, _, _) <- parseOrderFields o -> either refuse (const $ signed request) (checkLength fields)
+      _ -> refuse ORBadRequest
+    signed (fields, timestamp, signature) =
+      withTransaction oeStore (`getRegistration` rid) >>= \case
+        Nothing -> pure $ answerNow notFound
+        Just NameRegistration {nrOwner, nrLabelHash} ->
+          checkSigner nrOwner (retargetMessage rid fields timestamp) signature >>= \case
+            Left refusal -> refuse refusal
+            Right () -> withLabelTurns oeTurns nrLabelHash (ofLabelHash fields) $ inTurns [nrLabelHash, ofLabelHash fields] fields timestamp
+    -- another move can take the order to a name whose turn this request does not hold
+    inTurns held fields timestamp = do
+      now <- oeNow
+      withTransaction oeStore (`getRegistration` rid) >>= \case
+        Nothing -> pure $ answerNow notFound
+        Just stored
+          | nrLabelHash stored `notElem` held -> changed
+          | otherwise -> moveTo now (registrationAt now stored) fields timestamp
+    moveTo now r@NameRegistration {nrPhase} fields timestamp
+      | orderFieldsOf r == fields = answerNow . jsonResponse status200 <$> registrationView oeStore oeConfig oeContracts r
+      | Left refusal <- checkTimestamp now timestamp = refuse refusal
+      | not (movable r) = refuse ORBadRequest
+      | nrPhase == PFailed =
+          confirmLanded env r >>= \case
+            LNotLanded -> moveChecked now r fields
+            LRegistered v -> written env rid v <$> registrationChangedResponse env rid
+            LChanged -> changed
+            LUnread -> refuse ORNameCheckUnavailable
+      | otherwise = moveChecked now r fields
+    moveChecked now r@NameRegistration {nrMoves, nrYears, nrPrice, nrPayment} fields@OrderFields {ofLabelHash, ofLength, ofDuration}
+      | nrMoves >= nMaxOrderMoves oeConfig = answerNow <$> registrationRefusalResponse env "move_limit" rid
+      | otherwise =
+          firstRefusal [checkMoveMeets oeStore r fields now, pure $ checkDuration oeConfig now nrYears ofDuration, checkNameFree oeContracts oeStore ofLabelHash] >>= \case
+            Just refusal -> refuse refusal
+            Nothing -> case nrPayment of
+              RPInvoice {} -> checkMovePrice oeContracts r ofLength >>= either refuse (write now r fields)
+              RPCode _ -> write now r fields nrPrice
+    write now r fields price =
+      retargetOrder env r fields price >>= \case
+        Right v -> movedAnswer now v
+        Left WRChanged -> changed
+        Left (WRRefused refusal) -> refuse refusal
+    movedAnswer now v =
+      withTransaction oeStore (`getRegistration` rid) >>= \case
+        Just r -> written env rid v . jsonResponse status200 <$> registrationView oeStore oeConfig oeContracts (registrationAt now r)
+        Nothing -> answerNow internalError <$ logError ("POST /api/registration/:id/name: order " <> ridText <> " is not readable after its move")
+    changed = answerNow <$> registrationChangedResponse env rid
+    refuse = refused "POST /api/registration/:id/name"
+
+-- | POST /api/registration/:id/code, a paid taken order turned into a prepaid code, under its name's turn.
+takenCodeHandler :: OrdersEnv -> Text -> Request -> Respond -> IO ResponseReceived
+takenCodeHandler env@OrdersEnv {oeStore, oeContracts, oeTurns, oeNow} ridText req respond =
+  readBoundedBody maxBodyBytes req >>= requested >>= sendAnswer respond
+  where
+    rid = RegistrationId ridText
+    requested = \case
+      Just body | Just (J.Object o) <- J.decode body, Just request <- parseTakenCode o -> signed request
+      _ -> refuse ORBadRequest
+    signed request@TakenCodeRequest {tcHashText, tcLength, tcTimestamp, tcSignature} =
+      withTransaction oeStore (`getRegistration` rid) >>= \case
+        Nothing -> pure $ answerNow notFound
+        Just NameRegistration {nrOwner, nrLabelHash} ->
+          checkSigner nrOwner (takenCodeMessage rid tcHashText tcLength tcTimestamp) tcSignature >>= \case
+            Left refusal -> refuse refusal
+            Right () -> withLabelTurn oeTurns nrLabelHash $ inTurn nrLabelHash request
+    inTurn held request@TakenCodeRequest {tcHash} = do
+      now <- oeNow
+      withTransaction oeStore (`getRegistration` rid) >>= \case
+        Nothing -> pure $ answerNow notFound
+        Just r
+          | nrLabelHash r /= held -> changed
+          | otherwise ->
+              issuedCodeHash oeStore r >>= \case
+                Just issued | issued == tcHash -> pure $ answerNow codeIssued
+                _ -> issue now r request
+    issue now r TakenCodeRequest {tcHash, tcLength, tcTimestamp}
+      | Left refusal <- checkTimestamp now tcTimestamp = refuse refusal
+      | not (issuable r) = refuse ORBadRequest
+      | otherwise =
+          checkTakenCodeLength oeContracts r tcLength >>= \case
+            Left refusal -> refuse refusal
+            Right () ->
+              issueTakenCode env r tcHash tcLength >>= \case
+                Right v -> pure $ written env rid v codeIssued
+                Left WRChanged -> changed
+                Left (WRRefused refusal) -> refuse refusal
+    codeIssued = jsonResponse status200 $ J.object []
+    changed = answerNow <$> registrationChangedResponse env rid
+    refuse = refused "POST /api/registration/:id/code"
+
+parseTakenCode :: J.Object -> Maybe TakenCodeRequest
+parseTakenCode o = do
+  tcHashText <- textField o "codeHash"
+  tcHash <- parseCodeHash tcHashText
+  tcLength <- integerField =<< KM.lookup "codeLength" o
+  tcTimestamp <- integerField =<< KM.lookup "timestamp" o
+  tcSignature <- eitherToMaybe . parseSignature =<< textField o "signature"
+  pure TakenCodeRequest {tcHashText, tcHash, tcLength, tcTimestamp, tcSignature}
+
+-- | Published after the turn, as the answer is sent.
+written :: OrdersEnv -> RegistrationId -> Int64 -> Response -> Answer
+written OrdersEnv {oePhases} rid v aResponse = Answer {aResponse, aAfter = atomically $ publish oePhases rid v}
+
+refused :: Text -> OrderRefusal -> IO Answer
+refused what refusal = answerNow (orderRefusalResponse refusal) <$ logInfo (what <> " refused: " <> tshow refusal)

simplex-chat.cabal

@@ -475,6 +475,7 @@ executable simplex-store-service
       StoreService.Web.Names
       StoreService.Web.Names.Codes
       StoreService.Web.Names.Orders
+      StoreService.Web.Names.Owner
       StoreService.Web.Names.Records
       StoreService.Web.Names.Registration
       StoreService.Web.Names.Search
@@ -770,6 +771,7 @@ test-suite simplex-chat-test
       Bots.StoreService.NamesLabelTests
       Bots.StoreService.NamesLinksTests
       Bots.StoreService.NamesOrdersTests
+      Bots.StoreService.NamesOwnerTests
       Bots.StoreService.NamesPhasesTests
       Bots.StoreService.NamesProfilesTests
       Bots.StoreService.NamesRecordsTests
@@ -832,6 +834,7 @@ test-suite simplex-chat-test
       StoreService.Web.Names
       StoreService.Web.Names.Codes
       StoreService.Web.Names.Orders
+      StoreService.Web.Names.Owner
       StoreService.Web.Names.Records
       StoreService.Web.Names.Registration
       StoreService.Web.Names.Search

tests/Bots/StoreService/GroupIntegrationTests.hs

@@ -134,7 +134,7 @@ badgeGroupIntegrationTests = do
   it "leaves a tracker it cannot edit alone rather than publishing the code again" testUneditableTrackerLeftAlone
 
 namesBootTests :: SpecWith TestParams
-namesBootTests = it "boots with [names] and [chain], routing fixed /api/name paths ahead of a search, registrations to GET, a path no route knows to 404, and code checks and orders under one limit" testNamesBoot
+namesBootTests = it "boots with [names] and [chain], routing fixed /api/name paths ahead of a search, find ahead of registrations, registrations to GET, another name and a code to POST, a path no route knows to 404, and code checks and orders under one limit" testNamesBoot
 
 testNamesBoot :: HasCallStack => TestParams -> IO ()
 testNamesBoot ps = do
@@ -158,6 +158,13 @@ testNamesBoot ps = do
     answer registration `shouldReturn` (404, Just $ J.object ["error" J..= ("not_found" :: Text)])
     posted <- httpLbs registration {method = "POST"} mgr
     (statusCode $ responseStatus posted, lookup "Allow" $ responseHeaders posted) `shouldBe` (405, Just "GET")
+    found <- request "/api/registration/find"
+    answer found {method = "POST", requestBody = RequestBodyLBS "{}"} `shouldReturn` refused "bad_request"
+    foundByGet <- httpLbs found mgr
+    (statusCode $ responseStatus foundByGet, lookup "Allow" $ responseHeaders foundByGet) `shouldBe` (405, Just "POST")
+    forM_ ["name", "code"] $ \action -> do
+      owned <- request $ "/api/registration/t2Jk8RmQ4vXw9NcP3yLb6g/" <> action
+      (action,) <$> answer owned {method = "POST", requestBody = RequestBodyLBS "{}"} `shouldReturn` (action, refused "bad_request")
     -- the register above took the first of this client's 10 code requests a minute, which the code check shares
     let codeRequest path = request path >>= \r -> statusCode . responseStatus <$> httpLbs r {method = "POST", requestBody = RequestBodyLBS "{}"} mgr
     forM_ (take 9 $ cycle ["/api/code/check", "/api/name/register"]) $ \path -> (path,) <$> codeRequest path `shouldReturn` (path, 400)

tests/Bots/StoreService/NamesCodesTests.hs

@@ -34,7 +34,7 @@ import StoreService.Config (ListenerConfig (..))
 import StoreService.Group.Command (CmdAction (..), GroupCmd (..), groupCmdAction)
 import StoreService.Names.Codes
 import StoreService.Names.Phases (RegistrationId (..))
-import StoreService.Names.Store (NewPrepaidCode (..), PrepaidCode (..), getPrepaidCode, insertPrepaidCode, revokePrepaidCode, spendPrepaidCode)
+import StoreService.Names.Store (NewPrepaidCode (..), PrepaidCode (..), getPrepaidCode, insertPrepaidCode, reservePrepaidCode, revokePrepaidCode, spendPrepaidCode)
 import StoreService.Names.Turns (Turns, newTurns)
 import StoreService.Store (RevokeResult (..))
 import StoreService.Web.Http (codeLimit, newHttpEnv, notFound)
@@ -53,11 +53,12 @@ namesCodesTests = describe "StoreService names: prepaid codes" $ do
     it "answers bad_request to a body that is not an object with a code text, and 405 to GET" testCheckBadBody
     it "takes a code token for every check, whatever its outcome" testCheckLimit
   describe "reservations" $ do
-    it "reserves an unused code in the transaction of the registration's write" testReserve
+    it "reserves an unused code after the registration's write, in its transaction" testReserve
     it "refuses each unusable code with its tag, before the write runs" testReserveRefusals
     it "keeps a code its registration holds even if revoked or expired since, still checking the length" testReserveHeld
     it "refuses a spent code to its own registration with code_used, before the write runs" testReserveSpent
-    it "gives the code back when the write refuses" testReserveWriteRefused
+    it "reserves nothing when the write refuses" testReserveWriteRefused
+    it "rolls the write back when the code's reservation is refused after it" testReserveRollsBack
     it "lets one of two concurrent reservations of a code win, the other answered code_reserved" testConcurrentReserve
     it "releases and spends a code only after the write, and only for its holder" testReleaseSpend
   describe "group commands" $ do
@@ -238,7 +239,8 @@ testReserve = withOrders $ \turns st -> do
   code <- newCode 8
   PrepaidCode {pcCodeHash} <- issueAs st code usable
   let holderInWrite db = Right . (pcReservedBy =<<) <$> getPrepaidCode db pcCodeHash :: IO (Either Text (Maybe RegistrationId))
-  reserveCode turns st tNow pcCodeHash r1 8 holderInWrite `shouldReturn` Right (Right (Just r1))
+  reserveCode turns st tNow pcCodeHash r1 8 holderInWrite `shouldReturn` Right (Right Nothing)
+  (pcReservedBy =<<) <$> withTransaction st (`getPrepaidCode` pcCodeHash) `shouldReturn` Just r1
   reserveCode turns st tNow pcCodeHash r1 11 holderInWrite `shouldReturn` Right (Right (Just r1))
 
 testReserveRefusals :: IO ()
@@ -307,6 +309,15 @@ testReserveWriteRefused = withOrders $ \turns st -> do
   reserveCode turns st tNow pcCodeHash r2 8 writeOk `shouldReturn` Right (Right ())
   (pcReservedBy =<<) <$> readCode st row `shouldReturn` Just r2
 
+-- | The write reserves the code for another registration, as a writer outside this process could between the check and the reservation.
+testReserveRollsBack :: IO ()
+testReserveRollsBack = withOrders $ \turns st -> do
+  code <- newCode 8
+  row@PrepaidCode {pcId, pcCodeHash} <- issueAs st code usable
+  let takenMeanwhile db = Right () <$ reservePrepaidCode db pcId r2 tNow :: IO (Either Text ())
+  reserveCode turns st tNow pcCodeHash r1 8 takenMeanwhile `shouldReturn` Left CRReserved
+  readCode st row `shouldReturn` Just row
+
 testConcurrentReserve :: IO ()
 testConcurrentReserve = withOrders $ \turns st -> do
   code <- newCode 8

tests/Bots/StoreService/NamesContractsTests.hs

@@ -22,6 +22,7 @@ module Bots.StoreService.NamesContractsTests
     noncesCall,
     pricesCall,
     launchPricesAnswer,
+    pricesAnswer,
     oracle,
     alice,
     unhex,

tests/Bots/StoreService/NamesOrdersTests.hs

@@ -17,6 +17,18 @@ module Bots.StoreService.NamesOrdersTests
     settled,
     invoiceRegistration,
     registrationOf,
+    keyA,
+    keyB,
+    ownerAText,
+    ownerBText,
+    yearsDuration,
+    codeRoutes,
+    issueCode,
+    registered,
+    registrationById,
+    field,
+    advance,
+    refusedWith,
   )
 where
 

tests/Bots/StoreService/NamesOwnerTests.hs

@@ -0,0 +1,849 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module Bots.StoreService.NamesOwnerTests (namesOwnerTests) where
+
+import Bots.StoreService.FakeEthNode
+import Bots.StoreService.NamesContractsTests (launchPricesAnswer, oracle, pricesAnswer, pricesCall, registrarOf, rentPriceAnswer, rentPriceCall, unhex)
+import Bots.StoreService.NamesOrdersTests
+import Bots.StoreService.NamesStoreTests (order, ownerA, t0)
+import Bots.StoreService.WebTests (capturingStderr, digestFixture, jsonObject, statusOf, webGet)
+import Control.Applicative ((<|>))
+import Control.Arrow ((&&&))
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (Async, async, cancel, wait)
+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
+import Control.Concurrent.STM (atomically, check)
+import Control.Monad (forM, forM_, unless, void)
+import qualified Data.Aeson as J
+import qualified Data.Aeson.KeyMap as KM
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Base64.URL as B64U
+import qualified Data.ByteString.Char8 as BC
+import Data.IORef (readIORef)
+import Data.Foldable (toList)
+import Data.List (find, sort, sortOn)
+import Data.Maybe (fromJust, fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (UTCTime, addUTCTime)
+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
+import Data.Word (Word64, Word8)
+import Network.HTTP.Client (defaultManagerSettings, newManager)
+import qualified Network.Wai.Handler.Warp as Warp
+import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..))
+import Simplex.Chat.PaymentService.Types (InvoiceId (..), InvoiceStatus (..))
+import Simplex.Messaging.Agent.Store.Common (withTransaction)
+import qualified Simplex.Messaging.Agent.Store.DB as DB
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Secp256k1 (Secp256k1PrivateKey, signRecoverable)
+import Simplex.Messaging.Eth.Address (Address)
+import Simplex.Messaging.Eth.EIP712 (serializeSignature)
+import Simplex.Messaging.SimplexName (LabelHash (..), labelHash)
+import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
+import StoreService.Config (NamesConfig (..))
+import StoreService.Names.Abi (addressWord, hex, uint256)
+import StoreService.Names.Chain (TxHash (..))
+import StoreService.Names.Orders (OrdersEnv (..), signedRequestSeconds)
+import StoreService.Names.Phases (RegistrationId (..), phasesWaiting)
+import StoreService.Names.Signatures (OrderFields (..), findMessage, parseAnyCaseAddress, personalDigest, retargetMessage, takenCodeMessage)
+import StoreService.Names.Store hiding (findLimit)
+import StoreService.Names.Turns (turnsCount, withLabelTurn)
+import StoreService.Store (RevokeResult (..))
+import StoreService.Web.Http (createLimit, findLimit, holdMicros, readLimit)
+import StoreService.Web.Names (Route (..), namesApp)
+import StoreService.Web.Names.Owner (findHandler, retargetHandler, takenCodeHandler)
+import StoreService.Web.Names.Registration (registrationHandler)
+import StoreService.Web.Server (WebEnv (..), webApp)
+import System.Timeout (timeout)
+import Test.Hspec
+
+namesOwnerTests :: Spec
+namesOwnerTests = describe "StoreService names: owner" $ do
+  describe "find" $ 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 "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
+    it "refuses a move meeting another live order of the wallet's or the commitment with a bare order_exists, before the price" testMoveMeetsOrder
+    it "runs the order checks on the new fields: invalid_name, the duration, name_taken, name_check_unavailable" testMoveOrderChecks
+    it "registers a failed order whose register went through, by its mined register or by ownerOf, answering registration_changed and spending a code" testMoveLanded
+    it "answers name_check_unavailable when the register check cannot read the chain, changing nothing" testMoveLandedUnread
+    it "spends a released code still unused when its failed order turns out registered, and alerts once when it was spent elsewhere meanwhile" testMoveLandedReleasedCode
+    it "answers a dearer name price_too_high with its price, and moves to a cheaper one at its price" testMovePrice
+    it "checks a code order's code again: code_not_covering for a shorter name, a held code kept though revoked and expired since" testMoveCodeOrder
+    it "reserves a released code again while unused, else answers code_used, code_reserved, code_invalid or code_expired" testMoveReleasedCode
+    it "refuses sealed over 11095 characters, a body over 16384 bytes and malformed fields, accepting the longest" testMoveSizes
+    it "refuses another signer's signature and a stale timestamp, and answers an unknown order 404" testMoveRefusedSigner
+    it "answers registration_changed with the current view when the order changed during the checks, writing nothing" testMoveLostRace
+    it "moves A to B while another order moves B to A, in the turns' hash order, without deadlock" testMovesCross
+  describe "a code instead" $ do
+    it "issues a code for a paid taken order, its minLength 6, 7 and 8 for 6, 7 and 12 letters at the launch prices, kept in the view" testTakenCode
+    it "answers an identical repeat 200 whatever its codeLength and timestamp, even after a price change" testTakenCodeRepeat
+    it "answers code_length_changed with the current length after a price change, issuing nothing" testCodeLengthChanged
+    it "answers code_unavailable when no length qualifies, and 503 provider_unavailable when the prices cannot be read" testCodeUnavailable
+    it "refuses a code for an order that is not a paid taken one, another signer, a stale timestamp and a malformed hash" testTakenCodeRefused
+    it "answers code_conflict for a hash another code has, changing nothing" testCodeConflict
+    it "answers registration_changed with the current view when the order changed during the length read, issuing nothing" testCodeLostRace
+  describe "polls" $
+    it "wakes a held registration poll by another name and by a code" testPollsWoken
+
+-- fixtures
+
+-- | The owner routes and the registration poll as namesRoutes registers them, with the code orders, since a NamesEnv needs a running chat controller.
+withOwner :: (Ctx -> IO a) -> IO a
+withOwner = withOwnerAs id
+
+withOwnerAs :: (NamesConfig -> NamesConfig) -> (Ctx -> IO a) -> IO a
+withOwnerAs change action = withOrders $ \ctx@Ctx {cOrders, cWeb} -> do
+  let orders = cOrders {oeConfig = change (oeConfig cOrders)}
+      web = cWeb {weOrders = Just orders}
+      routes path = ownerRoutes orders path <|> codeRoutes orders (weProviders web) (weWaiters web) path
+      app req respond = fromMaybe (webApp web req respond) (namesApp (weHttp web) routes req respond)
+      ctx' = ctx {cOrders = orders, cWeb = web}
+  forM_ ["alicebakery", "dynamis"] $ answerUnowned ctx'
+  mgr <- newManager defaultManagerSettings
+  Warp.testWithApplication (pure app) $ \port -> action ctx' {cClient = (mgr, "http://127.0.0.1:" <> show port)}
+
+ownerRoutes :: OrdersEnv -> [Text] -> Maybe Route
+ownerRoutes orders = \case
+  ["api", "registration", "find"] -> Just Route {rMethod = "POST", rLimit = findLimit, rHandler = findHandler orders}
+  ["api", "registration", rid] -> Just Route {rMethod = "GET", rLimit = readLimit, rHandler = registrationHandler orders holdMicros rid}
+  ["api", "registration", rid, "name"] -> Just Route {rMethod = "POST", rLimit = createLimit, rHandler = retargetHandler orders rid}
+  ["api", "registration", rid, "code"] -> Just Route {rMethod = "POST", rLimit = createLimit, rHandler = takenCodeHandler orders rid}
+  _ -> Nothing
+
+signWith :: Ctx -> Secp256k1PrivateKey -> ByteString -> IO Text
+signWith Ctx {cRandom} key msg = hex . serializeSignature . either (error . show) id <$> signRecoverable cRandom key (personalDigest msg)
+
+clockSeconds :: Ctx -> IO Word64
+clockSeconds Ctx {cClock} = seconds <$> readIORef cClock
+
+seconds :: UTCTime -> Word64
+seconds = floor . utcTimeToPOSIXSeconds
+
+signedWindow :: Word64
+signedWindow = fromInteger signedRequestSeconds
+
+byB :: Order -> Order
+byB o = o {oOwner = ownerBText, oKey = keyB}
+
+dynamisOrder :: Order
+dynamisOrder = aliceOrder {oLabel = "dynamis", oCommitment = commitmentOf 3, oSealed = "sealed-dynamis-3", oPrice = 20000}
+
+-- viem's selectors of nameExpires(uint256), reservedNames(bytes32) and ownerOf(uint256), as in the calls of the contracts tests
+nameExpiresSelector, reservedNamesSelector, ownerOfSelector :: ByteString
+nameExpiresSelector = unhex "d6e4fa86"
+reservedNamesSelector = unhex "389c0748"
+ownerOfSelector = unhex "6352211e"
+
+labelBytes :: Text -> ByteString
+labelBytes label = lh
+  where
+    LabelHash lh = labelHash label
+
+-- | ownerOf of a name nobody holds: the registrar's bare require, a revert without data.
+answerUnowned :: Ctx -> Text -> IO ()
+answerUnowned Ctx {cNode} label = answerCall cNode (registrarOf cNode) (ownerOfSelector <> labelBytes label) $ Reverts ""
+
+answerOwner :: Ctx -> Text -> Address -> IO ()
+answerOwner Ctx {cNode} label owner = answerCall cNode (registrarOf cNode) (ownerOfSelector <> labelBytes label) $ Returns $ addressWord owner
+
+answerExpiry :: Ctx -> Text -> Word64 -> IO ()
+answerExpiry Ctx {cNode} label expiry = answerCall cNode (registrarOf cNode) (nameExpiresSelector <> labelBytes label) $ Returns $ uint256 expiry
+
+-- | A register transaction of the order as the sender saves it, then moved to this outcome.
+sentRegister :: Ctx -> NameRegistration -> Word8 -> TxStatus -> IO TxHash
+sentRegister Ctx {cStore} NameRegistration {nrId} n status = withTransaction cStore $ \db -> do
+  let h = TxHash $ digestFixture n
+  void $ insertTransaction db (TxRegister nrId) NewTransaction {ntxRaw = "raw", ntxHash = h, ntxNonce = fromIntegral n} orderTime
+  recordTransactionOutcome db h TSPending status (Just 120) `shouldReturn` True
+  pure h
+
+-- | The chain answers the name as available and held by nobody.
+answerFree :: Ctx -> Text -> IO ()
+answerFree ctx label = answerReserved ctx label 0 >> answerUnowned ctx label
+
+answerReserved :: Ctx -> Text -> Int -> IO ()
+answerReserved Ctx {cNode} label reason = do
+  answerCall cNode (registrarOf cNode) (nameExpiresSelector <> lh) $ Returns $ uint256 (0 :: Int)
+  answerCall cNode fakeController (reservedNamesSelector <> lh) $ Returns $ uint256 reason
+  where
+    LabelHash lh = labelHash label
+
+-- | The oracle's price list, as codeLengthFor reads it.
+answerPrices :: Ctx -> ByteString -> IO ()
+answerPrices Ctx {cNode} prices = do
+  answerCall cNode fakeController pricesCall $ Returns $ addressWord oracle
+  answerCall cNode oracle pricesCall $ Returns prices
+
+-- | A paid order, settled, then written as the worker would write it.
+paidIn :: Ctx -> Order -> (NameRegistration -> NameRegistration) -> IO NameRegistration
+paidIn ctx o change = do
+  (invId, _) <- placed ctx o
+  settleNow ctx invId settled `shouldReturn` Right ISPaid
+  r <- invoiceRegistration ctx invId
+  rewrite ctx r change
+
+-- | A code order of a code of this length, then written as the worker would write it.
+codeIn :: Ctx -> Int -> Order -> (NameRegistration -> NameRegistration) -> IO (NameRegistration, PrepaidCode)
+codeIn ctx len o change = do
+  (text, code) <- issueCode ctx len 2 id
+  r <- registrationById ctx =<< registered ctx text o
+  (,code) <$> rewrite ctx r change
+
+-- | A write outside the turns, as the worker's, at the stored version.
+rewrite :: Ctx -> NameRegistration -> (NameRegistration -> NameRegistration) -> IO NameRegistration
+rewrite Ctx {cStore, cClock} NameRegistration {nrId} change = do
+  t <- readIORef cClock
+  withTransaction cStore $ \db -> do
+    current <- fromJust <$> getRegistration db nrId
+    updateRegistration db (change current) t >>= \case
+      Written _ -> fromJust <$> getRegistration db nrId
+      refused -> error $ "not written: " <> show refused
+
+stored :: Ctx -> NameRegistration -> IO NameRegistration
+stored ctx = registrationById ctx . nrId
+
+failedPhase, takenPhase, registeredPhase, committedPhase, linksRefusedPhase :: NameRegistration -> NameRegistration
+failedPhase r = r {nrPhase = PFailed, nrFailedAt = Just orderTime, nrError = Just "The name could not be registered"}
+takenPhase r = r {nrPhase = PTaken}
+registeredPhase r = r {nrPhase = PRegistered, nrExpiresAt = Just (seconds orderTime + 3 * 31536000)}
+committedPhase r =
+  r
+    { nrPhase = PCommitted,
+      nrCommitTx = Just (TxHash $ digestFixture 8),
+      nrCommitBlock = Just 100,
+      nrRevealAfter = Just (seconds orderTime + 60),
+      nrRevealBefore = Just (seconds orderTime + 86400)
+    }
+linksRefusedPhase r = (committedPhase r) {nrLinksRefusedAt = Just orderTime}
+
+-- | Another name's fields, with the page's duration for 2 years at the service's clock.
+moveTo :: Ctx -> Text -> Int -> IO OrderFields
+moveTo Ctx {cClock} label n = do
+  t <- readIORef cClock
+  pure OrderFields {ofLabelHash = labelHash label, ofLength = T.length label, ofDuration = yearsDuration 2 t, ofCommitment = commitmentOf n, ofSealed = "sealed-" <> label <> "-" <> tshow n}
+
+moveBody :: Ctx -> Secp256k1PrivateKey -> RegistrationId -> OrderFields -> IO J.Object
+moveBody ctx key rid fields = clockSeconds ctx >>= moveBodyAt ctx key rid fields
+
+moveBodyAt :: Ctx -> Secp256k1PrivateKey -> RegistrationId -> OrderFields -> Word64 -> IO J.Object
+moveBodyAt ctx key rid fields@OrderFields {ofLabelHash = LabelHash lh, ofLength, ofDuration, ofCommitment, ofSealed} timestamp = do
+  sig <- signWith ctx key $ retargetMessage rid fields timestamp
+  pure $
+    KM.fromList
+      [ ("labelHash", J.String $ hex lh),
+        ("length", J.toJSON ofLength),
+        ("duration", J.toJSON ofDuration),
+        ("commitment", J.String $ hex ofCommitment),
+        ("sealed", J.String ofSealed),
+        ("timestamp", J.toJSON timestamp),
+        ("signature", J.String sig)
+      ]
+
+postMove :: Ctx -> RegistrationId -> J.Object -> IO (Int, Maybe J.Object)
+postMove ctx rid = post ctx (registrationPath rid <> "/name") . J.encode
+
+move :: Ctx -> Secp256k1PrivateKey -> NameRegistration -> OrderFields -> IO (Int, Maybe J.Object)
+move ctx key NameRegistration {nrId} fields = moveBody ctx key nrId fields >>= postMove ctx nrId
+
+-- | The view of an accepted move, failing the test otherwise.
+moved :: Ctx -> Secp256k1PrivateKey -> NameRegistration -> OrderFields -> IO J.Object
+moved ctx key r fields =
+  move ctx key r fields >>= \case
+    (200, Just v) -> pure v
+    other -> error $ "move refused: " <> show other
+
+registrationPath :: RegistrationId -> String
+registrationPath (RegistrationId rid) = "/api/registration/" <> T.unpack rid
+
+getView :: Ctx -> NameRegistration -> IO J.Object
+getView ctx NameRegistration {nrId} = webGet (cClient ctx) (registrationPath nrId) >>= jsonObject
+
+findBody :: Ctx -> Secp256k1PrivateKey -> Text -> Word64 -> IO J.Object
+findBody ctx key owner timestamp = do
+  sig <- signWith ctx key $ findMessage (either (error . show) id $ parseAnyCaseAddress owner) timestamp
+  pure $ KM.fromList [("owner", J.String owner), ("timestamp", J.toJSON timestamp), ("signature", J.String sig)]
+
+postFind :: Ctx -> J.Object -> IO (Int, Maybe J.Object)
+postFind ctx = post ctx "/api/registration/find" . J.encode
+
+-- | A code hash as the page sends it: unpadded base64url of a SHA-256.
+takenCodeHash :: Int -> (Text, ByteString)
+takenCodeHash n = (T.filter (/= '=') $ safeDecodeUtf8 $ B64U.encode h, h)
+  where
+    h = C.sha256Hash $ "taken code " <> BC.pack (show n)
+
+codeBodyAt :: Ctx -> Secp256k1PrivateKey -> RegistrationId -> Text -> Int -> Word64 -> IO J.Object
+codeBodyAt ctx key rid codeHash codeLength timestamp = do
+  sig <- signWith ctx key $ takenCodeMessage rid codeHash codeLength timestamp
+  pure $ KM.fromList [("codeHash", J.String codeHash), ("codeLength", J.toJSON codeLength), ("timestamp", J.toJSON timestamp), ("signature", J.String sig)]
+
+postCode :: Ctx -> RegistrationId -> J.Object -> IO (Int, Maybe J.Object)
+postCode ctx rid = post ctx (registrationPath rid <> "/code") . J.encode
+
+takeCode :: Ctx -> Secp256k1PrivateKey -> NameRegistration -> Text -> Int -> IO (Int, Maybe J.Object)
+takeCode ctx key NameRegistration {nrId} codeHash codeLength = clockSeconds ctx >>= codeBodyAt ctx key nrId codeHash codeLength >>= postCode ctx nrId
+
+currentFields :: NameRegistration -> OrderFields
+currentFields NameRegistration {nrLabelHash, nrLength, nrDuration, nrCommitment, nrSealed} =
+  OrderFields {ofLabelHash = nrLabelHash, ofLength = nrLength, ofDuration = nrDuration, ofCommitment = nrCommitment, ofSealed = nrSealed}
+
+fieldsIn :: J.Object -> [(Text, J.Value)] -> Expectation
+fieldsIn v = mapM_ (\(k, value) -> (k, field k v) `shouldBe` (k, Just value))
+
+answered :: Maybe J.Object
+answered = Just KM.empty
+
+refusedWithView :: Text -> J.Object -> (Int, Maybe J.Object)
+refusedWithView tag view = (409, Just $ KM.fromList [("error", J.String tag), ("registration", J.Object view)])
+
+labelHashText :: Text -> J.Value
+labelHashText label = J.String $ hex lh
+  where
+    LabelHash lh = labelHash label
+
+issuedCode :: Ctx -> NameRegistration -> IO PrepaidCode
+issuedCode Ctx {cStore} NameRegistration {nrIssuedCodeId} = withTransaction cStore $ \db -> fromJust <$> getPrepaidCodeById db (fromJust nrIssuedCodeId)
+
+codeRow :: Ctx -> PrepaidCode -> IO PrepaidCode
+codeRow Ctx {cStore} PrepaidCode {pcId} = withTransaction cStore $ \db -> fromJust <$> getPrepaidCodeById db pcId
+
+-- | Bounded, since a deadlock would otherwise hang the suite.
+within :: String -> IO a -> IO a
+within what action = timeout 10000000 action >>= maybe (error $ what <> " did not finish") pure
+
+-- | Waits until the turns have at least this many label or code hashes held or waited on.
+awaitTurns :: Ctx -> Int -> IO ()
+awaitTurns Ctx {cOrders} n = within "turns" loop
+  where
+    loop = turnsCount (oeTurns cOrders) >>= \count -> unless (count >= n) (threadDelay 1000 >> loop)
+
+-- | A registration poll at the order's version, once the server holds it.
+held :: Ctx -> NameRegistration -> IO (Async (Int, J.Object))
+held ctx@Ctx {cOrders} NameRegistration {nrId, nrVersion} = do
+  waiting <- atomically $ phasesWaiting (oePhases cOrders)
+  poll <- async $ webGet (cClient ctx) (registrationPath nrId <> "?seenVersion=" <> show nrVersion) >>= \resp -> (statusOf resp,) <$> jsonObject resp
+  within "the hold" $ atomically $ phasesWaiting (oePhases cOrders) >>= check . (> waiting)
+  pure poll
+
+woken :: Async (Int, J.Object) -> IO (Int, J.Object)
+woken poll = timeout 5000000 (wait poll) >>= maybe (cancel poll >> error "the poll was not woken") pure
+
+-- | Long enough for a request just sent to reach its turns.
+parkDelay :: Int
+parkDelay = 200000
+
+-- | Each eth_call's delay in the lost-race tests, far longer than a request takes to read its registration.
+slowRead :: Int
+slowRead = 3000000
+
+-- | How long after the turns are held the lost-race tests change the order: past the request's read, before its write.
+raceDelay :: Int
+raceDelay = 1000000
+
+-- tests
+
+testFind :: IO ()
+testFind = withOwner $ \ctx@Ctx {cStore} -> do
+  forM_ [1 .. 50 :: Int] $ \i -> do
+    (_, code) <- issueCode ctx 8 2 id
+    let new = NewRegistration {nrgId = oldOrder i, nrgOwner = ownerA, nrgOrder = order ("alicebakery" <> tshow i) (fromIntegral i), nrgYears = 2}
+    withTransaction cStore (\db -> createCodeRegistration db new code (addUTCTime (fromIntegral i) t0)) `shouldReturn` Right ()
+  answerFree ctx "alicebakers"
+  answerUnowned ctx "alicebakery50"
+  movedOrder <- registrationById ctx (oldOrder 50) >>= \r -> rewrite ctx r failedPhase
+  to <- moveTo ctx "alicebakers" 10
+  void $ moved ctx keyA movedOrder to
+  (InvoiceId invId, _) <- placed ctx aliceOrder
+  paid <- invoiceRegistration ctx (InvoiceId invId)
+  advance ctx 1
+  lapsed <- paidIn ctx dynamisOrder $ \r -> (committedPhase r) {nrRevealBefore = Just (seconds orderTime)}
+  findBody ctx keyA (T.toLower ownerAText) (seconds orderTime) >>= postFind ctx >>= \case
+    (200, Just v) | Just (J.Array found) <- KM.lookup "registrations" v -> do
+      let entries = map objectEntry $ toList found
+      map (field "registrationId") entries `shouldBe` map (Just . idText) (nrId lapsed : nrId paid : [oldOrder i | i <- [50, 49 .. 3]])
+      case entries of
+        lapsedEntry : unpaidEntry : moveEntry : _ -> do
+          (field "phase" lapsedEntry, nrPhase lapsed) `shouldBe` (Just "failed", PCommitted)
+          sort (KM.keys unpaidEntry) `shouldBe` sort ["registrationId", "invoiceId", "phase", "createdAt", "labelHash", "sealed"]
+          unpaidEntry
+            `shouldBe` KM.fromList
+              [ ("registrationId", idText $ nrId paid),
+                ("invoiceId", J.String invId),
+                ("phase", "unpaid"),
+                ("createdAt", J.toJSON orderTime),
+                ("labelHash", labelHashText "alicebakery"),
+                ("sealed", "sealed-alicebakery-1")
+              ]
+          moveEntry
+            `shouldBe` KM.fromList
+              [ ("registrationId", "old50"),
+                ("invoiceId", J.Null),
+                ("phase", "queued"),
+                ("createdAt", J.toJSON $ addUTCTime 50 t0),
+                ("labelHash", labelHashText "alicebakers"),
+                ("sealed", "sealed-alicebakers-10")
+              ]
+        _ -> expectationFailure "fewer than three entries"
+    other -> expectationFailure $ "find refused: " <> show other
+  (findBody ctx keyB ownerBText (seconds orderTime) >>= postFind ctx) `shouldReturn` refusedWith 404 "not_found"
+  where
+    oldOrder i = RegistrationId $ "old" <> tshow (i :: Int)
+    idText (RegistrationId t) = J.String t
+    objectEntry = \case
+      J.Object o -> o
+      other -> error $ "not an entry: " <> show other
+
+testFindRefused :: IO ()
+testFindRefused = withOwner $ \ctx -> do
+  void $ placed ctx aliceOrder
+  let ts = seconds orderTime
+  (findBody ctx keyB ownerAText ts >>= postFind ctx) `shouldReturn` refusedWith 400 "bad_request"
+  (findBody ctx keyA ownerAText (ts - signedWindow - 1) >>= postFind ctx) `shouldReturn` refusedWith 400 "bad_request"
+  (findBody ctx keyA ownerAText (ts + signedWindow + 1) >>= postFind ctx) `shouldReturn` refusedWith 400 "bad_request"
+  body <- findBody ctx keyA ownerAText ts
+  postFind ctx (KM.insert "owner" "0x014f9c09" body) `shouldReturn` refusedWith 400 "bad_request"
+  postFind ctx (KM.delete "signature" body) `shouldReturn` refusedWith 400 "bad_request"
+  post ctx "/api/registration/find" "[]" `shouldReturn` refusedWith 400 "bad_request"
+  findBody ctx keyA ownerAText (ts - signedWindow) >>= postFind ctx >>= (`shouldBe` 200) . fst
+
+testMoveRefusedPhases :: IO ()
+testMoveRefusedPhases = withOwner $ \ctx -> do
+  answerFree ctx "alicebakers"
+  to <- moveTo ctx "alicebakers" 10
+  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
+    (nrPhase r,) <$> move ctx keyA r to `shouldReturn` (nrPhase r, refusedWith 400 "bad_request")
+    stored ctx r `shouldReturn` r
+
+testMoveAccepted :: IO ()
+testMoveAccepted = withOwner $ \ctx -> do
+  answerFree ctx "alicebakers"
+  failedOrder <- paidIn ctx aliceOrder failedPhase
+  to <- moveTo ctx "alicebakers" 10
+  v <- moved ctx keyA failedOrder to
+  fieldsIn v
+    [ ("phase", "queued"),
+      ("labelHash", labelHashText "alicebakers"),
+      ("commitment", J.String $ hex $ ofCommitment to),
+      ("sealed", J.String $ ofSealed to),
+      ("duration", J.toJSON $ ofDuration to),
+      ("price", J.Number 10000),
+      ("moves", J.Number 1),
+      ("version", J.toJSON $ nrVersion failedOrder + 1),
+      ("linksRefused", J.Bool False),
+      ("label", J.Null),
+      ("commitTx", J.Null),
+      ("revealAfter", J.Null),
+      ("revealBefore", J.Null),
+      ("error", J.Null)
+    ]
+  written <- stored ctx failedOrder
+  (nrPhase written, nrLive written, nrMoves written, nrFailedAt written, nrOrderHash written) `shouldBe` (PQueued, True, 1, Nothing, nrOrderHash failedOrder)
+  -- the same name with other links, after a reveal refused for its links
+  refusedOrder <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 2} linksRefusedPhase
+  sameName <- moveTo ctx "alicebakery" 11
+  v2 <- moved ctx keyB refusedOrder sameName
+  fieldsIn v2 [("phase", "queued"), ("labelHash", labelHashText "alicebakery"), ("linksRefused", J.Bool False), ("commitTx", J.Null), ("revealAfter", J.Null), ("moves", J.Number 1)]
+  (nrLinksRefusedAt &&& nrCommitTx) <$> stored ctx refusedOrder `shouldReturn` (Nothing, Nothing)
+  -- a committed order with no reveal past revealBefore reads failed
+  lapsed <- paidIn ctx dynamisOrder $ \r -> (committedPhase r) {nrRevealBefore = Just (seconds orderTime - 1)}
+  back <- moveTo ctx "alicebakery" 12
+  v3 <- moved ctx keyA lapsed back
+  fieldsIn v3 [("phase", "queued"), ("error", J.Null), ("price", J.Number 10000)]
+
+testMoveRepeat :: IO ()
+testMoveRepeat = withOwner $ \ctx -> do
+  answerFree ctx "alicebakers"
+  r <- paidIn ctx aliceOrder failedPhase
+  -- the current fields from failed: nothing moves
+  (status, v) <- move ctx keyA r (currentFields r)
+  (status, field "phase" =<< v, field "moves" =<< v) `shouldBe` (200, Just "failed", Just (J.Number 0))
+  stored ctx r `shouldReturn` r
+  to <- moveTo ctx "alicebakers" 10
+  body <- moveBody ctx keyA (nrId r) to
+  first' <- postMove ctx (nrId r) body
+  fst first' `shouldBe` 200
+  movedOnce <- stored ctx r
+  advance ctx 3600
+  postMove ctx (nrId r) body `shouldReturn` first'
+  resigned <- moveBody ctx keyA (nrId r) to
+  postMove ctx (nrId r) resigned `shouldReturn` first'
+  stored ctx r `shouldReturn` movedOnce
+  nrMoves movedOnce `shouldBe` 1
+
+testMoveLimit :: IO ()
+testMoveLimit = withOwner $ \ctx -> do
+  answerFree ctx "alicebakers"
+  r <- paidIn ctx aliceOrder failedPhase
+  forM_ (zip [1 :: Int ..] ["alicebakers", "alicebakery", "alicebakers"]) $ \(n, label) -> do
+    to <- moveTo ctx label (10 + n)
+    v <- moved ctx keyA r to
+    field "moves" v `shouldBe` Just (J.toJSON n)
+    rewrite ctx r failedPhase
+  limited <- stored ctx r
+  to <- moveTo ctx "alicebakery" 20
+  view <- getView ctx limited
+  move ctx keyA limited to `shouldReturn` refusedWithView "move_limit" view
+  (field "moves" view, field "phase" view) `shouldBe` (Just (J.Number 3), Just "failed")
+  stored ctx r `shouldReturn` limited
+
+testMoveMeetsOrder :: IO ()
+testMoveMeetsOrder = withOwner $ \ctx -> do
+  answerFree ctx "alicebakers"
+  r <- paidIn ctx aliceOrder failedPhase
+  void $ placed ctx dynamisOrder
+  toDynamis <- moveTo ctx "dynamis" 10
+  move ctx keyA r toDynamis `shouldReturn` refusedWith 409 "order_exists"
+  void $ placed ctx (byB aliceOrder) {oLabel = "alicebakers", oCommitment = commitmentOf 4}
+  toForeign <- moveTo ctx "alicebakers" 4
+  move ctx keyA r toForeign `shouldReturn` refusedWith 409 "order_exists"
+  stored ctx r `shouldReturn` r
+
+testMoveOrderChecks :: IO ()
+testMoveOrderChecks = withOwner $ \ctx@Ctx {cNode} -> do
+  r <- paidIn ctx aliceOrder failedPhase
+  to <- moveTo ctx "alicebakers" 10
+  move ctx keyA r to {ofLength = 5} `shouldReturn` refusedWith 400 "invalid_name"
+  move ctx keyA r to {ofLength = 64} `shouldReturn` refusedWith 400 "invalid_name"
+  answerFree ctx "alicebakers"
+  move ctx keyA r to {ofDuration = ofDuration to + 3601} `shouldReturn` refusedWith 400 "bad_request"
+  answerReserved ctx "alicebakers" 1
+  move ctx keyA r to `shouldReturn` refusedWith 409 "name_taken"
+  setFault cNode "eth_call" HttpFailure
+  move ctx keyA r to `shouldReturn` refusedWith 503 "name_check_unavailable"
+  stored ctx r `shouldReturn` r
+
+testMoveLanded :: IO ()
+testMoveLanded = withOwner $ \ctx -> do
+  answerFree ctx "alicebakers"
+  minedOrder <- paidIn ctx aliceOrder failedPhase
+  (ownedOrder, code) <- codeIn ctx 7 dynamisOrder failedPhase
+  notLanded <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 2} failedPhase
+  let expiry = seconds orderTime + 2 * 31536000
+  forM_ ["alicebakery", "dynamis"] $ \label -> answerExpiry ctx label expiry
+  TxHash minedHash <- sentRegister ctx minedOrder 1 TSMined
+  answerOwner ctx "dynamis" (nrOwner ownedOrder)
+  void $ sentRegister ctx notLanded 2 TSReverted
+  answerOwner ctx "alicebakery" (nrOwner minedOrder)
+  forM_ [(minedOrder, Just minedHash), (ownedOrder, Nothing)] $ \(r, hash) -> do
+    poll <- held ctx r
+    to <- moveTo ctx "alicebakers" 10
+    answer <- move ctx keyA r to
+    view <- getView ctx r
+    answer `shouldBe` refusedWithView "registration_changed" view
+    woken poll `shouldReturn` (200, view)
+    fieldsIn view [("phase", "registered"), ("expiresAt", J.toJSON expiry), ("moves", J.Number 0), ("error", J.Null), ("registerTx", maybe J.Null (J.String . hex) hash)]
+    written <- stored ctx r
+    (nrPhase written, nrLive written, nrVersion written, nrLabelHash written) `shouldBe` (PRegistered, False, nrVersion r + 1, nrLabelHash r)
+  pcSpentAt <$> codeRow ctx code `shouldReturn` Just orderTime
+  to <- moveTo ctx "alicebakers" 11
+  v <- moved ctx keyB notLanded to
+  fieldsIn v [("phase", "queued"), ("moves", J.Number 1)]
+
+testMoveLandedReleasedCode :: IO ()
+testMoveLandedReleasedCode = withOwner $ \ctx@Ctx {cStore} -> do
+  answerFree ctx "alicebakers"
+  spender <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 20} id
+  (unused, unusedCode) <- codeIn ctx 7 dynamisOrder failedPhase
+  (spentElsewhere, spentCode) <- codeIn ctx 8 aliceOrder failedPhase
+  let expiry = seconds orderTime + 2 * 31536000
+  forM_ [("dynamis", unused), ("alicebakery", spentElsewhere)] $ \(label, r) -> do
+    answerExpiry ctx label expiry
+    answerOwner ctx label (nrOwner r)
+  forM_ [(unused, unusedCode), (spentElsewhere, spentCode)] $ \(r, code) ->
+    withTransaction cStore (\db -> releasePrepaidCode db (pcId code) (nrId r)) `shouldReturn` True
+  withTransaction cStore $ \db -> do
+    reservePrepaidCode db (pcId spentCode) (nrId spender) orderTime `shouldReturn` True
+    spendPrepaidCode db (pcId spentCode) (nrId spender) orderTime `shouldReturn` True
+  spenderBefore <- stored ctx spender
+  spentBefore <- codeRow ctx spentCode
+  to <- moveTo ctx "alicebakers" 10
+  fst <$> move ctx keyA unused to `shouldReturn` 409
+  nrPhase <$> stored ctx unused `shouldReturn` PRegistered
+  (pcReservedBy &&& pcSpentAt) <$> codeRow ctx unusedCode `shouldReturn` (Just (nrId unused), Just orderTime)
+  to' <- moveTo ctx "alicebakers" 11
+  logs <- capturingStderr $ fst <$> move ctx keyA spentElsewhere to' `shouldReturn` 409
+  nrPhase <$> stored ctx spentElsewhere `shouldReturn` PRegistered
+  length (filter (\l -> "[ERROR " `T.isInfixOf` l && hex (pcCodeHash spentCode) `T.isInfixOf` l && idText (nrId spentElsewhere) `T.isInfixOf` l) $ T.lines logs) `shouldBe` 1
+  codeRow ctx spentCode `shouldReturn` spentBefore
+  stored ctx spender `shouldReturn` spenderBefore
+  where
+    idText (RegistrationId t) = t
+
+testMoveLandedUnread :: IO ()
+testMoveLandedUnread = withOwner $ \ctx@Ctx {cNode} -> do
+  answerFree ctx "alicebakers"
+  r <- paidIn ctx aliceOrder failedPhase
+  -- a revert with data is a failed read, not an unowned name
+  answerCall cNode (registrarOf cNode) (ownerOfSelector <> labelBytes "alicebakery") $ Reverts $ unhex "37ed32e8"
+  to <- moveTo ctx "alicebakers" 10
+  move ctx keyA r to `shouldReturn` refusedWith 503 "name_check_unavailable"
+  stored ctx r `shouldReturn` r
+
+testMovePrice :: IO ()
+testMovePrice = withOwner $ \ctx -> do
+  answerFree ctx "alicebakers"
+  cheap <- paidIn ctx aliceOrder failedPhase
+  toDynamis <- moveTo ctx "dynamis" 10
+  move ctx keyA cheap toDynamis `shouldReturn` (409, Just $ KM.fromList [("error", "price_too_high"), ("price", J.Number 20000)])
+  stored ctx cheap `shouldReturn` cheap
+  dear <- paidIn ctx (byB dynamisOrder) takenPhase
+  toCheaper <- moveTo ctx "alicebakers" 11
+  v <- moved ctx keyB dear toCheaper
+  (field "price" v, field "phase" v) `shouldBe` (Just (J.Number 10000), Just "queued")
+  nrPrice <$> stored ctx dear `shouldReturn` 10000
+
+testMoveCodeOrder :: IO ()
+testMoveCodeOrder = withOwner $ \ctx@Ctx {cStore} -> do
+  answerFree ctx "alicebakers"
+  (r, code@PrepaidCode {pcCodeHash}) <- codeIn ctx 8 aliceOrder failedPhase
+  toShorter <- moveTo ctx "dynamis" 10
+  move ctx keyA r toShorter `shouldReturn` refusedWith 409 "code_not_covering"
+  stored ctx r `shouldReturn` r
+  withTransaction cStore (\db -> revokePrepaidCode db pcCodeHash orderTime) `shouldReturn` Revoked (pcId code)
+  withTransaction cStore $ \db -> DB.execute db "UPDATE sx_badge_service_name_prepaid_codes SET expires_at = ? WHERE code_hash = ?" (orderTime, DB.Binary pcCodeHash)
+  to <- moveTo ctx "alicebakers" 11
+  v <- moved ctx keyA r to
+  (field "phase" v, field "price" v) `shouldBe` (Just "queued", Just (J.Number 0))
+  (pcReservedBy &&& pcSpentAt) <$> codeRow ctx code `shouldReturn` (Just (nrId r), Nothing)
+
+testMoveReleasedCode :: IO ()
+testMoveReleasedCode = withOwner $ \ctx@Ctx {cStore} -> do
+  answerFree ctx "alicebakers"
+  spender <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 20} id
+  holder <- paidIn ctx (byB dynamisOrder) {oCommitment = commitmentOf 21} id
+  let refusals :: [(Text, PrepaidCode -> DB.Connection -> IO (), (Int, Maybe J.Object))]
+      refusals =
+        [ ("spent", \PrepaidCode {pcId} db -> reservePrepaidCode db pcId (nrId spender) orderTime >> void (spendPrepaidCode db pcId (nrId spender) orderTime), refusedWith 409 "code_used"),
+          ("held", \PrepaidCode {pcId} db -> void $ reservePrepaidCode db pcId (nrId holder) orderTime, refusedWith 409 "code_reserved"),
+          ("revoked", \PrepaidCode {pcCodeHash} db -> void $ revokePrepaidCode db pcCodeHash orderTime, refusedWith 400 "code_invalid"),
+          ("expired", \PrepaidCode {pcCodeHash} db -> DB.execute db "UPDATE sx_badge_service_name_prepaid_codes SET expires_at = ? WHERE code_hash = ?" (orderTime, DB.Binary pcCodeHash), refusedWith 409 "code_expired")
+        ]
+  forM_ (zip [1 :: Int ..] refusals) $ \(n, (what, change, refusal)) -> do
+    let label = "codeorder" <> tshow n
+    answerFree ctx label
+    (r, code) <- codeIn ctx 8 aliceOrder {oLabel = label, oCommitment = commitmentOf (30 + n)} failedPhase
+    withTransaction cStore (\db -> releasePrepaidCode db (pcId code) (nrId r)) `shouldReturn` True
+    withTransaction cStore $ change code
+    to <- moveTo ctx "alicebakers" (40 + n)
+    (what,) <$> move ctx keyA r to `shouldReturn` (what, refusal)
+    stored ctx r `shouldReturn` r
+  (r, code) <- codeIn ctx 8 aliceOrder failedPhase
+  withTransaction cStore (\db -> releasePrepaidCode db (pcId code) (nrId r)) `shouldReturn` True
+  to <- moveTo ctx "alicebakers" 50
+  void $ moved ctx keyA r to
+  pcReservedBy <$> codeRow ctx code `shouldReturn` Just (nrId r)
+
+testMoveSizes :: IO ()
+testMoveSizes = withOwner $ \ctx -> do
+  answerFree ctx "alicebakers"
+  r <- paidIn ctx aliceOrder failedPhase
+  to <- moveTo ctx "alicebakers" 10
+  let longest = to {ofSealed = T.replicate 11095 "s"}
+  body <- moveBody ctx keyA (nrId r) longest
+  postMove ctx (nrId r) (KM.insert "owner" (J.String $ T.replicate 5300 "0") body) `shouldReturn` refusedWith 400 "bad_request"
+  move ctx keyA r to {ofSealed = T.replicate 11096 "s"} `shouldReturn` refusedWith 400 "bad_request"
+  valid <- moveBody ctx keyA (nrId r) to
+  forM_ [KM.insert "labelHash" (J.String $ T.toUpper $ hex $ (\(LabelHash h) -> h) $ ofLabelHash to) valid, KM.delete "signature" valid, KM.insert "length" "11" valid] $ \malformed ->
+    postMove ctx (nrId r) malformed `shouldReturn` refusedWith 400 "bad_request"
+  post ctx (registrationPath (nrId r) <> "/name") "[]" `shouldReturn` refusedWith 400 "bad_request"
+  stored ctx r `shouldReturn` r
+  -- an owner in the body is ignored
+  (status, v) <- postMove ctx (nrId r) (KM.insert "owner" (J.String ownerBText) body)
+  (status, field "sealed" =<< v, field "owner" =<< v) `shouldBe` (200, Just (J.String $ ofSealed longest), Just (J.String ownerAText))
+
+testMoveRefusedSigner :: IO ()
+testMoveRefusedSigner = withOwner $ \ctx -> do
+  answerFree ctx "alicebakers"
+  r <- paidIn ctx aliceOrder failedPhase
+  to <- moveTo ctx "alicebakers" 10
+  move ctx keyB r to `shouldReturn` refusedWith 400 "bad_request"
+  ts <- clockSeconds ctx
+  (moveBodyAt ctx keyA (nrId r) to (ts - signedWindow - 1) >>= postMove ctx (nrId r)) `shouldReturn` refusedWith 400 "bad_request"
+  stored ctx r `shouldReturn` r
+  let unknown = RegistrationId "t2Jk8RmQ4vXw9NcP3yLb6g"
+  (moveBody ctx keyA unknown to >>= postMove ctx unknown) `shouldReturn` refusedWith 404 "not_found"
+
+testMoveLostRace :: IO ()
+testMoveLostRace = withOwner $ \ctx@Ctx {cNode} -> do
+  answerFree ctx "alicebakers"
+  r <- paidIn ctx aliceOrder failedPhase
+  to <- moveTo ctx "alicebakers" 10
+  setFault cNode "eth_call" (Slow slowRead)
+  moving <- async $ move ctx keyA r to
+  awaitTurns ctx 2
+  threadDelay raceDelay
+  changed <- rewrite ctx r id
+  clearFault cNode "eth_call"
+  answer <- within "the move" $ wait moving
+  view <- getView ctx changed
+  answer `shouldBe` refusedWithView "registration_changed" view
+  field "version" view `shouldBe` Just (J.toJSON $ nrVersion r + 1)
+  stored ctx r `shouldReturn` changed
+
+-- | Each round holds the higher hash's turn while both orders start, the one moving from the lower hash first in odd
+-- rounds and last in even ones, so that without the hash order some round has each order holding one turn and waiting
+-- for the other's.
+testMovesCross :: IO ()
+testMovesCross = withOwnerAs (\cfg -> cfg {nMaxOrderMoves = 100}) $ \ctx -> do
+  answerFree ctx "alicebakers"
+  let (low, high) = case sortOn hashOf ["alicebakery", "alicebakers"] of
+        [l, h] -> (l, h)
+        _ -> error "two names"
+  a <- paidIn ctx aliceOrder {oLabel = low, oCommitment = commitmentOf 60} failedPhase
+  b <- paidIn ctx (byB aliceOrder) {oLabel = high, oCommitment = commitmentOf 61} failedPhase
+  forM_ [1 .. 6 :: Int] $ \n -> do
+    rs <- mapM (stored ctx) [a, b]
+    let onName label = fromJust $ find ((== labelHash label) . nrLabelHash) rs
+        keyOf r = if nrOwner r == nrOwner a then keyA else keyB
+        bodyTo r label k = moveTo ctx label (100 + 2 * n + k) >>= moveBody ctx (keyOf r) (nrId r)
+        (fromLow, fromHigh) = (onName low, onName high)
+    lowMove <- (fromLow,) <$> bodyTo fromLow high 0
+    highMove <- (fromHigh,) <$> bodyTo fromHigh low 1
+    holding <- newEmptyMVar
+    release <- newEmptyMVar
+    holder <- async $ withLabelTurn (oeTurns $ cOrders ctx) (labelHash high) $ putMVar holding () >> takeMVar release
+    takeMVar holding
+    let started = if odd n then [lowMove, highMove] else [highMove, lowMove]
+    moves <- forM started $ \(r, body) -> async (postMove ctx (nrId r) body) <* threadDelay parkDelay
+    putMVar release ()
+    wait holder
+    outcomes <- within ("round " <> show n) $ mapM wait moves
+    map fst outcomes `shouldBe` [200, 200]
+    forM_ [a, b] $ \r -> rewrite ctx r failedPhase
+  where
+    hashOf label = (\(LabelHash h) -> h) (labelHash label)
+
+testTakenCode :: IO ()
+testTakenCode = withOwner $ \ctx@Ctx {cNode} -> do
+  answerPrices ctx launchPricesAnswer
+  answerCall cNode fakeController (rentPriceCall 6) $ Returns $ rentPriceAnswer 40000
+  answerCall cNode fakeController (rentPriceCall 12) $ Returns $ rentPriceAnswer 10000
+  forM_ (zip [1 :: Int ..] [("bakery", 40000, 6), ("dynamis", 20000, 7), ("alicebakery2", 10000, 8)]) $ \(n, (label, price, len)) -> do
+    answerFree ctx label
+    r <- paidIn ctx aliceOrder {oLabel = label, oPrice = price, oCommitment = commitmentOf (70 + n)} takenPhase
+    field "codeLength" <$> getView ctx r `shouldReturn` Just (J.toJSON len)
+    let (hashText, hash) = takenCodeHash n
+    takeCode ctx keyA r hashText len `shouldReturn` (200, answered)
+    written <- stored ctx r
+    (nrPhase written, nrLive written, nrVersion written) `shouldBe` (PCodeIssued, False, nrVersion r + 1)
+    PrepaidCode {pcCodeHash, pcMinLength, pcYears, pcPaymentStatus, pcReservedBy, pcSpentAt, pcRevokedAt, pcExpiresAt} <- issuedCode ctx written
+    (pcCodeHash, pcMinLength, pcYears, pcPaymentStatus) `shouldBe` (hash, len, 2, CPSPaid)
+    (pcReservedBy, pcSpentAt, pcRevokedAt, pcExpiresAt) `shouldBe` (Nothing, Nothing, Nothing, Nothing)
+    v <- getView ctx r
+    (field "phase" v, field "codeLength" v) `shouldBe` (Just "code_issued", Just (J.toJSON len))
+
+-- | 12 letters paid 10000 cents: with these prices 8 letters and longer cost that or less.
+takenTwelve :: Ctx -> IO NameRegistration
+takenTwelve ctx@Ctx {cNode} = do
+  answerPrices ctx launchPricesAnswer
+  answerCall cNode fakeController (rentPriceCall 12) $ Returns $ rentPriceAnswer 10000
+  answerFree ctx "alicebakery2"
+  paidIn ctx aliceOrder {oLabel = "alicebakery2", oPrice = 10000} takenPhase
+
+testTakenCodeRepeat :: IO ()
+testTakenCodeRepeat = withOwner $ \ctx -> do
+  r <- takenTwelve ctx
+  let (hashText, _) = takenCodeHash 1
+  body <- clockSeconds ctx >>= codeBodyAt ctx keyA (nrId r) hashText 8
+  postCode ctx (nrId r) body `shouldReturn` (200, answered)
+  issued <- stored ctx r
+  -- 9 letters and longer now cost 10000 cents, so a fresh computation would answer 9
+  answerPrices ctx $ pricesAnswer 5000 [(8, 6000), (7, 10000), (6, 20000)]
+  advance ctx 3600
+  postCode ctx (nrId r) body `shouldReturn` (200, answered)
+  takeCode ctx keyA r hashText 9 `shouldReturn` (200, answered)
+  stored ctx r `shouldReturn` issued
+  field "codeLength" <$> getView ctx r `shouldReturn` Just (J.Number 8)
+  takeCode ctx keyA r (fst $ takenCodeHash 2) 9 `shouldReturn` refusedWith 400 "bad_request"
+
+testCodeLengthChanged :: IO ()
+testCodeLengthChanged = withOwner $ \ctx@Ctx {cStore} -> do
+  r <- takenTwelve ctx
+  field "codeLength" <$> getView ctx r `shouldReturn` Just (J.Number 8)
+  answerPrices ctx $ pricesAnswer 5000 [(8, 6000), (7, 10000), (6, 20000)]
+  let (hashText, hash) = takenCodeHash 1
+  takeCode ctx keyA r hashText 8 `shouldReturn` (409, Just $ KM.fromList [("error", "code_length_changed"), ("codeLength", J.Number 9)])
+  stored ctx r `shouldReturn` r
+  withTransaction cStore (`getPrepaidCode` hash) `shouldReturn` Nothing
+  takeCode ctx keyA r hashText 9 `shouldReturn` (200, answered)
+  pcMinLength <$> (issuedCode ctx =<< stored ctx r) `shouldReturn` 9
+
+testCodeUnavailable :: IO ()
+testCodeUnavailable = withOwner $ \ctx@Ctx {cNode} -> do
+  r <- takenTwelve ctx
+  answerPrices ctx $ pricesAnswer 6000 []
+  let (hashText, _) = takenCodeHash 1
+  takeCode ctx keyA r hashText 8 `shouldReturn` refusedWith 409 "code_unavailable"
+  field "codeLength" <$> getView ctx r `shouldReturn` Just J.Null
+  setFault cNode "eth_call" HttpFailure
+  takeCode ctx keyA r hashText 8 `shouldReturn` refusedWith 503 "provider_unavailable"
+  stored ctx r `shouldReturn` r
+
+testTakenCodeRefused :: IO ()
+testTakenCodeRefused = withOwner $ \ctx -> do
+  r <- takenTwelve ctx
+  let (hashText, _) = takenCodeHash 1
+  takeCode ctx keyB r hashText 8 `shouldReturn` refusedWith 400 "bad_request"
+  ts <- clockSeconds ctx
+  (codeBodyAt ctx keyA (nrId r) hashText 8 (ts - signedWindow - 1) >>= postCode ctx (nrId r)) `shouldReturn` refusedWith 400 "bad_request"
+  body <- codeBodyAt ctx keyA (nrId r) hashText 8 ts
+  forM_ [KM.insert "codeHash" (J.String $ T.drop 1 hashText) body, KM.insert "codeLength" "8" body, KM.delete "timestamp" body] $ \malformed ->
+    postCode ctx (nrId r) malformed `shouldReturn` refusedWith 400 "bad_request"
+  stored ctx r `shouldReturn` r
+  (codeOrder, _) <- codeIn ctx 8 aliceOrder {oCommitment = commitmentOf 5} takenPhase
+  committedOrder <- paidIn ctx dynamisOrder committedPhase
+  forM_ [codeOrder, committedOrder] $ \o -> do
+    takeCode ctx keyA o hashText 8 `shouldReturn` refusedWith 400 "bad_request"
+    stored ctx o `shouldReturn` o
+  let unknown = RegistrationId "t2Jk8RmQ4vXw9NcP3yLb6g"
+  (codeBodyAt ctx keyA unknown hashText 8 ts >>= postCode ctx unknown) `shouldReturn` refusedWith 404 "not_found"
+
+testCodeConflict :: IO ()
+testCodeConflict = withOwner $ \ctx@Ctx {cStore} -> do
+  r <- takenTwelve ctx
+  let (hashText, hash) = takenCodeHash 1
+  Right _ <- withTransaction cStore $ \db -> insertPrepaidCode db NewPrepaidCode {npcCodeHash = hash, npcMinLength = 8, npcYears = 2, npcPaymentStatus = CPSPaid, npcExpiresAt = Nothing} orderTime
+  takeCode ctx keyA r hashText 8 `shouldReturn` refusedWith 409 "code_conflict"
+  stored ctx r `shouldReturn` r
+
+testCodeLostRace :: IO ()
+testCodeLostRace = withOwner $ \ctx@Ctx {cNode, cStore} -> do
+  r <- takenTwelve ctx
+  let (hashText, hash) = takenCodeHash 1
+  setFault cNode "eth_call" (Slow slowRead)
+  issuing <- async $ takeCode ctx keyA r hashText 8
+  awaitTurns ctx 1
+  threadDelay raceDelay
+  changed <- rewrite ctx r id
+  clearFault cNode "eth_call"
+  answer <- within "the code" $ wait issuing
+  view <- getView ctx changed
+  answer `shouldBe` refusedWithView "registration_changed" view
+  stored ctx r `shouldReturn` changed
+  withTransaction cStore (`getPrepaidCode` hash) `shouldReturn` Nothing
+
+testPollsWoken :: IO ()
+testPollsWoken = withOwner $ \ctx -> do
+  answerFree ctx "alicebakers"
+  r <- paidIn ctx aliceOrder failedPhase
+  poll <- held ctx r
+  to <- moveTo ctx "alicebakers" 10
+  void $ moved ctx keyA r to
+  (status, v) <- woken poll
+  (status, field "version" v, field "phase" v) `shouldBe` (200, Just (J.toJSON $ nrVersion r + 1), Just "queued")
+  t <- takenTwelve ctx
+  poll' <- held ctx t
+  takeCode ctx keyA t (fst $ takenCodeHash 1) 8 `shouldReturn` (200, answered)
+  (status', v') <- woken poll'
+  (status', field "version" v', field "phase" v') `shouldBe` (200, Just (J.toJSON $ nrVersion t + 1), Just "code_issued")

tests/Test.hs

@@ -16,6 +16,7 @@ import Bots.StoreService.NamesContractsTests
 import Bots.StoreService.NamesLabelTests
 import Bots.StoreService.NamesLinksTests
 import Bots.StoreService.NamesOrdersTests
+import Bots.StoreService.NamesOwnerTests
 import Bots.StoreService.NamesPhasesTests
 import Bots.StoreService.NamesProfilesTests
 import Bots.StoreService.NamesRecordsTests
@@ -107,6 +108,7 @@ main = do
       namesLabelTests
       namesLinksTests
       namesOrdersTests
+      namesOwnerTests
       namesPhasesTests
       namesProfilesTests
       namesRecordsTests