From 119e1dc74d989bc018d835be166c5c58cb4d90f1 Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 00:35:40 +0000 Subject: [PATCH] store: bound a name's reads by one deadline --- .../src/StoreService/Names/Contracts.hs | 50 +++++++++++++------ simplex-chat.cabal | 1 + .../Bots/StoreService/NamesContractsTests.hs | 30 +++++++++++ 3 files changed, 66 insertions(+), 15 deletions(-) diff --git a/apps/simplex-store-service/src/StoreService/Names/Contracts.hs b/apps/simplex-store-service/src/StoreService/Names/Contracts.hs index 38c9733855..0102b8c8a0 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Contracts.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Contracts.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} module StoreService.Names.Contracts - ( Contracts, + ( Contracts (ctDeadline), NameStatus (..), RegisteredName (..), NameRecords (..), @@ -24,12 +24,15 @@ module StoreService.Names.Contracts ) where +import Control.Concurrent.Async (Concurrently (..)) import Control.Monad.Except (ExceptT (..), runExceptT) import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Data.IORef (IORef, atomicWriteIORef, newIORef, readIORef) +import Data.Functor.Compose (Compose (..)) import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Word (Word64) @@ -42,12 +45,15 @@ import StoreService.Names.Abi import StoreService.Names.Chain (Block (..), ChainClient (..), ChainError (..), ethCall, latestBlock) import StoreService.Names.Registration (channelRecordKey, contactRecordKey, labelNode, nodeBytes) import StoreService.Names.Revert (RevertName (..)) +import System.Timeout (timeout) data Contracts = Contracts { ctChain :: ChainClient, ctTLD :: SimplexTLD, ctRegistrar :: IORef (Maybe RegistrarConstants), - ctCommitmentAges :: IORef (Maybe CommitmentAges) + ctCommitmentAges :: IORef (Maybe CommitmentAges), + -- | microseconds for all the reads of one name status or of one name's records + ctDeadline :: Int } data RegistrarConstants = RegistrarConstants {rcRegistry :: Address, rcGracePeriod :: Integer} @@ -76,24 +82,27 @@ secondsPerYear = 31536000 attoUsdPerCent :: Integer attoUsdPerCent = 10 ^ (16 :: Int) +-- | One call's timeout, so a node that hangs fails a status or a records read once, not once per read. +nameReadsDeadline :: Int +nameReadsDeadline = 10000000 + -- | Reads nothing: the registrar's constants and the commitment ages are read on first use and kept once read. newContracts :: SimplexTLD -> ChainClient -> IO Contracts newContracts ctTLD ctChain = do ctRegistrar <- newIORef Nothing ctCommitmentAges <- newIORef Nothing - pure Contracts {ctChain, ctTLD, ctRegistrar, ctCommitmentAges} + pure Contracts {ctChain, ctTLD, ctRegistrar, ctCommitmentAges, ctDeadline = nameReadsDeadline} -- | Registered while @nameExpires + GRACE_PERIOD@ is not before the latest block's time. nameStatus :: Contracts -> LabelHash -> IO (Either ChainError NameStatus) -nameStatus ct lh = runExceptT $ do - RegistrarConstants {rcRegistry, rcGracePeriod} <- ExceptT $ registrarConstants ct - expires <- ExceptT $ nameExpires ct lh - Block {blockTimestamp} <- ExceptT $ latestBlock $ ctChain ct +nameStatus ct@Contracts {ctChain} lh = withinDeadline ct "name status" $ runExceptT $ do + (RegistrarConstants {rcRegistry, rcGracePeriod}, expires, Block {blockTimestamp}) <- + ExceptT $ together $ (,,) <$> concurrent (registrarConstants ct) <*> concurrent (nameExpires ct lh) <*> concurrent (latestBlock ctChain) if toInteger expires + rcGracePeriod >= toInteger blockTimestamp then do let node = nodeArg ct lh - rnOwner <- ExceptT $ call ct rcRegistry ("owner(bytes32)", node) decodeAddress - rnResolver <- ExceptT $ call ct rcRegistry ("resolver(bytes32)", node) decodeAddress + registryRead signature = concurrent $ call ct rcRegistry (signature, node) decodeAddress + (rnOwner, rnResolver) <- ExceptT $ together $ (,) <$> registryRead "owner(bytes32)" <*> registryRead "resolver(bytes32)" pure $ NSRegistered RegisteredName {rnOwner, rnResolver, rnExpiresAt = expires, rnGracePeriod = rcGracePeriod} else do reason <- ExceptT $ call ct (controller ct) ("reservedNames(bytes32)", labelHashArg lh) decodeUint256 @@ -103,13 +112,14 @@ nameStatus ct lh = runExceptT $ do nameRecords :: Contracts -> LabelHash -> RegisteredName -> IO (Either ChainError (Maybe NameRecords)) nameRecords ct lh RegisteredName {rnOwner, rnResolver} | rnResolver /= resolver ct = pure $ Right Nothing - | otherwise = runExceptT $ do - rdContact <- ExceptT $ textRecord contactRecordKey - rdChannel <- ExceptT $ textRecord channelRecordKey - rdNonce <- ExceptT $ resolverNonce ct rnOwner - pure $ Just NameRecords {rdContact, rdChannel, rdNonce} + | otherwise = + withinDeadline ct "name records" $ together $ + (\rdContact rdChannel rdNonce -> Just NameRecords {rdContact, rdChannel, rdNonce}) + <$> textRecord contactRecordKey + <*> textRecord channelRecordKey + <*> concurrent (resolverNonce ct rnOwner) where - textRecord key = call ct (resolver ct) ("text(bytes32,string)", abiTuple [Static $ nodeArg ct lh, Dynamic $ abiBytes key]) decodeString + textRecord key = concurrent $ call ct (resolver ct) ("text(bytes32,string)", abiTuple [Static $ nodeArg ct lh, Dynamic $ abiBytes key]) decodeString -- | Cents for a label of this length and these years. The oracle prices by length only, -- so a placeholder label of that length keeps the label from the RPC node. @@ -178,6 +188,16 @@ readOnce ref readChain = Just a -> pure $ Right a Nothing -> readChain >>= either (pure . Left) (\a -> Right a <$ atomicWriteIORef ref (Just a)) +-- | Reads run at once; the first failure in argument order is the answer. +together :: Compose Concurrently (Either ChainError) a -> IO (Either ChainError a) +together = runConcurrently . getCompose + +concurrent :: IO (Either ChainError a) -> Compose Concurrently (Either ChainError) a +concurrent = Compose . Concurrently + +withinDeadline :: Contracts -> Text -> IO (Either ChainError a) -> IO (Either ChainError a) +withinDeadline Contracts {ctDeadline} what action = fromMaybe (Left $ ChainUnavailable $ what <> ": timed out") <$> timeout ctDeadline action + -- | An answer that does not decode is a node failure, as an RPC error is. call :: Contracts -> Address -> (ByteString, ByteString) -> (ByteString -> Either AbiError a) -> IO (Either ChainError a) call Contracts {ctChain} to (signature, args) decode = diff --git a/simplex-chat.cabal b/simplex-chat.cabal index ccb23e561e..60b701922a 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -473,6 +473,7 @@ executable simplex-store-service 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 build-depends: aeson ==2.2.* + , async ==2.2.* , attoparsec ==0.14.* , base >=4.7 && <5 , base64-bytestring >=1.0 && <1.3 diff --git a/tests/Bots/StoreService/NamesContractsTests.hs b/tests/Bots/StoreService/NamesContractsTests.hs index a788e87249..e167eca8b6 100644 --- a/tests/Bots/StoreService/NamesContractsTests.hs +++ b/tests/Bots/StoreService/NamesContractsTests.hs @@ -10,6 +10,7 @@ import Crypto.Random (ChaChaDRG) import Data.ByteArray.Encoding (Base (Base16), convertFromBase) import Data.ByteString (ByteString) import qualified Data.ByteString as B +import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime) import Data.Word (Word64) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String (strDecode) @@ -53,6 +54,8 @@ namesContractsTests = describe "StoreService names: contracts" $ do describe "failures" $ do it "fails a status on a failed read, never reading it as available" $ testFailedRead g it "fails a read whose answer does not decode or does not fit" $ testMalformed g + it "fails a status within its deadline when one method hangs" $ testStatusDeadline g + it "fails records within their deadline when the calls hang" $ testRecordsDeadline g testNode :: IO () testNode = do @@ -232,8 +235,35 @@ testMalformed g = withContracts g $ \node ct -> do answerCall node oracle pricesCall $ Returns $ B.dropEnd 32 launchPricesAnswer codeLengthFor ct 40000 2 `shouldReturn` Left (ChainUnavailable "eth_call: prices() answered AEShort") +testStatusDeadline :: TVar ChaChaDRG -> IO () +testStatusDeadline g = withContracts g $ \node ct -> do + answerRegistrar node + answerCall node (registrarOf node) nameExpiresCall $ Returns $ uint256 (0 :: Int) + answerCall node fakeController reservedNamesCall $ Returns $ uint256 (0 :: Int) + setFault node "eth_getBlockByNumber" Hang + elapsed <- timed $ nameStatus ct {ctDeadline = testDeadline} alice `shouldReturn` Left (ChainUnavailable "name status: timed out") + elapsed `shouldSatisfy` (< 2) + clearFault node "eth_getBlockByNumber" + nameStatus ct {ctDeadline = testDeadline} alice `shouldReturn` Right NSAvailable + +testRecordsDeadline :: TVar ChaChaDRG -> IO () +testRecordsDeadline g = withContracts g $ \node ct -> do + setFault node "eth_call" Hang + elapsed <- timed $ nameRecords ct {ctDeadline = testDeadline} alice (registeredAlice (resolverOf node) $ now + year) `shouldReturn` Left (ChainUnavailable "name records: timed out") + elapsed `shouldSatisfy` (< 2) + -- fixtures +-- | Far below a call's 10-second timeout, so only the deadline can end a hung read in time. +testDeadline :: Int +testDeadline = 300000 + +timed :: IO () -> IO NominalDiffTime +timed action = do + start <- getCurrentTime + action + (`diffUTCTime` start) <$> getCurrentTime + withContracts :: TVar ChaChaDRG -> (FakeEthNode -> Contracts -> IO a) -> IO a withContracts g action = withFakeEthNode $ \node -> do ct <- newContracts TLDSimplex =<< newChainClient g (fakeChainConfig node)