store: relay owner-signed record edits

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

@@ -11,6 +11,7 @@ import StoreService.Names.Chain (ChainClient, newChainClient)
 import StoreService.Names.Contracts (Contracts, newContracts)
 import StoreService.Names.Phases (Phases, newPhases)
 import StoreService.Names.Profiles (Profiles, chatProfile, defaultProfileLimits, monotonicSeconds, newProfiles, systemResolver)
+import StoreService.Names.Records (Records, newRecords)
 import StoreService.Names.Sender (Sender, newSender)
 import StoreService.Names.Turns (Turns)
 
@@ -24,7 +25,8 @@ data NamesEnv = NamesEnv
     neChain :: ChainClient,
     neContracts :: Contracts,
     neProfiles :: Profiles,
-    neSender :: Sender
+    neSender :: Sender,
+    neRecords :: Records
   }
 
 newNamesEnv :: ChatController -> UserId -> NamesConfig -> DBStore -> Turns -> IO NamesEnv
@@ -34,4 +36,5 @@ newNamesEnv neChat@ChatController {random} neUserId neConfig@NamesConfig {nTLD,
   neContracts <- newContracts nTLD neChain
   neProfiles <- newProfiles defaultProfileLimits monotonicSeconds (chatProfile neChat neUserId) systemResolver
   neSender <- newSender random neChain neStore getCurrentTime
-  pure NamesEnv {neChat, neUserId, neConfig, neStore, nePhases, neTurns, neChain, neContracts, neProfiles, neSender}
+  neRecords <- newRecords neStore neTurns neContracts neChain neSender nTLD getCurrentTime
+  pure NamesEnv {neChat, neUserId, neConfig, neStore, nePhases, neTurns, neChain, neContracts, neProfiles, neSender, neRecords}

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

@@ -0,0 +1,362 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+-- | Record edits signed by a name's owner, relayed through the registrar key's sender and followed to their outcome.
+module StoreService.Names.Records
+  ( Records (rsPendingAfter),
+    EditRequest (..),
+    EditAnswer (..),
+    newRecords,
+    relayEdit,
+    runRecordEdits,
+    recordsRound,
+  )
+where
+
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.STM
+import Control.Exception (bracket)
+import Control.Monad (forM, forever, unless, void, when)
+import Control.Monad.Except (ExceptT (..), runExceptT)
+import Control.Monad.IO.Class (liftIO)
+import Data.ByteString (ByteString)
+import Data.Int (Int64)
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
+import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime)
+import Data.Word (Word64)
+import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
+import qualified Simplex.Messaging.Agent.Store.DB as DB
+import Simplex.Messaging.Crypto (sha256Hash)
+import Simplex.Messaging.Crypto.Secp256k1 (RecoverableSignature)
+import Simplex.Messaging.Eth.Address (Address, recoverAddress)
+import Simplex.Messaging.Eth.EIP712 (Eip712Domain, serializeSignature)
+import Simplex.Messaging.SimplexName (LabelHash, SimplexTLD)
+import Simplex.Messaging.Util (tshow)
+import StoreService.Config (ChainConfig (..))
+import StoreService.Log (logWarn, safely)
+import StoreService.Names.Chain
+import StoreService.Names.Contracts (Contracts, NameStatus (..), RegisteredName (..), nameStatus, resolverNonce, textRecord)
+import StoreService.Names.Registration (Node, channelRecordKey, clearRecordsDigest, clearRecordsWithSigCalldata, contactRecordKey, labelNode, resolverDomain, setTextDigest, setTextWithSigCalldata)
+import StoreService.Names.Revert (RevertName (..), revertText)
+import StoreService.Names.Sender (SendError (..), Sender, submitTransaction)
+import StoreService.Names.Store
+import StoreService.Names.Turns (Turns, withLabelTurn)
+
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple (Only (..))
+#else
+import Database.SQLite.Simple (Only (..))
+#endif
+
+data Records = Records
+  { rsStore :: DBStore,
+    rsTurns :: Turns,
+    rsContracts :: Contracts,
+    rsChain :: ChainClient,
+    rsSender :: Sender,
+    rsTLD :: SimplexTLD,
+    rsNow :: IO UTCTime,
+    -- | microseconds a request waits for its edit's outcome
+    rsPendingAfter :: Int,
+    -- | the edits a request or the lane is sending or judging, so no edit is sent twice
+    rsClaimed :: TVar (Set Int64),
+    -- | the pending edits whose last chain read failed
+    rsStalled :: TVar (Set Int64),
+    -- | grows on every settlement and stall, waking the requests that wait for an edit
+    rsChanges :: TVar Int
+  }
+
+data EditRequest = EditRequest
+  { erLabelHash :: LabelHash,
+    erChange :: RecordChange,
+    erNonce :: Word64,
+    erDeadline :: Word64,
+    erSignature :: RecoverableSignature
+  }
+  deriving (Eq, Show)
+
+data EditAnswer
+  = -- | mined, Nothing when found applied with the applying transaction unknown
+    EAApplied (Maybe TxHash)
+  | -- | the revert's name when known; the nonce is free again
+    EAReverted (Maybe Text)
+  | -- | not settled within the wait, or the chain stopped answering after the send; the edit goes on
+    EAPending
+  | -- | the signer, the deadline, the owner or the nonce
+    EARefused
+  | -- | the chain failed before anything was sent, and nothing is stored
+    EAUnavailable
+  | -- | the per-name cap, with the seconds until another edit fits
+    EACapped Int
+  deriving (Eq, Show)
+
+-- | What the chain shows of an edit none of whose transactions mined.
+data Judgment
+  = -- | one of its own hashes, or Nothing when the nonce passed with the record holding its value
+    Applied (Maybe TxHash)
+  | -- | the nonce passed with the record holding another value
+    NonceTaken
+  | NonceFree
+
+-- | Below a proxy's idle timeout; the edit goes on after it.
+editPendingAfter :: Int
+editPendingAfter = 90000000
+
+-- | Relayed edits per name in 'editCapWindow'.
+editCap :: Int
+editCap = 10
+
+editCapWindow :: NominalDiffTime
+editCapWindow = 3600
+
+recordsInterval :: Int
+recordsInterval = 4000000
+
+newRecords :: DBStore -> Turns -> Contracts -> ChainClient -> Sender -> SimplexTLD -> IO UTCTime -> IO Records
+newRecords rsStore rsTurns rsContracts rsChain rsSender rsTLD rsNow = do
+  rsClaimed <- newTVarIO S.empty
+  rsStalled <- newTVarIO S.empty
+  rsChanges <- newTVarIO 0
+  pure Records {rsStore, rsTurns, rsContracts, rsChain, rsSender, rsTLD, rsNow, rsPendingAfter = editPendingAfter, rsClaimed, rsStalled, rsChanges}
+
+-- | An identical repeat of a sent edit is answered from it, before any chain read.
+relayEdit :: Records -> EditRequest -> IO EditAnswer
+relayEdit rs req@EditRequest {erSignature} =
+  recoverAddress erSignature digest >>= \case
+    Left _ -> pure EARefused
+    Right signer ->
+      withStore rs (`getRecordEditByBody` bodyHash) >>= \case
+        Just RecordEdit {reId} -> awaitEdit rs reId
+        Nothing -> newEdit rs req signer bodyHash
+  where
+    digest = editDigest rs req
+    bodyHash = sha256Hash $ digest <> serializeSignature erSignature
+
+newEdit :: Records -> EditRequest -> Address -> ByteString -> IO EditAnswer
+newEdit rs req signer bodyHash =
+  chainAccepts rs req signer >>= \case
+    Left _ -> pure EAUnavailable
+    Right False -> pure EARefused
+    Right True ->
+      insertEdit rs req signer bodyHash >>= \case
+        Left wait -> pure $ EACapped wait
+        Right (Just editId) -> sendNew rs editId
+        -- a pending or mined edit holds the nonce: the identical twin is waited for, any other body refused
+        Right Nothing -> withStore rs (`getRecordEditByBody` bodyHash) >>= maybe (pure EARefused) (awaitEdit rs . reId)
+
+-- | The deadline after the latest block's time, the signer the registry's owner on the default resolver, the nonce the owner's next.
+chainAccepts :: Records -> EditRequest -> Address -> IO (Either ChainError Bool)
+chainAccepts Records {rsChain, rsContracts} EditRequest {erLabelHash, erNonce, erDeadline} signer = runExceptT $ do
+  Block {blockTimestamp} <- ExceptT $ latestBlock rsChain
+  if erDeadline <= blockTimestamp
+    then pure False
+    else
+      ExceptT (nameStatus rsContracts erLabelHash) >>= \case
+        NSRegistered RegisteredName {rnOwner, rnResolver}
+          | rnOwner == signer && rnResolver == cResolver (ccConfig rsChain) -> (== erNonce) <$> ExceptT (resolverNonce rsContracts signer)
+        _ -> pure False
+
+-- | Left with the seconds to wait when the name's cap is used up; Right Nothing when a pending or mined edit holds the nonce.
+insertEdit :: Records -> EditRequest -> Address -> ByteString -> IO (Either Int (Maybe Int64))
+insertEdit Records {rsStore, rsTurns, rsNow} EditRequest {erLabelHash, erChange, erNonce, erDeadline, erSignature} signer bodyHash =
+  withLabelTurn rsTurns erLabelHash $ do
+    now <- rsNow
+    withTransaction rsStore $ \db -> do
+      times <- relayedEditTimes db erLabelHash (addUTCTime (negate editCapWindow) now)
+      let relayed = length times
+      if relayed >= editCap
+        then pure $ Left $ max 1 $ ceiling $ diffUTCTime (addUTCTime editCapWindow $ times !! (relayed - editCap)) now
+        else Right <$> insertRecordEdit db edit now
+  where
+    edit = NewRecordEdit {nreLabelHash = erLabelHash, nreOwner = signer, nreNonce = erNonce, nreChange = erChange, nreDeadline = erDeadline, nreSignature = erSignature, nreBodyHash = bodyHash}
+
+-- | An edit the chain failed to take is deleted while still claimed, so the lane cannot send it after.
+sendNew :: Records -> Int64 -> IO EditAnswer
+sendNew rs editId = do
+  sent <- withClaim rs editId True $ withStore rs (`getRecordEdit` editId) >>= maybe (pure True) send
+  if sent then awaitEdit rs editId else EAUnavailable <$ settled rs editId
+  where
+    send edit =
+      sendEdit rs edit >>= \case
+        Right () -> pure True
+        Left e -> do
+          logWarn $ "names records: edit " <> tshow editId <> " not sent: " <> tshow e
+          False <$ withStore rs (`deleteUnsentEdit` editId)
+
+-- | A dry run's revert is judged at once; Left when nothing was sent and the chain did not refuse the edit.
+sendEdit :: Records -> RecordEdit -> IO (Either SendError ())
+sendEdit rs@Records {rsSender} edit@RecordEdit {reId} =
+  submitTransaction rsSender (TxEdit reId) (resolver rs) (editCalldata rs edit) >>= \case
+    Right _ -> Right () <$ unstall rs reId
+    Left SEInFlight -> pure $ Right ()
+    Left (SEChain (ChainReverted name)) -> Right () <$ judged rs edit (settle rs reId $ ESReverted $ revertText =<< name)
+    Left e -> pure $ Left e
+
+-- | Waits until the edit settles, the chain stops answering for it, or 'rsPendingAfter' passes.
+awaitEdit :: Records -> Int64 -> IO EditAnswer
+awaitEdit rs@Records {rsChanges, rsStalled, rsPendingAfter} editId = registerDelay rsPendingAfter >>= loop
+  where
+    loop timer = do
+      -- read before the row, so a change committed after the read still wakes this request
+      seen <- readTVarIO rsChanges
+      withStore rs (`getRecordEdit` editId) >>= \case
+        Nothing -> pure EAUnavailable
+        Just RecordEdit {reState = ESMined tx} -> pure $ EAApplied tx
+        Just RecordEdit {reState = ESReverted revert} -> pure $ EAReverted revert
+        Just RecordEdit {reState = ESPending} -> do
+          stalled <- S.member editId <$> readTVarIO rsStalled
+          if stalled
+            then pure EAPending
+            else do
+              changed <- atomically $ (True <$ (readTVar rsChanges >>= check . (/= seen))) `orElse` (False <$ (readTVar timer >>= check))
+              if changed then loop timer else pure EAPending
+
+runRecordEdits :: Records -> IO ()
+runRecordEdits rs = forever $ recordsRound rs >> threadDelay recordsInterval
+
+-- | One pass over the pending edits that no request is sending. A pass that fails is logged, and the lane goes on.
+recordsRound :: Records -> IO ()
+recordsRound rs@Records {rsChain} = void $ safely "names records: the round" $ do
+  editIds <- withStore rs pendingEditIds
+  unless (null editIds) $
+    runExceptT (ExceptT (latestBlock rsChain) >>= \tip -> (tip,) <$> ExceptT (deepBlock rsChain tip)) >>= \case
+      Left e -> mapM_ (\editId -> stall rs editId e) editIds
+      Right (tip, deep) -> mapM_ (\editId -> withClaim rs editId () $ withStore rs (`getRecordEdit` editId) >>= mapM_ (follow rs tip deep)) editIds
+
+-- | The newest block at the configured confirmation depth, as the sender counts it.
+deepBlock :: ChainClient -> Block -> IO (Either ChainError Block)
+deepBlock c@ChainClient {ccConfig = ChainConfig {cConfirmations}} tip@Block {blockNumber}
+  | depth == 0 = pure $ Right tip
+  | otherwise = blockAt c $ if blockNumber >= depth then blockNumber - depth else 0
+  where
+    depth = fromIntegral (max 1 cConfirmations) - 1
+
+-- | One step for a pending edit, from its transactions' statuses as the sender settled them.
+follow :: Records -> Block -> Block -> RecordEdit -> IO ()
+follow rs@Records {rsChain} Block {blockTimestamp} Block {blockTimestamp = deepTime} edit@RecordEdit {reId, reDeadline} = do
+  txs <- withStore rs (`editTransactions` reId)
+  case txs of
+    [] -> if ahead then resend else expire
+    _
+      | mined : _ <- [ntHash | NameTransaction {ntHash, ntStatus = TSMined} <- txs] -> settle rs reId $ ESMined $ Just mined
+      | any ((== TSPending) . ntStatus) txs -> if deepTime > reDeadline then expire else unstall rs reId
+      -- a mined revert carries no data: past the deadline it is SignatureExpired, else unnamed
+      | block : _ <- [b | NameTransaction {ntStatus = TSReverted, ntMinedBlock = Just b} <- txs] ->
+          blockAt rsChain block >>= \case
+            Left e -> stall rs reId e
+            Right Block {blockTimestamp = minedTime} -> judged rs edit $ settle rs reId $ ESReverted $ if minedTime > reDeadline then signatureExpired else Nothing
+      -- every transaction dropped: its registrar nonce went to another one
+      | otherwise -> judged rs edit $ if ahead then resend else expire
+  where
+    ahead = reDeadline > blockTimestamp
+    expire = judged rs edit $ settle rs reId $ ESReverted signatureExpired
+    resend = sendEdit rs edit >>= either (stall rs reId) pure
+
+-- | Settles the edit as the chain shows it, or runs the action when its nonce is still free.
+judged :: Records -> RecordEdit -> IO () -> IO ()
+judged rs edit@RecordEdit {reId} whenFree =
+  judge rs edit >>= \case
+    Left e -> stall rs reId e
+    Right (Applied tx) -> settle rs reId $ ESMined tx
+    Right NonceTaken -> settle rs reId $ ESReverted $ revertText RNInvalidNonce
+    Right NonceFree -> whenFree
+
+-- | Its own transactions first: a status-1 receipt answers its hash. Without one, the owner's nonce and the record.
+judge :: Records -> RecordEdit -> IO (Either ChainError Judgment)
+judge rs@Records {rsChain, rsContracts} RecordEdit {reId, reLabelHash, reOwner, reNonce, reChange} = runExceptT $ do
+  txs <- liftIO $ withStore rs (`editTransactions` reId)
+  receipts <- forM txs $ \NameTransaction {ntHash} -> (ntHash,) <$> ExceptT (transactionReceipt rsChain ntHash)
+  case [h | (h, Just Receipt {receiptSuccess = True}) <- receipts] of
+    h : _ -> pure $ Applied $ Just h
+    [] -> do
+      nonce <- ExceptT $ resolverNonce rsContracts reOwner
+      if nonce <= reNonce
+        then pure NonceFree
+        else do
+          holds <- case reChange of
+            RCSetText key value -> (== value) <$> record (encodeUtf8 key)
+            RCClear -> (&&) <$> (unset <$> record contactRecordKey) <*> (unset <$> record channelRecordKey)
+          pure $ if holds then Applied Nothing else NonceTaken
+  where
+    record = ExceptT . textRecord rsContracts reLabelHash
+    unset = (== "")
+
+settle :: Records -> Int64 -> EditState -> IO ()
+settle rs editId state = do
+  void $ withStore rs $ \db -> settleRecordEdit db editId state
+  settled rs editId
+
+-- | Wakes the requests waiting for the edit, which read it again.
+settled :: Records -> Int64 -> IO ()
+settled Records {rsStalled, rsChanges} editId = atomically $ modifyTVar' rsStalled (S.delete editId) >> modifyTVar' rsChanges (+ 1)
+
+-- | Logged once until the edit's next successful step.
+stall :: Show e => Records -> Int64 -> e -> IO ()
+stall Records {rsStalled, rsChanges} editId e = do
+  new <- atomically $ do
+    stalled <- readTVar rsStalled
+    let new = not $ S.member editId stalled
+    when new $ writeTVar rsStalled (S.insert editId stalled) >> modifyTVar' rsChanges (+ 1)
+    pure new
+  when new $ logWarn $ "names records: edit " <> tshow editId <> " waits for the chain: " <> tshow e
+
+unstall :: Records -> Int64 -> IO ()
+unstall Records {rsStalled} editId = atomically $ modifyTVar' rsStalled $ S.delete editId
+
+-- | Runs the action only when nobody else holds the edit, else answers the fallback.
+withClaim :: Records -> Int64 -> a -> IO a -> IO a
+withClaim Records {rsClaimed} editId fallback action =
+  bracket claim (\claimed -> when claimed release) $ \claimed -> if claimed then action else pure fallback
+  where
+    claim = atomically $ do
+      held <- readTVar rsClaimed
+      if S.member editId held then pure False else True <$ writeTVar rsClaimed (S.insert editId held)
+    release = atomically $ modifyTVar' rsClaimed $ S.delete editId
+
+editDigest :: Records -> EditRequest -> ByteString
+editDigest rs EditRequest {erLabelHash, erChange, erNonce, erDeadline} = case erChange of
+  RCSetText key value -> setTextDigest (domain rs) node key value erNonce erDeadline
+  RCClear -> clearRecordsDigest (domain rs) node erNonce erDeadline
+  where
+    node = nodeOf rs erLabelHash
+
+editCalldata :: Records -> RecordEdit -> ByteString
+editCalldata rs RecordEdit {reLabelHash, reChange, reNonce, reDeadline, reSignature} = case reChange of
+  RCSetText key value -> setTextWithSigCalldata node key value reNonce reDeadline reSignature
+  RCClear -> clearRecordsWithSigCalldata node reNonce reDeadline reSignature
+  where
+    node = nodeOf rs reLabelHash
+
+nodeOf :: Records -> LabelHash -> Node
+nodeOf Records {rsTLD} = labelNode rsTLD
+
+domain :: Records -> Eip712Domain
+domain rs@Records {rsChain} = resolverDomain (cChainId $ ccConfig rsChain) (resolver rs)
+
+resolver :: Records -> Address
+resolver = cResolver . ccConfig . rsChain
+
+signatureExpired :: Maybe Text
+signatureExpired = revertText RNSignatureExpired
+
+withStore :: Records -> (DB.Connection -> IO a) -> IO a
+withStore Records {rsStore} = withTransaction rsStore
+
+pendingEditIds :: DB.Connection -> IO [Int64]
+pendingEditIds db = map fromOnly <$> DB.query db "SELECT name_record_edit_id FROM sx_badge_service_name_record_edits WHERE state = ? ORDER BY name_record_edit_id" (Only pendingState)
+
+deleteUnsentEdit :: DB.Connection -> Int64 -> IO ()
+deleteUnsentEdit db editId =
+  DB.execute
+    db
+    "DELETE FROM sx_badge_service_name_record_edits WHERE name_record_edit_id = ? AND state = ? AND NOT EXISTS (SELECT 1 FROM sx_badge_service_name_transactions WHERE name_record_edit_id = ?)"
+    (editId, pendingState, editId)
+
+pendingState :: Text
+pendingState = "pending"

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

@@ -8,8 +8,9 @@ import Data.Text (Text)
 import Network.HTTP.Types (Method)
 import Network.Wai (Request, ResponseReceived, pathInfo)
 import StoreService.Names.Env (NamesEnv (..))
-import StoreService.Web.Http (HttpEnv, Limit, Respond, codeLimit, limited, only)
+import StoreService.Web.Http (HttpEnv, Limit, Respond, codeLimit, limited, only, recordsLimit)
 import StoreService.Web.Names.Codes (codeCheckHandler)
+import StoreService.Web.Names.Records (recordsHandler)
 
 data Route = Route
   { rMethod :: Method,
@@ -18,7 +19,8 @@ data Route = Route
   }
 
 namesRoutes :: NamesEnv -> [Text] -> Maybe Route
-namesRoutes NamesEnv {neStore} = \case
+namesRoutes NamesEnv {neStore, neRecords} = \case
+  ["api", "name", "records"] -> Just Route {rMethod = "POST", rLimit = recordsLimit, rHandler = recordsHandler neRecords}
   ["api", "code", "check"] -> Just Route {rMethod = "POST", rLimit = codeLimit, rHandler = codeCheckHandler neStore}
   _ -> Nothing
 

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

@@ -0,0 +1,69 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module StoreService.Web.Names.Records (EditInvalid (..), recordsHandler, editRequest) where
+
+import Control.Monad (unless)
+import Data.Aeson ((.:), (.:?), (.=))
+import qualified Data.Aeson as J
+import qualified Data.Aeson.Types as JT
+import Data.Text (Text)
+import Data.Text.Encoding (decodeLatin1)
+import Network.HTTP.Types (status200, status400, status409, status504)
+import Network.Wai (Request, Response, ResponseReceived)
+import Simplex.Messaging.SimplexName (LabelHash (..))
+import StoreService.Names.Abi (bytes32FromHex, hex)
+import StoreService.Names.Chain (TxHash (..))
+import StoreService.Names.Links (LinkKind (..), linkKindOf)
+import StoreService.Names.Records (EditAnswer (..), EditRequest (..), Records, relayEdit)
+import StoreService.Names.Registration (channelRecordKey, contactRecordKey)
+import StoreService.Names.Signatures (parseSignature)
+import StoreService.Names.Store (RecordChange (..))
+import StoreService.Web.Http (Respond, badRequest, jsonError, jsonResponse, maxBodyBytes, providerUnavailable, rateLimited, readBoundedBody)
+
+data EditInvalid = EIBadRequest | EIInvalidLink
+  deriving (Eq, Show)
+
+recordsHandler :: Records -> Request -> Respond -> IO ResponseReceived
+recordsHandler rs req respond =
+  readBoundedBody maxBodyBytes req >>= \case
+    Just body | Just o <- J.decode body -> case editRequest o of
+      Right edit -> relayEdit rs edit >>= respond . editResponse
+      Left EIInvalidLink -> respond invalidLink
+      Left EIBadRequest -> respond badRequest
+    _ -> respond badRequest
+
+-- | The formats and the key, then the link, then the signature's format and low s, as the page's checks run.
+editRequest :: J.Object -> Either EditInvalid EditRequest
+editRequest o = do
+  (labelHash, change, erNonce, erDeadline, signature) <- maybe (Left EIBadRequest) Right $ JT.parseMaybe fields o
+  erLabelHash <- maybe (Left EIBadRequest) (Right . LabelHash) $ bytes32FromHex labelHash
+  erChange <- case change of
+    Nothing -> Right RCClear
+    Just (key, value) -> do
+      kind <- maybe (Left EIBadRequest) Right $ lookup key recordKinds
+      unless (value == "" || linkKindOf value == Just kind) $ Left EIInvalidLink
+      Right $ RCSetText key value
+  erSignature <- either (const $ Left EIBadRequest) Right $ parseSignature signature
+  pure EditRequest {erLabelHash, erChange, erNonce, erDeadline, erSignature}
+  where
+    fields v = do
+      clear <- v .:? "clear"
+      change <- if clear == Just True then pure Nothing else Just <$> ((,) <$> v .: "key" <*> v .: "value")
+      (,,,,) <$> v .: "labelHash" <*> pure change <*> v .: "nonce" <*> v .: "deadline" <*> v .: "signature"
+
+recordKinds :: [(Text, LinkKind)]
+recordKinds = [(decodeLatin1 contactRecordKey, LKContact), (decodeLatin1 channelRecordKey, LKChannel)]
+
+editResponse :: EditAnswer -> Response
+editResponse = \case
+  EAApplied tx -> jsonResponse status200 $ J.object ["tx" .= ((\(TxHash h) -> hex h) <$> tx)]
+  EAReverted revert -> jsonResponse status409 $ J.object ["error" .= ("record_reverted" :: Text), "revert" .= revert]
+  EAPending -> jsonError status504 "edit_pending"
+  EARefused -> badRequest
+  EAUnavailable -> providerUnavailable
+  EACapped seconds -> rateLimited seconds
+
+invalidLink :: Response
+invalidLink = jsonError status400 "invalid_link"

simplex-chat.cabal

@@ -451,6 +451,7 @@ executable simplex-store-service
       StoreService.Names.Links
       StoreService.Names.Phases
       StoreService.Names.Profiles
+      StoreService.Names.Records
       StoreService.Names.Registration
       StoreService.Names.Revert
       StoreService.Names.Sender
@@ -471,6 +472,7 @@ executable simplex-store-service
       StoreService.Web.Http
       StoreService.Web.Names
       StoreService.Web.Names.Codes
+      StoreService.Web.Names.Records
       StoreService.Web.Server
       Paths_simplex_chat
   ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -Werror=name-shadowing -threaded -rtsopts
@@ -763,6 +765,7 @@ test-suite simplex-chat-test
       Bots.StoreService.NamesLabelTests
       Bots.StoreService.NamesLinksTests
       Bots.StoreService.NamesProfilesTests
+      Bots.StoreService.NamesRecordsTests
       Bots.StoreService.NamesSenderTests
       Bots.StoreService.NamesSignatureTests
       Bots.StoreService.NamesStoreTests
@@ -797,6 +800,7 @@ test-suite simplex-chat-test
       StoreService.Names.Links
       StoreService.Names.Phases
       StoreService.Names.Profiles
+      StoreService.Names.Records
       StoreService.Names.Registration
       StoreService.Names.Revert
       StoreService.Names.Sender
@@ -817,6 +821,7 @@ test-suite simplex-chat-test
       StoreService.Web.Http
       StoreService.Web.Names
       StoreService.Web.Names.Codes
+      StoreService.Web.Names.Records
       StoreService.Web.Server
       Paths_simplex_chat
   if flag(client_postgres)

tests/Bots/StoreService/NamesRecordsTests.hs

@@ -0,0 +1,601 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Bots.StoreService.NamesRecordsTests (namesRecordsTests) where
+
+import Bots.StoreService.FakeEthNode
+import Bots.StoreService.NamesStoreTests (t0)
+import Bots.StoreService.WebTests (withServiceStore)
+import Bots.StoreService.WebUIMock (EphemeralWallet (..), newEphemeralWallet, walletFromCode)
+import Control.Concurrent.Async (Async, async, concurrently, wait)
+import Control.Concurrent.STM
+import Control.Monad (forM_)
+import Crypto.Number.Serialize (i2ospOf_, os2ip)
+import qualified Crypto.PubKey.ECC.Types as ECC
+import Crypto.Random (ChaChaDRG)
+import Data.Aeson ((.=))
+import qualified Data.Aeson as J
+import qualified Data.Aeson.KeyMap as KM
+import Data.ByteArray.Encoding (Base (Base16), convertFromBase)
+import Data.ByteString (ByteString)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime)
+import Data.Word (Word64)
+import Network.HTTP.Client (RequestBody (..), defaultManagerSettings, httpLbs, method, newManager, parseRequest, requestBody, requestHeaders, responseBody, responseStatus)
+import Network.HTTP.Types (hContentType, statusCode)
+import qualified Network.Wai.Handler.Warp as Warp
+import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
+import qualified Simplex.Messaging.Agent.Store.DB as DB
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Secp256k1 (RecoverableSignature (..), signRecoverable)
+import Simplex.Messaging.Encoding.String (strDecode)
+import Simplex.Messaging.Eth.Address (Address, recoverAddress)
+import Simplex.Messaging.Eth.EIP712 (Eip712Domain, serializeSignature)
+import Simplex.Messaging.SimplexName (LabelHash (..), SimplexTLD (..), labelHash)
+import StoreService.Config (ChainConfig (..))
+import StoreService.Names.Abi
+import StoreService.Names.Chain
+import StoreService.Names.Contracts (newContracts)
+import StoreService.Names.Records
+import StoreService.Names.Registration (Node, clearRecordsDigest, clearRecordsWithSigCalldata, labelNode, nodeBytes, resolverDomain, setTextDigest, setTextWithSigCalldata)
+import StoreService.Names.Sender (Sender, followTransactions, newSender)
+import StoreService.Names.Signatures (parseSignature)
+import StoreService.Names.Store (EditState (..), NewRecordEdit (..), RecordChange (..), RecordEdit (..), getRecordEditByBody, insertRecordEdit)
+import StoreService.Names.Turns (newTurns)
+import StoreService.Web.Names.Records (EditInvalid (..), editRequest, recordsHandler)
+import System.Timeout (timeout)
+import Test.Hspec
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple (Only (..))
+#else
+import Database.SQLite.Simple (Only (..))
+#endif
+
+namesRecordsTests :: Spec
+namesRecordsTests = describe "StoreService names: records" $ do
+  -- the signatures and calldata marked viem are viem 2.57.5's, by the wallet of "abandon ... about" (account 0),
+  -- with the SimplexResolver ABI of ens-contracts PR #36 at 23892cc
+  g <- runIO C.newRandom
+  describe "requests" $ do
+    it "signs and encodes SetText and ClearRecords edits as viem does" $ testViemVectors g
+    it "reads a request's formats, then its link, then its signature" testRequestOrder
+    it "bounds a link at 4096 bytes and takes only a link of the key's kind" testLinkBound
+    it "refuses a high s, though recovery accepts it" testHighS
+  describe "relay" $ do
+    it "relays an edit with viem's calldata and answers its hash once mined" $ testRelayMined g
+    it "refuses a wrong signer or a passed deadline before any row or gas" $ testRefusedBeforeRow g
+    it "leaves the owner's cap untouched by ten edits a non-owner signs" $ testNonOwnerCap g
+    it "checks a refused edit's repeat anew" $ testRefusedRepeat g
+    it "refuses the eleventh relayed edit of a name within an hour, with the real wait" $ testCap g
+    it "answers provider_unavailable and stores nothing when the chain fails before the send" $ testUnavailableBeforeSend g
+    it "lets a concurrent twin lose the unique insert before any signing, and answers both" $ testConcurrentTwin g
+    it "answers edit_pending after the wait, and its repeat with the hash once mined" $ testPendingThenMined g
+    it "answers edit_pending at once when the chain stops answering after the send" $ testChainStopsAfterSend g
+  describe "outcomes" $ do
+    it "answers an InvalidNonce revert of an edit another relayer applied as mined with no hash, and its repeat too" $ testAppliedByAnother g
+    it "answers a SignatureExpired revert of an edit another relayer applied as mined with no hash" $ testExpiredAppliedByAnother g
+    it "answers record_reverted InvalidNonce when another body used the nonce with another value" $ testNonceTakenByAnother g
+    it "frees a reverted edit's nonce for a new body, and answers the reverted edit's repeat while the new one is pending" $ testRevertFreesNonce g
+    it "keeps an edit pending when the re-read after a dry run's revert fails, and settles it in a later round" $ testFailedReRead g
+  describe "restarts" $ do
+    it "sends a saved edit that was never sent, and follows a sent one to its receipt" $ testResume g
+    it "answers an identical repeat after a restart from the stored edit, with no chain read" $ testRepeatAfterRestart g
+    it "finds an edit that expired across a restart applied, and makes it mined" $ testRestartExpiredApplied g
+    it "frees an edit past its deadline while its transaction is still rebroadcast" $ testExpiryFreesNonce g
+  describe "http" $
+    it "answers the contract's statuses and bodies" $ testHttp g
+
+data Setup = Setup
+  { node :: FakeEthNode,
+    store :: DBStore,
+    clock :: TVar UTCTime,
+    chain :: ChainClient,
+    random :: TVar ChaChaDRG,
+    sender :: Sender,
+    records :: Records,
+    owner :: EphemeralWallet
+  }
+
+-- | A registered alicebakery on the default resolver, held by the viem wallet, its nonce 0 and no records; two confirmations.
+withSetup :: TVar ChaChaDRG -> (Setup -> IO a) -> IO a
+withSetup random action = withFakeEthNode $ \node -> withServiceStore $ \store -> do
+  clock <- newTVarIO t0
+  chain <- newChainClient random (fakeChainConfig node) {cConfirmations = 2}
+  owner <- walletFromCode random viemCode
+  (sender, records) <- start store clock chain random
+  let s = Setup {node, store, clock, chain, random, sender, records, owner}
+  answerName s
+  action s
+
+start :: DBStore -> TVar UTCTime -> ChainClient -> TVar ChaChaDRG -> IO (Sender, Records)
+start store clock chain random = do
+  sender <- newSender random chain store (readTVarIO clock)
+  contracts <- newContracts TLDSimplex chain
+  turns <- newTurns
+  rs <- newRecords store turns contracts chain sender TLDSimplex (readTVarIO clock)
+  pure (sender, rs {rsPendingAfter = longWait})
+
+-- | A new sender and lane over the same store and node, as after the service restarts.
+restart :: Setup -> IO Setup
+restart s@Setup {store, clock, chain, random} = do
+  (sender, records) <- start store clock chain random
+  pure s {sender, records}
+
+answerName :: Setup -> IO ()
+answerName s@Setup {node, owner = EphemeralWallet {ewAddress}} = do
+  answerCall node fakeBaseRegistrar (selector "ens()") $ Returns $ addressWord registry
+  answerCall node fakeBaseRegistrar (selector "GRACE_PERIOD()") $ Returns $ uint256 gracePeriod
+  answerCall node fakeBaseRegistrar (selector "nameExpires(uint256)" <> unLabel alice) $ Returns $ uint256 nameExpiry
+  answerCall node registry (selector "owner(bytes32)" <> nodeBytes aliceNode) $ Returns $ addressWord ewAddress
+  answerCall node registry (selector "resolver(bytes32)" <> nodeBytes aliceNode) $ Returns $ addressWord fakeResolver
+  setNonce s 0
+  setRecord s contactKey ""
+  setRecord s channelKey ""
+
+setNonce :: Setup -> Word64 -> IO ()
+setNonce Setup {node, owner = EphemeralWallet {ewAddress}} n =
+  answerCall node fakeResolver (selector "nonces(address)" <> addressWord ewAddress) $ Returns $ uint256 n
+
+setRecord :: Setup -> Text -> Text -> IO ()
+setRecord Setup {node} key value =
+  answerCall node fakeResolver (selector "text(bytes32,string)" <> abiTuple [Static $ nodeBytes aliceNode, Dynamic $ abiBytes $ encodeUtf8 key]) $
+    Returns $ abiTuple [Dynamic $ abiBytes $ encodeUtf8 value]
+
+signEdit :: Setup -> EphemeralWallet -> RecordChange -> Word64 -> Word64 -> IO EditRequest
+signEdit Setup {random} EphemeralWallet {ewKey} change nonce erDeadline = do
+  sig <- signRecoverable random ewKey (digestOf change nonce erDeadline) >>= either fail pure
+  pure EditRequest {erLabelHash = alice, erChange = change, erNonce = nonce, erDeadline, erSignature = sig}
+
+channel :: Text -> RecordChange
+channel = RCSetText channelKey
+
+-- | The owner's channel edit with nonce 0 and the default deadline.
+ownerEdit :: Setup -> Text -> IO EditRequest
+ownerEdit s@Setup {owner} value = signEdit s owner (channel value) 0 deadline
+
+relay :: Setup -> EditRequest -> IO (Async EditAnswer)
+relay Setup {records} = async . relayEdit records
+
+-- | Mines the n-th transaction sent with this status, one block deeper, then runs the sender's round and the lane's.
+mineSent :: Setup -> Int -> Bool -> IO TxHash
+mineSent Setup {node, sender, records} n ok = do
+  raws <- within $ awaitSent node n
+  let h = C.keccak256 $ raws !! (n - 1)
+  _ <- mine node [(h, ok)]
+  _ <- mine node []
+  followTransactions sender
+  recordsRound records
+  pure $ TxHash h
+
+answerOf :: Async EditAnswer -> IO EditAnswer
+answerOf = within . wait
+
+within :: IO a -> IO a
+within action = timeout 5000000 action >>= maybe (fail "timed out") pure
+
+stateOf :: Setup -> EditRequest -> IO (Maybe EditState)
+stateOf Setup {store} req = withTransaction store $ \db -> fmap reState <$> getRecordEditByBody db (bodyHashOf req)
+
+editRows :: Setup -> IO Int
+editRows Setup {store} = withTransaction store $ \db -> do
+  [Only n] <- DB.query_ db "SELECT count(*) FROM sx_badge_service_name_record_edits"
+  pure n
+
+-- | As the relay keys a sent edit: the signed digest and the signature.
+bodyHashOf :: EditRequest -> ByteString
+bodyHashOf EditRequest {erChange, erNonce, erDeadline, erSignature} = C.sha256Hash $ digestOf erChange erNonce erDeadline <> serializeSignature erSignature
+
+-- | Saves an edit as a request does before it joins the sender, as if the service stopped right after.
+saveUnsent :: Setup -> EditRequest -> IO ()
+saveUnsent Setup {store, clock, owner = EphemeralWallet {ewAddress}} req@EditRequest {erChange, erNonce, erDeadline, erSignature} = do
+  now <- readTVarIO clock
+  Just _ <- withTransaction store $ \db ->
+    insertRecordEdit db NewRecordEdit {nreLabelHash = alice, nreOwner = ewAddress, nreNonce = erNonce, nreChange = erChange, nreDeadline = erDeadline, nreSignature = erSignature, nreBodyHash = bodyHashOf req} now
+  pure ()
+
+passTime :: Setup -> NominalDiffTime -> IO ()
+passTime Setup {clock} t = atomically $ modifyTVar' clock (addUTCTime t)
+
+-- requests
+
+testViemVectors :: TVar ChaChaDRG -> IO ()
+testViemVectors g = withSetup g $ \s@Setup {owner = EphemeralWallet {ewAddress}} -> do
+  ewAddress `shouldBe` viemAddress
+  EditRequest {erSignature = setSig} <- ownerEdit s viemChannelLink
+  setSig `shouldBe` viemSetSignature
+  recoverAddress setSig (digestOf (channel viemChannelLink) 0 deadline) `shouldReturn` Right viemAddress
+  setTextWithSigCalldata aliceNode channelKey viemChannelLink 0 deadline setSig `shouldBe` viemSetCall
+  EditRequest {erSignature = clearSig} <- signEdit s (owner s) RCClear 1 deadline
+  clearSig `shouldBe` viemClearSignature
+  clearRecordsWithSigCalldata aliceNode 1 deadline clearSig `shouldBe` viemClearCall
+
+testRequestOrder :: IO ()
+testRequestOrder = do
+  let valid = requestJson [("key", J.String channelKey), ("value", J.String viemChannelLink)]
+  fmap erChange (editRequest valid) `shouldBe` Right (channel viemChannelLink)
+  fmap erChange (editRequest $ requestJson [("clear", J.Bool True)]) `shouldBe` Right RCClear
+  fmap erChange (editRequest $ requestJson [("key", J.String contactKey), ("value", "")]) `shouldBe` Right (RCSetText contactKey "")
+  -- formats first: a bad label hash or key is bad_request even with a bad link
+  editRequest (KM.insert "labelHash" (J.String $ "0x" <> T.toUpper (T.drop 2 aliceHashText)) $ withLink "https://x/a") `shouldBe` Left EIBadRequest
+  editRequest (requestJson [("key", "simplex.other"), ("value", J.String viemChannelLink)]) `shouldBe` Left EIBadRequest
+  editRequest (KM.insert "nonce" (J.Number (-1)) valid) `shouldBe` Left EIBadRequest
+  editRequest (KM.insert "deadline" (J.String "1767229200") valid) `shouldBe` Left EIBadRequest
+  editRequest (KM.delete "value" valid) `shouldBe` Left EIBadRequest
+  -- the link before the signature
+  editRequest (KM.insert "signature" "0x00" $ withLink "https://x/a") `shouldBe` Left EIInvalidLink
+  editRequest (KM.insert "signature" "0x00" valid) `shouldBe` Left EIBadRequest
+  where
+    withLink link = requestJson [("key", J.String channelKey), ("value", J.String link)]
+
+testLinkBound :: IO ()
+testLinkBound = do
+  let prefix = "https://smp8.simplex.im/c#"
+      linkOf n = prefix <> T.replicate (n - T.length prefix) "a"
+      edit key value = editRequest $ requestJson [("key", J.String key), ("value", J.String value)]
+  fmap erChange (edit channelKey $ linkOf 4096) `shouldBe` Right (channel $ linkOf 4096)
+  edit channelKey (linkOf 4097) `shouldBe` Left EIInvalidLink
+  edit contactKey viemChannelLink `shouldBe` Left EIInvalidLink
+  edit channelKey "https://smp8.simplex.im/c#Y8m3;https://smp9.simplex.im/c#Z1" `shouldBe` Left EIInvalidLink
+
+testHighS :: IO ()
+testHighS = do
+  let RecoverableSignature {rsR, rsS, rsRecId} = viemSetSignature
+      highS = i2ospOf_ 32 $ curveOrder - os2ip rsS
+      flipped = RecoverableSignature {rsR, rsS = highS, rsRecId = 1 - rsRecId}
+  recoverAddress flipped (digestOf (channel viemChannelLink) 0 deadline) `shouldReturn` Right viemAddress
+  editRequest (KM.insert "signature" (J.String $ hex $ serializeSignature flipped) $ requestJson [("key", J.String channelKey), ("value", J.String viemChannelLink)])
+    `shouldBe` Left EIBadRequest
+  where
+    curveOrder = ECC.ecc_n $ ECC.common_curve $ ECC.getCurveByName ECC.SEC_p256k1
+
+-- relay
+
+testRelayMined :: TVar ChaChaDRG -> IO ()
+testRelayMined g = withSetup g $ \s@Setup {node} -> do
+  req <- ownerEdit s viemChannelLink
+  r <- relay s req
+  [raw] <- within $ awaitSent node 1
+  fmap (\TxRequest {trTo, trData} -> (trTo, trData)) (decodeSignedTx raw) `shouldBe` Right (fakeResolver, viemSetCall)
+  h <- mineSent s 1 True
+  answerOf r `shouldReturn` EAApplied (Just h)
+  stateOf s req `shouldReturn` Just (ESMined $ Just h)
+
+testRefusedBeforeRow :: TVar ChaChaDRG -> IO ()
+testRefusedBeforeRow g = withSetup g $ \s@Setup {node, records} -> do
+  other <- newEphemeralWallet g
+  (relayEdit records =<< signEdit s other (channel viemChannelLink) 0 deadline) `shouldReturn` EARefused
+  setBlock node 2 deadline
+  (relayEdit records =<< ownerEdit s viemChannelLink) `shouldReturn` EARefused
+  editRows s `shouldReturn` 0
+  sentTransactions node `shouldReturn` []
+
+testNonOwnerCap :: TVar ChaChaDRG -> IO ()
+testNonOwnerCap g = withSetup g $ \s@Setup {node, records} -> do
+  other <- newEphemeralWallet g
+  forM_ [0 .. 9] $ \n -> (relayEdit records =<< signEdit s other (channel viemChannelLink) n deadline) `shouldReturn` EARefused
+  editRows s `shouldReturn` 0
+  r <- relay s =<< ownerEdit s viemChannelLink
+  _ <- within $ awaitSent node 1
+  h <- mineSent s 1 True
+  answerOf r `shouldReturn` EAApplied (Just h)
+
+testRefusedRepeat :: TVar ChaChaDRG -> IO ()
+testRefusedRepeat g = withSetup g $ \s@Setup {owner} -> do
+  req <- signEdit s owner (channel viemChannelLink) 1 deadline
+  relayEdit (records s) req `shouldReturn` EARefused
+  stateOf s req `shouldReturn` Nothing
+  setNonce s 1
+  r <- relay s req
+  h <- mineSent s 1 True
+  answerOf r `shouldReturn` EAApplied (Just h)
+
+testCap :: TVar ChaChaDRG -> IO ()
+testCap g = withSetup g $ \s@Setup {owner} -> do
+  let quick = s {records = (records s) {rsPendingAfter = shortWait}}
+  forM_ [0 .. 9] $ \n -> do
+    setNonce s n
+    (relayEdit (records quick) =<< signEdit s owner (channel viemChannelLink) n deadline) `shouldReturn` EAPending
+  setNonce s 10
+  eleventh <- signEdit s owner (channel viemChannelLink) 10 deadline
+  passTime s 1000
+  relayEdit (records s) eleventh `shouldReturn` EACapped 2600
+  editRows s `shouldReturn` 10
+  passTime s 2601
+  relayEdit (records quick) eleventh `shouldReturn` EAPending
+  editRows s `shouldReturn` 11
+
+testUnavailableBeforeSend :: TVar ChaChaDRG -> IO ()
+testUnavailableBeforeSend g = withSetup g $ \s@Setup {node, records} -> do
+  req <- ownerEdit s viemChannelLink
+  setFault node "eth_call" HttpFailure
+  relayEdit records req `shouldReturn` EAUnavailable
+  clearFault node "eth_call"
+  setFault node "eth_maxPriorityFeePerGas" HttpFailure
+  relayEdit records req `shouldReturn` EAUnavailable
+  editRows s `shouldReturn` 0
+  sentTransactions node `shouldReturn` []
+  clearFault node "eth_maxPriorityFeePerGas"
+  r <- relay s req
+  h <- mineSent s 1 True
+  answerOf r `shouldReturn` EAApplied (Just h)
+
+testConcurrentTwin :: TVar ChaChaDRG -> IO ()
+testConcurrentTwin g = withSetup g $ \s@Setup {node, records} -> do
+  req <- ownerEdit s viemChannelLink
+  -- both pass the repeat lookup before either inserts
+  setFault node "eth_getBlockByNumber" $ Slow 300000
+  answers <- async $ concurrently (relayEdit records req) (relayEdit records req)
+  _ <- within $ awaitSent node 1
+  clearFault node "eth_getBlockByNumber"
+  h <- mineSent s 1 True
+  within (wait answers) `shouldReturn` (EAApplied (Just h), EAApplied (Just h))
+  length <$> sentTransactions node `shouldReturn` 1
+  editRows s `shouldReturn` 1
+
+testPendingThenMined :: TVar ChaChaDRG -> IO ()
+testPendingThenMined g = withSetup g $ \s@Setup {records} -> do
+  req <- ownerEdit s viemChannelLink
+  relayEdit records {rsPendingAfter = shortWait} req `shouldReturn` EAPending
+  h <- mineSent s 1 True
+  relayEdit records req `shouldReturn` EAApplied (Just h)
+
+testChainStopsAfterSend :: TVar ChaChaDRG -> IO ()
+testChainStopsAfterSend g = withSetup g $ \s@Setup {node, records} -> do
+  req <- ownerEdit s viemChannelLink
+  r <- relay s req
+  _ <- within $ awaitSent node 1
+  setFault node "eth_getBlockByNumber" HttpFailure
+  recordsRound records
+  answerOf r `shouldReturn` EAPending
+  relayEdit records req `shouldReturn` EAPending
+  clearFault node "eth_getBlockByNumber"
+  h <- mineSent s 1 True
+  relayEdit records req `shouldReturn` EAApplied (Just h)
+
+-- outcomes
+
+testAppliedByAnother :: TVar ChaChaDRG -> IO ()
+testAppliedByAnother g = withSetup g $ \s@Setup {node} -> do
+  req <- ownerEdit s viemChannelLink
+  saveUnsent s req
+  -- another relayer applied it while the service was down
+  setNonce s 1
+  setRecord s channelKey viemChannelLink
+  revertDryRun node viemSetCall $ Just $ selector "InvalidNonce()"
+  s' <- restart s
+  recordsRound (records s')
+  stateOf s req `shouldReturn` Just (ESMined Nothing)
+  sentTransactions node `shouldReturn` []
+  relayEdit (records s') req `shouldReturn` EAApplied Nothing
+
+testExpiredAppliedByAnother :: TVar ChaChaDRG -> IO ()
+testExpiredAppliedByAnother g = withSetup g $ \s@Setup {node} -> do
+  req <- ownerEdit s viemChannelLink
+  r <- relay s req
+  _ <- within $ awaitSent node 1
+  setBlock node 300 deadline
+  setNonce s 1
+  setRecord s channelKey viemChannelLink
+  -- mined in the block after the deadline, so it reverted SignatureExpired
+  _ <- mineSent s 1 False
+  answerOf r `shouldReturn` EAApplied Nothing
+  stateOf s req `shouldReturn` Just (ESMined Nothing)
+
+testNonceTakenByAnother :: TVar ChaChaDRG -> IO ()
+testNonceTakenByAnother g = withSetup g $ \s@Setup {node} -> do
+  req <- ownerEdit s viemChannelLink
+  r <- relay s req
+  _ <- within $ awaitSent node 1
+  setNonce s 1
+  setRecord s channelKey "https://smp9.simplex.im/c#other"
+  _ <- mineSent s 1 False
+  answerOf r `shouldReturn` EAReverted (Just "InvalidNonce")
+  stateOf s req `shouldReturn` Just (ESReverted $ Just "InvalidNonce")
+
+testRevertFreesNonce :: TVar ChaChaDRG -> IO ()
+testRevertFreesNonce g = withSetup g $ \s@Setup {node, records} -> do
+  first <- ownerEdit s viemChannelLink
+  r <- relay s first
+  -- reverted before the deadline with the nonce unused, so the revert has no name
+  _ <- mineSent s 1 False
+  answerOf r `shouldReturn` EAReverted Nothing
+  second <- ownerEdit s "https://smp9.simplex.im/c#second"
+  r' <- relay s second
+  _ <- within $ awaitSent node 2
+  relayEdit records first `shouldReturn` EAReverted Nothing
+  stateOf s second `shouldReturn` Just ESPending
+  h <- mineSent s 2 True
+  answerOf r' `shouldReturn` EAApplied (Just h)
+
+testFailedReRead :: TVar ChaChaDRG -> IO ()
+testFailedReRead g = withSetup g $ \s@Setup {node} -> do
+  req <- ownerEdit s viemChannelLink
+  saveUnsent s req
+  revertDryRun node viemSetCall $ Just $ selector "InvalidSignature()"
+  s' <- restart s
+  setFault node "eth_call" HttpFailure
+  recordsRound (records s')
+  stateOf s req `shouldReturn` Just ESPending
+  relayEdit (records s') req `shouldReturn` EAPending
+  clearFault node "eth_call"
+  recordsRound (records s')
+  stateOf s req `shouldReturn` Just (ESReverted $ Just "InvalidSignature")
+  relayEdit (records s') req `shouldReturn` EAReverted (Just "InvalidSignature")
+  sentTransactions node `shouldReturn` []
+
+-- restarts
+
+testResume :: TVar ChaChaDRG -> IO ()
+testResume g = withSetup g $ \s@Setup {node, owner} -> do
+  unsent <- ownerEdit s viemChannelLink
+  saveUnsent s unsent
+  s' <- restart s
+  recordsRound (records s')
+  h <- mineSent s' 1 True
+  stateOf s unsent `shouldReturn` Just (ESMined $ Just h)
+  -- a sent edit whose transaction the node forgot while the service was down
+  setNonce s 1
+  sent <- signEdit s owner (channel "https://smp9.simplex.im/c#next") 1 deadline
+  _ <- relayEdit (records s') {rsPendingAfter = shortWait} sent
+  [_, raw] <- within $ awaitSent node 2
+  dropTransaction node $ C.keccak256 raw
+  s'' <- restart s'
+  followTransactions (sender s'')
+  (!! 2) <$> sentTransactions node `shouldReturn` raw
+  h' <- mineSent s'' 3 True
+  stateOf s sent `shouldReturn` Just (ESMined $ Just h')
+  TxHash (C.keccak256 raw) `shouldBe` h'
+
+testRepeatAfterRestart :: TVar ChaChaDRG -> IO ()
+testRepeatAfterRestart g = withSetup g $ \s@Setup {node} -> do
+  req <- ownerEdit s viemChannelLink
+  r <- relay s req
+  h <- mineSent s 1 True
+  answerOf r `shouldReturn` EAApplied (Just h)
+  s' <- restart s
+  setFault node "eth_call" HttpFailure
+  setFault node "eth_getBlockByNumber" HttpFailure
+  relayEdit (records s') req `shouldReturn` EAApplied (Just h)
+  length <$> sentTransactions node `shouldReturn` 1
+
+testRestartExpiredApplied :: TVar ChaChaDRG -> IO ()
+testRestartExpiredApplied g = withSetup g $ \s@Setup {node} -> do
+  req <- ownerEdit s viemChannelLink
+  saveUnsent s req
+  setBlock node 300 $ deadline + 1
+  setNonce s 1
+  setRecord s channelKey viemChannelLink
+  s' <- restart s
+  recordsRound (records s')
+  stateOf s req `shouldReturn` Just (ESMined Nothing)
+  sentTransactions node `shouldReturn` []
+
+testExpiryFreesNonce :: TVar ChaChaDRG -> IO ()
+testExpiryFreesNonce g = withSetup g $ \s@Setup {node, records, sender} -> do
+  req <- ownerEdit s viemChannelLink
+  relayEdit records {rsPendingAfter = shortWait} req `shouldReturn` EAPending
+  [raw] <- within $ awaitSent node 1
+  -- the latest block is past the deadline, but not yet the block two confirmations deep
+  setBlock node 300 deadline
+  setBlock node 301 $ deadline + 1
+  recordsRound records
+  stateOf s req `shouldReturn` Just ESPending
+  setBlock node 302 $ deadline + 2
+  recordsRound records
+  stateOf s req `shouldReturn` Just (ESReverted $ Just "SignatureExpired")
+  relayEdit records req `shouldReturn` EAReverted (Just "SignatureExpired")
+  dropTransaction node $ C.keccak256 raw
+  followTransactions sender
+  sentTransactions node `shouldReturn` [raw, raw]
+
+-- http
+
+testHttp :: TVar ChaChaDRG -> IO ()
+testHttp g = withSetup g $ \s@Setup {records} -> Warp.testWithApplication (pure $ recordsHandler records) $ \port -> do
+  manager <- newManager defaultManagerSettings
+  let post body = do
+        req <- parseRequest $ "http://127.0.0.1:" <> show port <> "/api/name/records"
+        resp <- httpLbs req {method = "POST", requestHeaders = [(hContentType, "application/json")], requestBody = RequestBodyLBS body} manager
+        pure (statusCode $ responseStatus resp, J.decode $ responseBody resp :: Maybe J.Value)
+      editBody value = J.encode $ KM.insert "value" (J.String value) $ requestJson [("key", J.String channelKey)]
+  post "[]" `shouldReturn` (400, Just $ J.object ["error" .= ("bad_request" :: Text)])
+  post (editBody "https://x/a") `shouldReturn` (400, Just $ J.object ["error" .= ("invalid_link" :: Text)])
+  answer <- async $ post $ editBody viemChannelLink
+  TxHash h <- mineSent s 1 True
+  within (wait answer) `shouldReturn` (200, Just $ J.object ["tx" .= hex h])
+  setNonce s 1
+  next <- async . post . J.encode . editJson =<< signEdit s (owner s) (channel "https://smp9.simplex.im/c#next") 1 deadline
+  _ <- mineSent s 2 False
+  within (wait next) `shouldReturn` (409, Just $ J.object ["error" .= ("record_reverted" :: Text), "revert" .= J.Null])
+
+-- fixtures
+
+editJson :: EditRequest -> J.Object
+editJson EditRequest {erChange, erNonce, erDeadline, erSignature} =
+  KM.fromList $
+    [ ("labelHash", J.String aliceHashText),
+      ("nonce", J.toJSON erNonce),
+      ("deadline", J.toJSON erDeadline),
+      ("signature", J.String $ hex $ serializeSignature erSignature)
+    ]
+      <> case erChange of
+        RCSetText key value -> [("key", J.String key), ("value", J.String value)]
+        RCClear -> [("clear", J.Bool True)]
+
+longWait, shortWait :: Int
+longWait = 4000000
+shortWait = 200000
+
+-- | The fields of viem's SetText edit but its key and value, with these added or replaced.
+requestJson :: [(J.Key, J.Value)] -> J.Object
+requestJson extra = KM.union (KM.fromList extra) $ KM.delete "key" $ KM.delete "value" $ editJson viemEdit
+
+viemEdit :: EditRequest
+viemEdit = EditRequest {erLabelHash = alice, erChange = channel viemChannelLink, erNonce = 0, erDeadline = deadline, erSignature = viemSetSignature}
+
+digestOf :: RecordChange -> Word64 -> Word64 -> ByteString
+digestOf change nonce dl = case change of
+  RCSetText key value -> setTextDigest resolverDomain' aliceNode key value nonce dl
+  RCClear -> clearRecordsDigest resolverDomain' aliceNode nonce dl
+
+resolverDomain' :: Eip712Domain
+resolverDomain' = resolverDomain fakeChainId fakeResolver
+
+alice :: LabelHash
+alice = labelHash "alicebakery"
+
+aliceNode :: Node
+aliceNode = labelNode TLDSimplex alice
+
+aliceHashText :: Text
+aliceHashText = hex $ unLabel alice
+
+unLabel :: LabelHash -> ByteString
+unLabel (LabelHash h) = h
+
+contactKey, channelKey :: Text
+contactKey = "simplex.contact"
+channelKey = "simplex.channel"
+
+-- | An hour after the fake node's first block.
+deadline :: Word64
+deadline = 1767229200
+
+nameExpiry, gracePeriod :: Word64
+nameExpiry = 1861833600
+gracePeriod = 7776000
+
+registry :: Address
+registry = address "0x5fbdb2315678afecb367f032d93f642f64180aa3"
+
+-- | The name code of BIP-39 entropy zero, the wallet of "abandon ... about".
+viemCode :: Text
+viemCode = "SN-00000-00000-00000-00000-00000-0VME2"
+
+viemAddress :: Address
+viemAddress = address "0x9858effd232b4033e47d90003d41ec34ecaeda94"
+
+viemChannelLink :: Text
+viemChannelLink = "https://smp8.simplex.im/c#Y8m3"
+
+-- | viem: SetText(alicebakery.simplex, simplex.channel, viemChannelLink, 0, deadline)
+viemSetSignature :: RecoverableSignature
+viemSetSignature = either (error . show) id $ parseSignature "0xfce4c6865591609c07ef3d94f376187d8a20cd9d94b4affcb60b55e999038fbd4e45c42b5fafe66a8d4f756e99398602eacef777b4dce4afd0a767cddadf3ca91c"
+
+-- | viem: ClearRecords(alicebakery.simplex, 1, deadline)
+viemClearSignature :: RecoverableSignature
+viemClearSignature = either (error . show) id $ parseSignature "0x0565f7e5a591c200fcc358c1d9e9293721d0b99f0285b589211203e311e8e6167ee822d664048870bdd8552263d25bbf45e7f4985fd3b8c3a19cfced44ef9d561c"
+
+viemSetCall, viemClearCall :: ByteString
+viemSetCall = unhex "71a218a70f4104919a21c22f566d9c7947c7c7d8addbf546c973851a7e449276ea54ec1a00000000000000000000000000000000000000000000000000000000000000c000000000000000000000000000000000000000000000000000000000000001000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000006955c7100000000000000000000000000000000000000000000000000000000000000140000000000000000000000000000000000000000000000000000000000000000f73696d706c65782e6368616e6e656c0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001e68747470733a2f2f736d70382e73696d706c65782e696d2f632359386d3300000000000000000000000000000000000000000000000000000000000000000041fce4c6865591609c07ef3d94f376187d8a20cd9d94b4affcb60b55e999038fbd4e45c42b5fafe66a8d4f756e99398602eacef777b4dce4afd0a767cddadf3ca91c00000000000000000000000000000000000000000000000000000000000000"
+viemClearCall = unhex "6463e6140f4104919a21c22f566d9c7947c7c7d8addbf546c973851a7e449276ea54ec1a0000000000000000000000000000000000000000000000000000000000000001000000000000000000000000000000000000000000000000000000006955c710000000000000000000000000000000000000000000000000000000000000008000000000000000000000000000000000000000000000000000000000000000410565f7e5a591c200fcc358c1d9e9293721d0b99f0285b589211203e311e8e6167ee822d664048870bdd8552263d25bbf45e7f4985fd3b8c3a19cfced44ef9d561c00000000000000000000000000000000000000000000000000000000000000"
+
+unhex :: ByteString -> ByteString
+unhex = either error id . convertFromBase Base16
+
+address :: ByteString -> Address
+address = either error id . strDecode

tests/Test.hs

@@ -16,6 +16,7 @@ import Bots.StoreService.NamesContractsTests
 import Bots.StoreService.NamesLabelTests
 import Bots.StoreService.NamesLinksTests
 import Bots.StoreService.NamesProfilesTests
+import Bots.StoreService.NamesRecordsTests
 import Bots.StoreService.NamesSenderTests
 import Bots.StoreService.NamesSignatureTests
 import Bots.StoreService.NamesStoreTests
@@ -103,6 +104,7 @@ main = do
       namesLabelTests
       namesLinksTests
       namesProfilesTests
+      namesRecordsTests
       namesSenderTests
       namesSignatureTests
       namesStoreTests