store: bound the node's text and quantities

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

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 [] "<html>Sign in to provider-api-key</html>"
+        Just (Answers v) -> reply ["result" .= v]
         Nothing -> reply =<< atomically (answer st method params)
     Nothing -> respond $ responseLBS badRequest400 [] "not a JSON-RPC request"
   where

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)