From 0585b4e62f77f784fce6d5063c399416fe177ec2 Mon Sep 17 00:00:00 2001 From: chessai Date: Wed, 8 Jan 2025 15:17:52 -0600 Subject: [PATCH] add a mempool insertCheck variant that doesn't short-circuit. improve error messages in /send api Change-Id: I435856410fb82c59f8170d32bf12e5cea69833d1 --- src/Chainweb/Mempool/InMem.hs | 109 +++++++++++++----- src/Chainweb/Mempool/Mempool.hs | 12 +- src/Chainweb/Mempool/RestAPI/Client.hs | 1 + .../Pact/PactService/Pact4/ExecBlock.hs | 7 +- .../Pact/PactService/Pact5/ExecBlock.hs | 12 +- src/Chainweb/Pact/RestAPI/Server.hs | 32 ++--- .../Chainweb/Test/Pact4/RemotePactTest.hs | 18 +-- .../Chainweb/Test/Pact5/RemotePactTest.hs | 76 +++++++----- 8 files changed, 172 insertions(+), 95 deletions(-) diff --git a/src/Chainweb/Mempool/InMem.hs b/src/Chainweb/Mempool/InMem.hs index 121d7a9813..2c86640c5b 100644 --- a/src/Chainweb/Mempool/InMem.hs +++ b/src/Chainweb/Mempool/InMem.hs @@ -3,10 +3,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -25,6 +27,8 @@ module Chainweb.Mempool.InMem ) where ------------------------------------------------------------------------------ + +import Data.List qualified as List import Control.Applicative ((<|>)) import Control.Concurrent.Async import Control.Concurrent.MVar @@ -119,18 +123,19 @@ toMempoolBackend toMempoolBackend logger mempool = do return $! MempoolBackend { mempoolTxConfig = tcfg - , mempoolMember = member - , mempoolLookup = lookup - , mempoolLookupEncoded = lookupEncoded - , mempoolInsert = insert - , mempoolInsertCheck = insertCheck - , mempoolMarkValidated = markValidated - , mempoolAddToBadList = addToBadList - , mempoolCheckBadList = checkBadList - , mempoolGetBlock = getBlock - , mempoolPrune = prune - , mempoolGetPendingTransactions = getPending - , mempoolClear = clear + , mempoolMember = memberInMem lockMVar + , mempoolLookup = lookupInMem tcfg lockMVar + , mempoolLookupEncoded = lookupEncodedInMem lockMVar + , mempoolInsert = insertInMem logger cfg lockMVar + , mempoolInsertCheck = insertCheckInMem cfg lockMVar + , mempoolInsertCheckVerbose = insertCheckVerboseInMem cfg lockMVar + , mempoolMarkValidated = markValidatedInMem logger tcfg lockMVar + , mempoolAddToBadList = addToBadListInMem lockMVar + , mempoolCheckBadList = checkBadListInMem lockMVar + , mempoolGetBlock = getBlockInMem logger cfg lockMVar + , mempoolPrune = pruneInMem logger lockMVar + , mempoolGetPendingTransactions = getPendingInMem cfg nonce lockMVar + , mempoolClear = clearInMem lockMVar } where cfg = _inmemCfg mempool @@ -138,26 +143,6 @@ toMempoolBackend logger mempool = do lockMVar = _inmemDataLock mempool InMemConfig tcfg _ _ _ _ _ _ = cfg - member = memberInMem lockMVar - lookup = lookupInMem tcfg lockMVar - lookupEncoded = lookupEncodedInMem lockMVar - insert = insertInMem logger cfg lockMVar - insertCheck = insertCheckInMem cfg lockMVar - markValidated = markValidatedInMem logger tcfg lockMVar - addToBadList = addToBadListInMem lockMVar - checkBadList = checkBadListInMem lockMVar - getBlock :: forall to. - (NFData t) - => BlockFill - -> MempoolPreBlockCheck t to - -> BlockHeight - -> BlockHash - -> IO (Vector to) - getBlock = getBlockInMem logger cfg lockMVar - getPending = getPendingInMem cfg nonce lockMVar - prune = pruneInMem logger lockMVar - clear = clearInMem lockMVar - ------------------------------------------------------------------------------ -- | A 'bracket' function for in-memory mempools. @@ -348,6 +333,66 @@ insertCheckInMem cfg lock txs hasher :: t -> TransactionHash hasher = txHasher (_inmemTxCfg cfg) +-- | This function is used when a transaction(s) is inserted into the mempool via +-- the service API. It is NOT used when a new block is created. +-- For the latter, more strict validation methods are used. In particular, TTL validation +-- uses the current time as reference in the former case (mempool insertion) +-- and the creation time of the parent header in the latter case (new block creation). +-- +insertCheckVerboseInMem + :: forall t + . NFData t + => InMemConfig t -- ^ in-memory config + -> MVar (InMemoryMempoolData t) -- ^ in-memory state + -> Vector t -- ^ new transactions + -> IO (Vector (T2 TransactionHash (Either InsertError t))) +insertCheckVerboseInMem cfg lock txs + | V.null txs = return V.empty + | otherwise = do + now <- getCurrentTimeIntegral + badmap <- withMVarMasked lock $ readIORef . _inmemBadMap + curTxIdx <- withMVarMasked lock $ readIORef . _inmemCurrentTxs + + let withHashesAndPositions :: (HashMap TransactionHash (Int, InsertError), HashMap TransactionHash (Int, t)) + withHashesAndPositions = + over _1 (HashMap.fromList . V.toList) + $ over _2 (HashMap.fromList . V.toList) + $ V.partitionWith (\(i, h, e) -> bimap (\err -> (h, (i, err))) (\err -> (h, (i, err))) e) + $ flip V.imap txs $ \i tx -> + let !h = hasher tx + in (i, h,) $! validateOne cfg badmap curTxIdx now tx h + + let (prevFailures, prevSuccesses) = withHashesAndPositions + + preInsertBatchChecks <- _inmemPreInsertBatchChecks cfg (V.fromList $ List.map (\(h, (_, t)) -> T2 h t) $ HashMap.toList prevSuccesses) + + let update (failures, successes) result = case result of + Left (T2 txHash insertError) -> + case HashMap.lookup txHash successes of + Just (i, _) -> + -- add to failures and remove from successes + ( HashMap.insert txHash (i, insertError) failures + , HashMap.delete txHash successes + ) + Nothing -> error "insertCheckInMem: impossible" + -- nothing to do; the successes already contains this value. + Right _ -> (failures, successes) + let (failures, successes) = V.foldl' update (prevFailures, prevSuccesses) preInsertBatchChecks + + let allEntries = + [ (i, T2 txHash (Left insertError)) + | (txHash, (i, insertError)) <- HashMap.toList failures + ] ++ + [ (i, T2 txHash (Right val)) + | (txHash, (i, val)) <- HashMap.toList successes + ] + let sortedEntries = V.fromList $ List.map snd $ List.sortBy (compare `on` fst) allEntries + + return sortedEntries + where + hasher :: t -> TransactionHash + hasher = txHasher (_inmemTxCfg cfg) + -- | Validation: Confirm the validity of some single transaction @t@. -- -- This function is only used during insert checks. TTL validation is done in diff --git a/src/Chainweb/Mempool/Mempool.hs b/src/Chainweb/Mempool/Mempool.hs index 876592281e..7ea32837eb 100644 --- a/src/Chainweb/Mempool/Mempool.hs +++ b/src/Chainweb/Mempool/Mempool.hs @@ -90,6 +90,7 @@ module Chainweb.Mempool.Mempool , pact5RequestKeyToTransactionHash ) where ------------------------------------------------------------------------------ + import Control.DeepSeq (NFData) import Control.Exception import Control.Lens hiding ((.=)) @@ -237,7 +238,7 @@ data InsertError | InsertErrorCompilationFailed Text | InsertErrorOther Text | InsertErrorInvalidHash - | InsertErrorInvalidSigs + | InsertErrorInvalidSigs Text | InsertErrorTimedOut | InsertErrorPactParseError Text | InsertErrorWrongChain Text Text @@ -257,7 +258,7 @@ instance Show InsertError where InsertErrorCompilationFailed msg -> "Transaction compilation failed: " <> T.unpack msg InsertErrorOther m -> "insert error: " <> T.unpack m InsertErrorInvalidHash -> "Invalid transaction hash" - InsertErrorInvalidSigs -> "Invalid transaction sigs" + InsertErrorInvalidSigs msg -> "Invalid transaction sigs: " <> T.unpack msg InsertErrorTimedOut -> "Transaction validation timed out" InsertErrorPactParseError msg -> "Pact parse error: " <> T.unpack msg InsertErrorWrongChain expected actual -> "Wrong chain, expected: " <> T.unpack expected <> ", actual: " <> T.unpack actual @@ -295,9 +296,12 @@ data MempoolBackend t = MempoolBackend { -> IO () -- | Perform the pre-insert check for the given transactions. Short-circuits - -- on the first Transaction that fails. + -- on the first Transaction that fails. , mempoolInsertCheck :: Vector t -> IO (Either (T2 TransactionHash InsertError) ()) + -- | Perform the pre-insert check for the given transactions. Does not short circuit. + , mempoolInsertCheckVerbose :: Vector t -> IO (Vector (T2 TransactionHash (Either InsertError t))) + -- | Remove the given hashes from the pending set. , mempoolMarkValidated :: Vector t -> IO () @@ -342,6 +346,7 @@ noopMempool = do , mempoolLookupEncoded = noopLookupEncoded , mempoolInsert = noopInsert , mempoolInsertCheck = noopInsertCheck + , mempoolInsertCheckVerbose = noopInsertCheckVerbose , mempoolMarkValidated = noopMV , mempoolAddToBadList = noopAddToBadList , mempoolCheckBadList = noopCheckBadList @@ -364,6 +369,7 @@ noopMempool = do noopLookupEncoded v = return $ V.replicate (V.length v) Missing noopInsert = const $ const $ return () noopInsertCheck _ = fail "unsupported" + noopInsertCheckVerbose _ = fail "unsupported" noopMV = const $ return () noopAddToBadList = const $ return () noopCheckBadList v = return $ V.replicate (V.length v) False diff --git a/src/Chainweb/Mempool/RestAPI/Client.hs b/src/Chainweb/Mempool/RestAPI/Client.hs index ad15d40776..0d9db652d6 100644 --- a/src/Chainweb/Mempool/RestAPI/Client.hs +++ b/src/Chainweb/Mempool/RestAPI/Client.hs @@ -59,6 +59,7 @@ toMempool version chain txcfg env = , mempoolLookupEncoded = const unsupported , mempoolInsert = insert , mempoolInsertCheck = const unsupported + , mempoolInsertCheckVerbose = const unsupported , mempoolMarkValidated = const unsupported , mempoolAddToBadList = const unsupported , mempoolCheckBadList = const unsupported diff --git a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs index 9d5dfafaf0..a72a597e5b 100644 --- a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs @@ -327,8 +327,11 @@ checkTxSigs -> f () checkTxSigs logger v cid bh t = do liftIO $ logFunctionText logger Debug $ "Pact4.checkTxSigs: " <> sshow (Pact4._cmdHash t) - if | isRight (Pact4.assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs) -> pure () - | otherwise -> throwError InsertErrorInvalidSigs + case Pact4.assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs of + Right _ -> do + pure () + Left err -> do + throwError $ InsertErrorInvalidSigs (displayAssertValidateSigsError err) where hsh = Pact4._cmdHash t sigs = Pact4._cmdSigs t diff --git a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs index 5ecc977f39..6ad3fe5d14 100644 --- a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs @@ -52,7 +52,7 @@ import Control.Monad.State.Strict import Data.ByteString (ByteString) import Data.Coerce import Data.Decimal -import Data.Either (partitionEithers, isRight) +import Data.Either (partitionEithers) import Data.Foldable import Data.Maybe import Data.Text qualified as T @@ -77,6 +77,7 @@ import qualified Chainweb.Pact5.Backend.ChainwebPactDb as Pact5 import qualified Chainweb.Pact4.Transaction as Pact4 import qualified Chainweb.Pact5.Transaction as Pact5 import qualified Chainweb.Pact5.Validations as Pact5 +import Pact.Core.Pretty qualified as Pact5 import qualified Data.ByteString.Short as SB import qualified Pact.Core.Hash as Pact5 import System.LogLevel @@ -527,8 +528,11 @@ validateParsedChainwebTx _logger v cid db _blockHandle txValidationTime bh isGen checkTxSigs :: Pact5.Transaction -> ExceptT InsertError IO () checkTxSigs t = do - if | isRight (Pact5.assertValidateSigs hsh signers sigs) -> pure () - | otherwise -> throwError InsertErrorInvalidSigs + case Pact5.assertValidateSigs hsh signers sigs of + Right _ -> do + pure () + Left err -> do + throwError $ InsertErrorInvalidSigs (displayAssertValidateSigsError err) where hsh = Pact5._cmdHash t sigs = Pact5._cmdSigs t @@ -558,7 +562,7 @@ validateRawChainwebTx -> Pact4.UnparsedTransaction -> ExceptT InsertError IO Pact5.Transaction validateRawChainwebTx logger v cid db blockHandle parentTime bh isGenesis tx = do - tx' <- either (throwError . InsertErrorPactParseError . sshow) return $ Pact5.parsePact4Command tx + tx' <- either (throwError . InsertErrorPactParseError . Pact5.renderText) return $ Pact5.parsePact4Command tx liftIO $ do logDebug_ logger $ "validateRawChainwebTx: parse succeeded" validateParsedChainwebTx logger v cid db blockHandle parentTime bh isGenesis tx' diff --git a/src/Chainweb/Pact/RestAPI/Server.hs b/src/Chainweb/Pact/RestAPI/Server.hs index 2e1ffb0eb1..28ab69c49a 100644 --- a/src/Chainweb/Pact/RestAPI/Server.hs +++ b/src/Chainweb/Pact/RestAPI/Server.hs @@ -46,6 +46,7 @@ import Control.Monad.Trans.Except (ExceptT, runExceptT, except) import Data.Aeson as Aeson import Data.Bifunctor (second) +import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSL8 import qualified Data.ByteString.Short as SB @@ -104,6 +105,7 @@ import Chainweb.Pact.RestAPI.EthSpv import Chainweb.Pact.RestAPI.SPV import Chainweb.Pact.Types import Chainweb.Pact4.SPV qualified as Pact4 +import Pact.Types.ChainMeta qualified as Pact4 import Chainweb.Payload import Chainweb.Payload.PayloadStore import Chainweb.RestAPI.Orphans () @@ -260,11 +262,13 @@ sendHandler -> Handler Pact4.RequestKeys sendHandler logger mempool (Pact4.SubmitBatch cmds) = Handler $ do liftIO $ logg Info (PactCmdLogSend cmds) - case (traverse . traverse) (\t -> (encodeUtf8 t,) <$> eitherDecodeStrictText t) cmds of + let cmdPayloads :: Either String (NonEmpty (Pact4.Command (ByteString, Pact4.Payload Pact4.PublicMeta Text))) + cmdPayloads = traverse (traverse (\t -> (encodeUtf8 t,) <$> eitherDecodeStrictText t)) cmds + case cmdPayloads of Right (fmap Pact4.mkPayloadWithText -> cmdsWithParsedPayloads) -> do let cmdsWithParsedPayloadsV = V.fromList $ NEL.toList cmdsWithParsedPayloads -- If any of the txs in the batch fail validation, we reject them all. - liftIO (mempoolInsertCheck mempool cmdsWithParsedPayloadsV) >>= checkResult + liftIO (mempoolInsertCheckVerbose mempool cmdsWithParsedPayloadsV) >>= checkResult liftIO (mempoolInsert mempool UncheckedInsert cmdsWithParsedPayloadsV) return $! Pact4.RequestKeys $ NEL.map Pact4.cmdToRequestKey cmdsWithParsedPayloads Left err -> failWith $ "reading JSON for transaction failed: " <> T.pack err @@ -276,17 +280,19 @@ sendHandler logger mempool (Pact4.SubmitBatch cmds) = Handler $ do logg = logFunctionJson (setComponent "send-handler" logger) - toPactHash :: TransactionHash -> Pact4.TypedHash h - toPactHash (TransactionHash h) = Pact4.TypedHash h - - checkResult :: Either (T2 TransactionHash InsertError) () -> ExceptT ServerError IO () - checkResult (Right _) = pure () - checkResult (Left (T2 hash insErr)) = failWith $ fold - [ "Validation failed for hash " - , sshow $ toPactHash hash - , ": " - , sshow insErr - ] + checkResult :: Vector (T2 TransactionHash (Either InsertError Pact4.UnparsedTransaction)) -> ExceptT ServerError IO () + checkResult vec + | V.null vec = return () + | otherwise = do + let errors = flip mapMaybe (L.zip [0..] (V.toList vec)) $ \(i, T2 txHash e) -> case e of + Left err -> Just $ "Transaction " <> sshow txHash <> " at index " <> sshow @Word i <> " failed with: " <> sshow err + Right _ -> Nothing + if null errors + then do + return () + else do + let err = "One or more transactions were invalid: " <> T.intercalate ", " errors + failWith err -- -------------------------------------------------------------------------- -- -- Poll Handler diff --git a/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs b/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs index 21d7cdc57d..587768a6cf 100644 --- a/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs +++ b/test/unit/Chainweb/Test/Pact4/RemotePactTest.hs @@ -208,7 +208,7 @@ invalidCommandTest rdb = runResourceT $ do net <- withNodesAtLatestBehavior v id nodeDbDirs let cenv = _getServiceClientEnv net - let sendExpect :: [Command Text] -> (Text -> Bool) -> ResourceT IO () + let sendExpect :: (HasCallStack) => [Command Text] -> (Text -> Bool) -> ResourceT IO () sendExpect txs p = do e <- liftIO $ flip runClientM cenv $ pactSendApiClient v cid $ SubmitBatch $ NEL.fromList txs @@ -227,7 +227,7 @@ invalidCommandTest rdb = runResourceT $ do iot <- liftIO $ toTxCreationTime @Integer <$> getCurrentTimeIntegral - let prefix cmd = "Validation failed for hash " <> sshow (_cmdHash cmd) <> ": " + let prefix i cmd = "One or more transactions were invalid: Transaction " <> sshow (_cmdHash cmd) <> " at index " <> sshow @Int i <> " failed with: " cmdParseFailure <- liftIO $ buildTextCmd "bare-command" v $ set cbSigners [mkEd25519Signer' sender00 []] @@ -237,7 +237,7 @@ invalidCommandTest rdb = runResourceT $ do $ set cbRPC (mkExec "(+ 1" (mkKeySetData "sender00" [sender00])) $ defaultCmd -- Why does pact just return 'mzero' here... - sendExpect [cmdParseFailure] (== (prefix cmdParseFailure <> "Pact parse error: Failed reading: mzero")) + sendExpect [cmdParseFailure] (== (prefix 0 cmdParseFailure <> "Pact parse error: Failed reading: mzero")) cmdInvalidPayloadHash <- liftIO $ do bareCmd <- buildTextCmd "bare-command" v @@ -250,7 +250,7 @@ invalidCommandTest rdb = runResourceT $ do pure $ bareCmd { _cmdHash = Pact.hash "fakehash" } - sendExpect [cmdInvalidPayloadHash] (== (prefix cmdInvalidPayloadHash <> "Invalid transaction hash")) + sendExpect [cmdInvalidPayloadHash] (== (prefix 0 cmdInvalidPayloadHash <> "Invalid transaction hash")) cmdSignersSigsLengthMismatch1 <- liftIO $ do bareCmd <- buildTextCmd "bare-command" v @@ -263,7 +263,7 @@ invalidCommandTest rdb = runResourceT $ do pure $ bareCmd { _cmdSigs = [] } - sendExpect [cmdSignersSigsLengthMismatch1] (== (prefix cmdSignersSigsLengthMismatch1 <> "Invalid transaction sigs")) + sendExpect [cmdSignersSigsLengthMismatch1] (== (prefix 0 cmdSignersSigsLengthMismatch1 <> "Invalid transaction sigs: The number of signers and signatures do not match. Number of signers: 1. Number of signatures: 0.")) cmdSignersSigsLengthMismatch2 <- liftIO $ do bareCmd <- buildTextCmd "bare-command" v @@ -277,7 +277,7 @@ invalidCommandTest rdb = runResourceT $ do { -- This is an invalid ED25519 signature, but length signers == length signatures is checked first _cmdSigs = [ED25519Sig "fakeSig"] } - sendExpect [cmdSignersSigsLengthMismatch2] (== (prefix cmdSignersSigsLengthMismatch2 <> "Invalid transaction sigs")) + sendExpect [cmdSignersSigsLengthMismatch2] (== (prefix 0 cmdSignersSigsLengthMismatch2 <> "Invalid transaction sigs: The number of signers and signatures do not match. Number of signers: 0. Number of signatures: 1.")) -- TODO: It's hard to test for invalid schemes, because it's baked into -- chainwebversion. @@ -296,7 +296,7 @@ invalidCommandTest rdb = runResourceT $ do pure $ bareCmd { _cmdSigs = [ED25519Sig "fakeSig"] } - sendExpect [cmdInvalidUserSig] (== (prefix cmdInvalidUserSig <> "Invalid transaction sigs")) + sendExpect [cmdInvalidUserSig] (== (prefix 0 cmdInvalidUserSig <> "Invalid transaction sigs: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.")) cmdGood <- liftIO $ buildTextCmd "good-command" v $ set cbSigners [mkEd25519Signer' sender00 []] @@ -307,12 +307,12 @@ invalidCommandTest rdb = runResourceT $ do $ defaultCmd -- Test that [badCmd, goodCmd] fails on badCmd, and the batch is rejected. -- We just re-use a previously built bad cmd. - sendExpect [cmdInvalidUserSig, cmdGood] (== (prefix cmdInvalidUserSig <> "Invalid transaction sigs")) + sendExpect [cmdInvalidUserSig, cmdGood] (== (prefix 0 cmdInvalidUserSig <> "Invalid transaction sigs: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.")) -- Test that [goodCmd, badCmd] fails on badCmd, and the batch is rejected. -- Order matters, and the error message also indicates the position of the -- failing tx. -- We just re-use a previously built bad cmd. - sendExpect [cmdGood, cmdInvalidUserSig] (== (prefix cmdInvalidUserSig <> "Invalid transaction sigs")) + sendExpect [cmdGood, cmdInvalidUserSig] (== (prefix 1 cmdInvalidUserSig <> "Invalid transaction sigs: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.")) -- | Check that txlogs don't problematically access history -- post-compaction. diff --git a/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs b/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs index e9ab176325..c1243e83b7 100644 --- a/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs +++ b/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs @@ -4,32 +4,32 @@ , DeriveAnyClass , DerivingStrategies , FlexibleContexts + , FlexibleInstances , ImplicitParams - , ImpredicativeTypes , ImportQualifiedPost + , ImpredicativeTypes , LambdaCase + , MultiParamTypeClasses + , NamedFieldPuns , NumericUnderscores , OverloadedStrings - , PatternSynonyms , PackageImports + , PartialTypeSignatures + , PatternSynonyms + , RecordWildCards , ScopedTypeVariables - , TypeApplications , TemplateHaskell - , RecordWildCards , TupleSections + , TypeApplications + , UndecidableInstances + , ViewPatterns #-} {-# options_ghc -fno-warn-gadt-mono-local-binds #-} -- temporary {-# options_ghc -Wwarn -fno-warn-name-shadowing -fno-warn-unused-top-binds #-} -{-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -Wno-partial-type-signatures #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE FlexibleInstances #-} module Chainweb.Test.Pact5.RemotePactTest ( tests @@ -225,13 +225,13 @@ pollingConfirmationDepthTest baseRdb _step = runResourceT $ do cmd2 <- buildTextCmd v (trivialTx cid 43) let rks = [cmdToRequestKey cmd1, cmdToRequestKey cmd2] - let expectSuccessful :: (HasCallStack, _) => P.Prop [Maybe TestPact5CommandResult] + let expectSuccessful :: (HasCallStack) => P.Prop [Maybe TestPact5CommandResult] expectSuccessful = P.alignExact [ P.match _Just ? P.fun _crResult ? P.equals (PactResultOk (PInteger 42)) , P.match _Just ? P.fun _crResult ? P.equals (PactResultOk (PInteger 43)) ] - let expectEmpty :: (HasCallStack, _) => _ + let expectEmpty :: (HasCallStack, Foldable t, Eq a) => t (Maybe a) -> IO () expectEmpty = traverse_ (P.equals Nothing) send fx v cid [cmd1, cmd2] @@ -353,7 +353,7 @@ sendInvalidTxsTest rdb = withResourceT (mkFixture v rdb) $ \fx -> $ set cbRPC (mkExec' "(+ 1") $ defaultCmd cid send fx v cid [cmdParseFailure] - & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains "Pact parse error" + & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains "Pact parse error: Expected: [')']" , testCase "invalid hash" $ do cmdInvalidPayloadHash <- do @@ -365,7 +365,7 @@ sendInvalidTxsTest rdb = withResourceT (mkFixture v rdb) $ \fx -> } send fx v cid [cmdInvalidPayloadHash] & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains - (validationFailed cmdInvalidPayloadHash "Invalid transaction hash") + (validationFailed 0 cmdInvalidPayloadHash "Invalid transaction hash") , testCase "signature length mismatch" $ do cmdSignersSigsLengthMismatch1 <- do @@ -377,7 +377,7 @@ sendInvalidTxsTest rdb = withResourceT (mkFixture v rdb) $ \fx -> } send fx v cid [cmdSignersSigsLengthMismatch1] & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains - (validationFailed cmdSignersSigsLengthMismatch1 "Invalid transaction sigs") + (validationFailed 0 cmdSignersSigsLengthMismatch1 "Invalid transaction sigs: The number of signers and signatures do not match. Number of signers: 1. Number of signatures: 0.") cmdSignersSigsLengthMismatch2 <- do bareCmd <- buildTextCmd v @@ -392,13 +392,13 @@ sendInvalidTxsTest rdb = withResourceT (mkFixture v rdb) $ \fx -> } send fx v cid [cmdSignersSigsLengthMismatch2] & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains - (validationFailed cmdSignersSigsLengthMismatch2 "Invalid transaction sigs") + (validationFailed 0 cmdSignersSigsLengthMismatch2 "Invalid transaction sigs: The number of signers and signatures do not match. Number of signers: 0. Number of signatures: 1.") , testCase "invalid signatures" $ do cmdInvalidUserSig <- mkCmdInvalidUserSig send fx v cid [cmdInvalidUserSig] & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains - (validationFailed cmdInvalidUserSig "Invalid transaction sigs") + (validationFailed 0 cmdInvalidUserSig "Invalid transaction sigs: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.") , testCase "batches are rejected with any invalid txs" $ do cmdGood <- mkCmdGood @@ -407,20 +407,32 @@ sendInvalidTxsTest rdb = withResourceT (mkFixture v rdb) $ \fx -> -- We just re-use a previously built bad cmd. send fx v cid [cmdInvalidUserSig, cmdGood] & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains - (validationFailed cmdInvalidUserSig "Invalid transaction sigs") + (validationFailed 0 cmdInvalidUserSig "Invalid transaction sigs: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.") -- Test that [goodCmd, badCmd] fails on badCmd, and the batch is rejected. -- Order matters, and the error message also indicates the position of the -- failing tx. -- We just re-use a previously built bad cmd. send fx v cid [cmdGood, cmdInvalidUserSig] & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains - (validationFailed cmdInvalidUserSig "Invalid transaction sigs") + (validationFailed 1 cmdInvalidUserSig "Invalid transaction sigs: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.") + + , testCase "multiple bad txs in batch" $ do + cmdGood <- mkCmdGood + cmdInvalidUserSig <- mkCmdInvalidUserSig + cmdParseFailure <- buildTextCmd v + $ set cbRPC (mkExec' "(+ 1") + $ defaultCmd cid + send fx v cid [cmdInvalidUserSig, cmdGood, cmdParseFailure] + & fails ? P.match _FailureResponse ? P.fun responseBody ? P.checkAll + [ textContains (validationFailed 0 cmdInvalidUserSig "Invalid transaction sigs: The signature at position 0 is invalid: failed to parse ed25519 signature: invalid bytestring size.") + , textContains (validationFailed 2 cmdParseFailure "Pact parse error: Expected: [')']") + ] , testCase "invalid metadata" $ do cmdGood <- mkCmdGood send fx v wrongChain [cmdGood] & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains - (validationFailed cmdGood "Transaction metadata (chain id, chainweb version) conflicts with this endpoint") + (validationFailed 0 cmdGood "Transaction metadata (chain id, chainweb version) conflicts with this endpoint") send fx wrongV cid [cmdGood] & fails ? P.match _FailureResponse ? P.checkAll @@ -432,21 +444,21 @@ sendInvalidTxsTest rdb = withResourceT (mkFixture v rdb) $ \fx -> cmdInvalidChain <- buildTextCmd v (defaultCmd cid & set cbChainId invalidCid) send fx v wrongChain [cmdInvalidChain] & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains - (validationFailed cmdInvalidChain "insert error: Unparsable ChainId") + (validationFailed 0 cmdInvalidChain "insert error: Unparsable ChainId") cmdWrongV <- buildTextCmd wrongV $ set cbRPC (mkExec "(+ 1 2)" (mkKeySetData "sender00" [sender00])) $ defaultCmd cid send fx v cid [cmdWrongV] & fails ? P.match _FailureResponse ? P.fun responseBody ? textContains - (validationFailed cmdWrongV "Transaction metadata (chain id, chainweb version) conflicts with this endpoint") + (validationFailed 0 cmdWrongV "Transaction metadata (chain id, chainweb version) conflicts with this endpoint") cmdExpiredTTL <- buildTextCmd v (defaultCmd cid & cbCreationTime .~ Just (TxCreationTime 0)) send fx v cid [cmdExpiredTTL] & fails ? P.match _FailureResponse ? P.checkAll [ P.fun responseStatusCode ? P.equals badRequest400 , P.fun responseBody ? textContains - (validationFailed cmdExpiredTTL "Transaction time-to-live is expired") + (validationFailed 0 cmdExpiredTTL "Transaction time-to-live is expired") ] , testCase "cannot buy gas" $ do @@ -457,7 +469,7 @@ sendInvalidTxsTest rdb = withResourceT (mkFixture v rdb) $ \fx -> & fails ? P.match _FailureResponse ? P.checkAll [ P.fun responseStatusCode ? P.equals badRequest400 , P.fun responseBody ? textContains - (validationFailed cmdExcessiveGasLimit "Transaction gas limit exceeds block gas limit") + (validationFailed 0 cmdExcessiveGasLimit "Transaction gas limit exceeds block gas limit") ] cmdGasPriceTooPrecise <- buildTextCmd v @@ -467,7 +479,7 @@ sendInvalidTxsTest rdb = withResourceT (mkFixture v rdb) $ \fx -> & fails ? P.match _FailureResponse ? P.checkAll [ P.fun responseStatusCode ? P.equals badRequest400 , P.fun responseBody ? textContains - (validationFailed cmdGasPriceTooPrecise "insert error: This transaction's gas price: 0.00000000000000001 is not correctly rounded. It should be rounded to at most 12 decimal places.") + (validationFailed 0 cmdGasPriceTooPrecise "insert error: This transaction's gas price: 0.00000000000000001 is not correctly rounded. It should be rounded to at most 12 decimal places.") ] cmdNotEnoughGasFunds <- buildTextCmd v @@ -478,7 +490,7 @@ sendInvalidTxsTest rdb = withResourceT (mkFixture v rdb) $ \fx -> & fails ? P.match _FailureResponse ? P.checkAll [ P.fun responseStatusCode ? P.equals badRequest400 , P.fun responseBody ? textContains - (validationFailed cmdNotEnoughGasFunds "Attempt to buy gas failed with: BuyGasPactError (PEUserRecoverableError (UserEnforceError \"Insufficient funds\")") + (validationFailed 0 cmdNotEnoughGasFunds "Attempt to buy gas failed with: BuyGasPactError (PEUserRecoverableError (UserEnforceError \"Insufficient funds\")") ] cmdInvalidSender <- buildTextCmd v @@ -490,7 +502,7 @@ sendInvalidTxsTest rdb = withResourceT (mkFixture v rdb) $ \fx -> , P.fun responseBody ? textContains -- TODO: the full error is far more verbose than this, -- perhaps that's something we should fix. - (validationFailed cmdInvalidSender "Attempt to buy gas failed") + (validationFailed 0 cmdInvalidSender "Attempt to buy gas failed") ] ] @@ -509,7 +521,7 @@ sendInvalidTxsTest rdb = withResourceT (mkFixture v rdb) $ \fx -> cid = unsafeChainId 0 wrongChain = unsafeChainId 1 - validationFailed cmd msg = "Validation failed for hash " <> sshow (_cmdHash cmd) <> ": " <> msg + validationFailed i cmd msg = "Transaction " <> sshow (_cmdHash cmd) <> " at index " <> sshow @Int i <> " failed with: " <> msg mkCmdInvalidUserSig = mkCmdGood <&> set cmdSigs [ED25519Sig "fakeSig"] @@ -667,7 +679,7 @@ successfulTx :: P.Prop (CommandResult log err) successfulTx = P.fun _crResult ? P.match _PactResultOk P.succeed -- TODO: backport into Pact 5 -_PEPact5Error :: Prism' (PactErrorCompat c) (ErrorCode, BoundedText _, c) +_PEPact5Error :: Prism' (PactErrorCompat c) (ErrorCode, BoundedText 256, c) _PEPact5Error = prism' (PEPact5Error . uncurry3 PactErrorCode) $ \case PEPact5Error (PactErrorCode {_peCode, _peMsg, _peInfo}) -> Just (_peCode, _peMsg, _peInfo) @@ -842,12 +854,12 @@ localTests baseRdb = let . at "balance" . _Just . _PDecimal let - hasBalance :: (HasCallStack, _) => _ + hasBalance :: (HasCallStack) => _ hasBalance p = P.fun _crResult ? P.match _PactResultOk ? P.match (_PObject . at "balance" . _Just) ? P.match _PDecimal p - hasBlockHeight :: (HasCallStack, _) => _ + hasBlockHeight :: (HasCallStack) => _ hasBlockHeight p = P.fun _crMetaData ? P.match (_Just . A._Object . at "blockHeight" . _Just . A._Number) p @@ -1057,7 +1069,7 @@ fails p actual = try actual >>= \case Left e -> p e _ -> P.fail "a failed computation" actual -textContains :: HasCallStack => _ +textContains :: HasCallStack => Text -> P.Prop Text textContains expectedStr actualStr | expectedStr `T.isInfixOf` actualStr = P.succeed actualStr | otherwise =