diff --git a/apps/simplex-store-service/src/StoreService/Names/Chain.hs b/apps/simplex-store-service/src/StoreService/Names/Chain.hs index 2d6cbe8d39..03ac65909a 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Chain.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Chain.hs @@ -28,7 +28,7 @@ module StoreService.Names.Chain where import Control.Concurrent.STM (TVar) -import Control.Exception (try) +import Control.Exception (evaluate, try) import Control.Monad ((>=>)) import Crypto.Random (ChaChaDRG) import Data.Aeson ((.:), (.:?), (.=)) @@ -106,6 +106,14 @@ maxRpcResponseBytes = 1024 * 1024 revertCode :: Int revertCode = 3 +-- | A node's error message is cut to this many characters. +maxNodeMessageLength :: Int +maxNodeMessageLength = 200 + +-- | The hex digits of a 256-bit quantity. +maxQuantityDigits :: Int +maxQuantityDigits = 64 + newChainClient :: TVar ChaChaDRG -> ChainConfig -> IO ChainClient newChainClient g ccConfig@ChainConfig {cServiceKey} = do ccManager <- newTlsManager @@ -177,19 +185,24 @@ signTransaction g ChainClient {ccConfig = ChainConfig {cChainId, cServiceKey}} T sendRawTransaction :: ChainClient -> ByteString -> IO (Either ChainError TxHash) sendRawTransaction c raw = rpc c "eth_sendRawTransaction" [J.String $ hex raw] (fmap TxHash . bytes) +-- | The answer is parsed within the timeout, so a slow parse is bounded too. rpc :: ChainClient -> Text -> [J.Value] -> (J.Value -> JT.Parser a) -> IO (Either ChainError a) rpc ChainClient {ccManager, ccConfig = ChainConfig {cRpcUrl}, ccTimeout} method params parseResult = - timeout ccTimeout (try post) >>= \case + timeout ccTimeout (try $ post >>= evaluate . answer) >>= \case Nothing -> pure $ Left $ unavailable "timed out" Just (Left (e :: HTTP.HttpException)) -> pure $ Left $ unavailable $ httpFailure e - Just (Right (status, body)) - | LB.length body > fromIntegral maxRpcResponseBytes -> pure $ Left $ unavailable $ "response over " <> tshow maxRpcResponseBytes <> " bytes" - | otherwise -> pure $ case JT.parseEither response =<< J.eitherDecode body of - Right r -> r - Left e - | statusIsSuccessful status -> Left $ unavailable $ "not a JSON-RPC response: " <> T.pack e - | otherwise -> Left $ unavailable $ "HTTP " <> tshow (statusCode status) + Just (Right r) -> pure r where + answer (status, body) + | LB.length body > fromIntegral maxRpcResponseBytes = Left $ unavailable $ "response over " <> tshow maxRpcResponseBytes <> " bytes" + | otherwise = case J.eitherDecode body of + Left _ -> refused Nothing + Right v -> either (refused . Just) id $ JT.parseEither response v + where + refused parseError + | not (statusIsSuccessful status) = Left $ unavailable $ "HTTP " <> tshow (statusCode status) + -- aeson's decode error quotes the body, which can be any page a proxy answers with + | otherwise = Left $ unavailable $ "not a JSON-RPC response" <> maybe "" ((": " <>) . T.pack) parseError post = do req <- HTTP.parseRequest cRpcUrl HTTP.withResponse @@ -210,7 +223,7 @@ rpc ChainClient {ccManager, ccConfig = ChainConfig {cRpcUrl}, ccTimeout} method pure $ if code == revertCode || "execution reverted" `T.isPrefixOf` message then ChainReverted $ decodeRevert =<< (JT.parseMaybe bytes =<< revertData) - else unavailable $ "error " <> tshow code <> ": " <> message + else unavailable $ "error " <> tshow code <> ": " <> T.take maxNodeMessageLength message unavailable reason = ChainUnavailable $ method <> ": " <> reason -- | Only the kind of failure: an exception's text can hold the URL or its host. @@ -230,7 +243,7 @@ nullable p = \case quantity :: forall a. (Integral a, Bounded a) => J.Value -> JT.Parser a quantity = J.withText "quantity" $ \t -> case T.stripPrefix "0x" t of - Just h | [(n, "")] <- readHex (T.unpack h), n <= toInteger (maxBound :: a) -> pure $ fromInteger n + Just h | T.length h <= maxQuantityDigits, [(n, "")] <- readHex (T.unpack h), n <= toInteger (maxBound :: a) -> pure $ fromInteger n _ -> fail "not a quantity" bytes :: J.Value -> JT.Parser ByteString diff --git a/tests/Bots/StoreService/FakeEthNode.hs b/tests/Bots/StoreService/FakeEthNode.hs index aa8014b620..cef15a1e16 100644 --- a/tests/Bots/StoreService/FakeEthNode.hs +++ b/tests/Bots/StoreService/FakeEthNode.hs @@ -63,6 +63,9 @@ data Fault | -- | answers only once the node is closed Hang | HttpFailure + | -- | a 200 page that is not JSON, as a proxy may answer + NotJson + | Answers J.Value data FakeState = FakeState { fsCalls :: Map (ByteString, ByteString) CallAnswer, @@ -157,6 +160,8 @@ fakeApp st req respond = do atomically $ readTVar st >>= check . fsClosed reply $ rpcError (-32000) "node closed" Nothing Just (RpcError code message revertData) -> reply $ rpcError code message revertData + Just NotJson -> respond $ responseLBS ok200 [] "Sign in to provider-api-key" + Just (Answers v) -> reply ["result" .= v] Nothing -> reply =<< atomically (answer st method params) Nothing -> respond $ responseLBS badRequest400 [] "not a JSON-RPC request" where diff --git a/tests/Bots/StoreService/NamesChainTests.hs b/tests/Bots/StoreService/NamesChainTests.hs index 54a028e49e..02d6067eb2 100644 --- a/tests/Bots/StoreService/NamesChainTests.hs +++ b/tests/Bots/StoreService/NamesChainTests.hs @@ -7,6 +7,7 @@ module Bots.StoreService.NamesChainTests (namesChainTests) where import Bots.StoreService.FakeEthNode import Control.Concurrent.STM (TVar) import Crypto.Random (ChaChaDRG) +import qualified Data.Aeson as J import Data.ByteArray.Encoding (Base (Base16), convertFromBase) import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -36,6 +37,9 @@ namesChainTests = describe "StoreService names: chain" $ do it "reads an HTTP failure as unavailable" $ testHttpFailure g it "reads a refused connection as unavailable, without the URL" $ testRefused g it "refuses an answer over the size bound" $ testOversized g + it "reads a 2xx answer that is not JSON as unavailable, without quoting it" $ testNotJson g + it "cuts a node's long error message" $ testLongNodeMessage g + it "refuses a quantity over 256 bits, and a long one within the call's timeout" $ testLongQuantity g describe "reads" $ do it "answers eth_call from the node by contract and calldata" $ testEthCall g it "reads the latest block's number, time and base fee" $ testLatestBlock g @@ -162,6 +166,27 @@ testOversized g = withChain g $ \node c -> do answerCall node fakeController availableCall $ Returns $ B.replicate (512 * 1024) 0 ethCall c fakeController availableCall `shouldReturn` Left (ChainUnavailable "eth_call: response over 1048576 bytes") +testNotJson :: TVar ChaChaDRG -> IO () +testNotJson g = withChain g $ \node c -> do + setFault node "eth_call" NotJson + ethCall c fakeController availableCall `shouldReturn` Left (ChainUnavailable "eth_call: not a JSON-RPC response") + +testLongNodeMessage :: TVar ChaChaDRG -> IO () +testLongNodeMessage g = withChain g $ \node c -> do + setFault node "eth_call" $ RpcError (-32000) (T.replicate 1000 "x") Nothing + ethCall c fakeController availableCall `shouldReturn` Left (ChainUnavailable $ "eth_call: error -32000: " <> T.replicate 200 "x") + +testLongQuantity :: TVar ChaChaDRG -> IO () +testLongQuantity g = withChain g $ \node c -> do + let fee digits = setFault node "eth_maxPriorityFeePerGas" (Answers $ J.String $ "0x" <> digits) >> maxPriorityFee c {ccTimeout = 300000} + notQuantity = Left (ChainUnavailable "eth_maxPriorityFeePerGas: not a JSON-RPC response: Error in $: not a quantity") + fee (T.replicate 63 "0" <> "7") `shouldReturn` Right 7 + fee (T.replicate 64 "0" <> "7") `shouldReturn` notQuantity + start <- getCurrentTime + fee (T.replicate 1000000 "f") `shouldReturn` notQuantity + elapsed <- (`diffUTCTime` start) <$> getCurrentTime + elapsed `shouldSatisfy` (< 1) + testEthCall :: TVar ChaChaDRG -> IO () testEthCall g = withChain g $ \node c -> do answerCall node fakeController availableCall $ Returns $ uint256 (1 :: Int)