From 9958428478e37752b775b4f1e92bc2781c01d041 Mon Sep 17 00:00:00 2001 From: jmcardon Date: Tue, 28 Jan 2025 19:42:42 -0500 Subject: [PATCH] Revamp error codes to have the same format as legacy errors --- pact-repl/Main.hs | 14 - pact-request-api/Pact/Core/Command/Server.hs | 20 +- .../Pact/Core/Command/Server/History.hs | 2 +- pact-tests/Pact/Core/Test/ClientTests.hs | 11 +- .../Pact/Core/Test/JSONRoundtripTests.hs | 1 + .../Pact/Core/Test/PactContinuationTest.hs | 98 ++++--- pact-tests/PactCoreTests.hs | 2 + pact/Pact/Core/Errors.hs | 246 ++++++------------ pact/Pact/Core/Names.hs | 1 + test-utils/Pact/Core/Gen.hs | 14 + 10 files changed, 162 insertions(+), 247 deletions(-) diff --git a/pact-repl/Main.hs b/pact-repl/Main.hs index 708cfad50..c8cce5b72 100644 --- a/pact-repl/Main.hs +++ b/pact-repl/Main.hs @@ -22,8 +22,6 @@ import Pact.Core.Command.Server import Pact.Core.Command.Util import Pact.Core.Repl.Compile import System.IO -import Pact.Core.Errors -import Pact.Core.Info import qualified Pact.Core.Version as PI import System.Directory import System.Exit(exitFailure, exitSuccess) @@ -52,8 +50,6 @@ data ReplOpts | OServer FilePath -- Crypto | OGenKey - | OExplainErrorCode String - -- | OServer deriving (Eq, Show) replOpts :: O.Parser (Maybe ReplOpts) @@ -64,7 +60,6 @@ replOpts = O.optional $ <|> apiReqFlag <|> unsignedReqFlag <|> loadFlag - <|> explainErrorCodeFlag <|> OServer <$> O.strOption (O.metavar "CONFIG" <> O.short 's' <> O.long "server" <> O.help "Run Pact-Server") -- Todo: trace output and coverage? @@ -92,11 +87,6 @@ apiReqFlag = O.help "Format API request JSON using REQ_YAML file") <*> localFlag -explainErrorCodeFlag :: O.Parser ReplOpts -explainErrorCodeFlag = - OExplainErrorCode <$> O.strOption (O.long "explain-error-code" <> O.metavar "ERROR_CODE" <> - O.help "Describe the error code") - unsignedReqFlag :: O.Parser ReplOpts unsignedReqFlag = OUnsignedReq <$> O.strOption (O.short 'u' <> O.long "unsigned" <> O.metavar "REQ_YAML" <> @@ -128,10 +118,6 @@ main = O.execParser argParser >>= \case Just s -> runScript s dbg Nothing -> runScript fp dbg | otherwise -> runScript fp dbg - OExplainErrorCode errCodeStr -> case errorCodeFromText $ T.pack errCodeStr of - Nothing -> putStrLn $ "Invalid error code format" -- todo enhance error - Just errCode -> let (PrettyErrorCode phase cause _ _) = prettyErrorCode $ PactErrorCode errCode "" NoInfo - in T.putStrLn ("Encountered failure in: " <> phase <> ", caused by: " <> cause) OServer configPath -> Y.decodeFileEither configPath >>= \case Left perr -> putStrLn $ Y.prettyPrintParseException perr Right config -> runServer config noSPVSupport diff --git a/pact-request-api/Pact/Core/Command/Server.hs b/pact-request-api/Pact/Core/Command/Server.hs index d215d076b..aa0b4670a 100644 --- a/pact-request-api/Pact/Core/Command/Server.hs +++ b/pact-request-api/Pact/Core/Command/Server.hs @@ -89,7 +89,7 @@ instance Show ProcessResult where PEUnknownException _ -> "UnkownException" data ProcessMsg - = StoreMsg RequestKey (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info))) (MVar ProcessResult) + = StoreMsg RequestKey (CommandResult Hash PactOnChainError) (MVar ProcessResult) instance Show ProcessMsg where show = \case @@ -115,7 +115,7 @@ instance JE.Encode PollRequest where build (PollRequest rks) = JE.object [ "requestKeys" JE..= JE.Array rks ] newtype PollResponse - = PollResponse (HM.HashMap RequestKey (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)))) + = PollResponse (HM.HashMap RequestKey (CommandResult Hash (PactOnChainError))) deriving newtype (Eq, Show) instance JE.Encode PollResponse where @@ -138,7 +138,7 @@ instance JD.FromJSON ListenRequest where ListenRequest <$> o JD..: "listen" newtype ListenResponse - = ListenResponse (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info))) + = ListenResponse (CommandResult Hash (PactOnChainError)) deriving newtype (Eq, Show) instance JD.FromJSON ListenResponse where @@ -154,7 +154,7 @@ instance JE.Encode LocalRequest where build (LocalRequest cmd) = JE.build cmd newtype LocalResponse - = LocalResponse { _localResponse :: CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)) } + = LocalResponse { _localResponse :: CommandResult Hash (PactOnChainError) } instance JD.FromJSON LocalResponse where parseJSON v = LocalResponse <$> JD.parseJSON v @@ -288,7 +288,7 @@ sendHandler runtime (SendRequest submitBatch) = do Left (_::SomeException)-> throwError err500 pure $ SendResponse $ RequestKeys requestKeys -computeResultAndUpdateState :: ServerRuntime -> RequestKey -> Command Text -> IO (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info))) +computeResultAndUpdateState :: ServerRuntime -> RequestKey -> Command Text -> IO (CommandResult Hash (PactOnChainError)) computeResultAndUpdateState runtime requestKey cmd = case verifyCommand @(StableEncoding PublicMeta) (fmap E.encodeUtf8 cmd) of ProcFail errStr -> do @@ -331,7 +331,7 @@ computeResultAndUpdateState runtime requestKey cmd = pure $ pactErrorToCommandResult requestKey pe (Gas 0) Right evalResult -> pure $ evalResultToCommandResult requestKey evalResult -evalResultToCommandResult :: RequestKey -> EvalResult -> CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)) +evalResultToCommandResult :: RequestKey -> EvalResult -> CommandResult Hash (PactOnChainError) evalResultToCommandResult requestKey (EvalResult out logs exec gas _lm txid _lgas ev) = CommandResult { _crReqKey = requestKey @@ -344,11 +344,11 @@ evalResultToCommandResult requestKey (EvalResult out logs exec gas _lm txid _lga , _crMetaData = Nothing } -pactErrorToCommandResult :: RequestKey -> PactError Info -> Gas -> CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)) +pactErrorToCommandResult :: RequestKey -> PactError Info -> Gas -> CommandResult Hash (PactOnChainError) pactErrorToCommandResult rk pe gas = CommandResult { _crReqKey = rk , _crTxId = Nothing - , _crResult = PactResultErr $ PEPact5Error $ pactErrorToLocatedErrorCode $ pe + , _crResult = PactResultErr $ pactErrorToOnChainError pe , _crGas = gas , _crLogs = Nothing , _crEvents = [] -- todo @@ -357,10 +357,10 @@ pactErrorToCommandResult rk pe gas = CommandResult } -- TODO: once base-4.19 switch to L.unsnoc -evalOutputToCommandResult :: [CompileValue Info] -> PactResult (PactErrorCompat (LocatedErrorInfo Info)) +evalOutputToCommandResult :: [CompileValue Info] -> PactResult (PactOnChainError) evalOutputToCommandResult li = case L.uncons $ L.reverse li of Just (v, _) -> PactResultOk (compileValueToPactValue v) - Nothing -> PactResultErr $ PEPact5Error $ pactErrorToErrorCode $ PEExecutionError (EvalError "empty input") [] def + Nothing -> PactResultErr $ pactErrorToOnChainError $ PEExecutionError (EvalError "empty input") [] def localHandler :: ServerRuntime -> LocalRequest -> Handler LocalResponse localHandler env (LocalRequest cmd) = do diff --git a/pact-request-api/Pact/Core/Command/Server/History.hs b/pact-request-api/Pact/Core/Command/Server/History.hs index c3390e328..8f9280f0f 100644 --- a/pact-request-api/Pact/Core/Command/Server/History.hs +++ b/pact-request-api/Pact/Core/Command/Server/History.hs @@ -28,7 +28,7 @@ import qualified Pact.JSON.Decode as J import Pact.Core.Persistence.SQLite import Pact.Core.Serialise -type Cmd = CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)) +type Cmd = CommandResult Hash (PactOnChainError) data HistoryDb = HistoryDb diff --git a/pact-tests/Pact/Core/Test/ClientTests.hs b/pact-tests/Pact/Core/Test/ClientTests.hs index 411ed66f5..7f968ba7f 100644 --- a/pact-tests/Pact/Core/Test/ClientTests.hs +++ b/pact-tests/Pact/Core/Test/ClientTests.hs @@ -18,7 +18,6 @@ import Pact.Core.Command.Client import Pact.Core.Test.ServerUtils import Pact.Core.Errors -import Pact.Core.Evaluate simpleServerCmd :: IO (Command Text) simpleServerCmd = do @@ -44,7 +43,7 @@ tests = testGroup "Servant API client tests" [ cmd <- simpleServerCmdWithPactErr res <- withTestPactServer "clientspec" $ \clientEnv -> do runClientM (localClient (LocalRequest cmd)) clientEnv - (_crResult . _localResponse <$> res) `shouldSatisfy` failWith (ErrorCode 0) + (_crResult . _localResponse <$> res) `shouldSatisfy` failWith (ErrorType "ExecutionError") , testCase "correctly runs a simple command publicly and listens to the result" $ do cmd <- simpleServerCmd @@ -72,15 +71,13 @@ tests = testGroup "Servant API client tests" [ Left _ -> assertFailure "client request failed" Right r -> case r of -- ListenTimeout _ -> assertFailure "timeout" - ListenResponse lr -> Right (_crResult lr) `shouldSatisfy` failWith (ErrorCode 0) + ListenResponse lr -> Right (_crResult lr) `shouldSatisfy` failWith (ErrorType "ExecutionError") ] -failWith :: ErrorCode -> Either ClientError (PactResult (PactErrorCompat (LocatedErrorInfo Info))) -> Bool +failWith :: ErrorType -> Either ClientError (PactResult (PactOnChainError)) -> Bool failWith errType res = case res of Left _ -> False Right r -> case r of PactResultOk _ -> False - PactResultErr r' -> case r' of - PELegacyError _ -> False - PEPact5Error pe -> _peCode pe == errType + PactResultErr pe -> _peType pe == errType diff --git a/pact-tests/Pact/Core/Test/JSONRoundtripTests.hs b/pact-tests/Pact/Core/Test/JSONRoundtripTests.hs index fa2ca287b..f7661b96f 100644 --- a/pact-tests/Pact/Core/Test/JSONRoundtripTests.hs +++ b/pact-tests/Pact/Core/Test/JSONRoundtripTests.hs @@ -70,4 +70,5 @@ tests = testGroup "JSON Roundtrips" $ stableEncodings ++ jsonRoundtrips jsonRoundtrips = fmap testJSONRoundtrip $ [ EncodingCase signerGen , EncodingCase lineInfoGen + , EncodingCase pactOnChainErrorGen ] diff --git a/pact-tests/Pact/Core/Test/PactContinuationTest.hs b/pact-tests/Pact/Core/Test/PactContinuationTest.hs index af9550679..3d3031f40 100644 --- a/pact-tests/Pact/Core/Test/PactContinuationTest.hs +++ b/pact-tests/Pact/Core/Test/PactContinuationTest.hs @@ -36,7 +36,6 @@ import Pact.Core.Command.Server import Pact.Core.Command.Types import Pact.Core.Environment.Types import Pact.Core.Errors -import Pact.Core.Evaluate import Pact.Core.SPV import Pact.Core.StableEncoding import Pact.Core.Signer @@ -52,6 +51,7 @@ import qualified Pact.JSON.Encode as JE import Pact.Core.Test.ServerUtils -- ---- TESTS ----- +-- TODO: test error messages are expected in subsequent PR tests :: TestTree tests = testGroup "PactContinuationTests" @@ -134,7 +134,7 @@ testManagedCaps = do mhash])) -- PEUserRecoverableError (UserEnforceError "insufficient balance") -- Encountered failure in: PEUserRecoverableError, caused by: UserEnforceError - managedPayFails `failsWithCode` (ErrorCode 0x0004000000000000) + managedPayFails `failsWithCode` (ErrorType "ExecutionError") testOldNestedPacts :: TestTree testOldNestedPacts = do @@ -150,7 +150,7 @@ testOldNestedPacts = do succeeds moduleCmd -- pact-5 --explain-error-code 0x00031a0000000000 -- Encountered failure in: PEExecutionError, caused by: MultipleOrNestedDefPactExecFound - nestedExecPactCmd `failsWithCode` (ErrorCode 0x00031a0000000000) + nestedExecPactCmd `failsWithCode` (ErrorType "ExecutionError") -- CONTINUATIONS TESTS @@ -203,7 +203,7 @@ testNestedPactContinuation = testGroup "test nested pact continuation" $ [ testErrStep (errorStepNestedPactCode mname4) ("(" <> mname4 <> "-nested.nestedTester)") nestedDefPactFlags ] -testSimpleServerCmd :: IO (Maybe (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)))) +testSimpleServerCmd :: IO (Maybe (CommandResult Hash (PactOnChainError))) testSimpleServerCmd = do simpleKeys <- DynEd25519KeyPair <$> generateEd25519KeyPair cmd <- mkExec "(+ 1 2)" PUnit def [(simpleKeys,[])] [] Nothing (Just "test1") @@ -230,7 +230,7 @@ testCorrectNextStep code command flags = do -- pact-5 --explain-error-code 0x00031f0000000000 -- Encountered failure in: PEExecutionError, caused by: DefPactStepMismatch -- Fails with a `DefpactStepMismatch`, which is what we want. - checkStateCmd `failsWithCode` (ErrorCode 0x00031f0000000000) + checkStateCmd `failsWithCode` (ErrorType "ExecutionError") threeStepPactCode :: T.Text -> T.Text @@ -324,7 +324,7 @@ testIncorrectNextStep code command flags = do -- We expect a step mismatch -- pact-5 --explain-error-code 0x00031f0000000000 -- Encountered failure in: PEExecutionError, caused by: DefPactStepMismatch - incorrectStepCmd `failsWithCode` (ErrorCode 0x00031f0000000000) + incorrectStepCmd `failsWithCode` (ErrorType "ExecutionError") checkStateCmd `succeedsWith` (`shouldBe` textVal "step 1") @@ -351,7 +351,7 @@ testLastStep code command flags = do -- We are expecting the pact was already completed here. -- pact-5 --explain-error-code 0x0003150000000000 -- Encountered failure in: PEExecutionError, caused by: DefPactAlreadyCompleted - checkStateCmd `failsWithCode` (ErrorCode 0x0003150000000000) + checkStateCmd `failsWithCode` (ErrorType "ExecutionError") @@ -375,7 +375,7 @@ testErrStep code command flags = do -- We expect a step mismatch -- pact-5 --explain-error-code 0x00031f0000000000 -- Encountered failure in: PEExecutionError, caused by: DefPactStepMismatch - checkStateCmd `failsWithCode` (ErrorCode 0x00031f0000000000) + checkStateCmd `failsWithCode` (ErrorType "ExecutionError") errorStepPactCode :: T.Text -> T.Text @@ -465,7 +465,7 @@ testCorrectRollbackStep = do -- We are expecting the pact was already completed here. -- pact-5 --explain-error-code 0x0003150000000000 -- Encountered failure in: PEExecutionError, caused by: DefPactAlreadyCompleted - checkStateCmd `failsWithCode` (ErrorCode 0x0003150000000000) + checkStateCmd `failsWithCode` (ErrorType "ExecutionError") @@ -504,7 +504,7 @@ testIncorrectRollbackStep = do contNextStepCmd `succeedsWith` (`shouldBe` textVal "step 1") -- pact-5 --explain-error-code 0x00031e0000000000 -- Encountered failure in: PEExecutionError, caused by: DefPactRollbackMismatch - incorrectRbCmd `failsWithCode` (ErrorCode 0x00031e0000000000) + incorrectRbCmd `failsWithCode` (ErrorType "ExecutionError") checkStateCmd `succeedsWith` (`shouldBe` textVal "step 2") @@ -568,7 +568,7 @@ testNoRollbackFunc = do contNextStepCmd `succeedsWith` (`shouldBe` textVal "step 1") -- ✗ pact-5 --explain-error-code 0x00031b0000000000 -- Encountered failure in: PEExecutionError, caused by: DefPactStepHasNoRollback - noRollbackCmd `failsWithCode` (ErrorCode 0x00031b0000000000) + noRollbackCmd `failsWithCode` (ErrorType "ExecutionError") checkStateCmd `succeedsWith` (`shouldBe` textVal "step 2") @@ -598,7 +598,7 @@ testPactYield = testGroup "pact yield"$ [ -- the hash depends on the cbor encoding, so we bless some dummy hash ,testCase "testCrossChainYield:fails with different module" $ testCrossChainYield "(bless \"_9xPxvYomOU0iEqXpcrChvoA-E9qoaE1TqU460xN1AA\")" - (Just (`shouldBeErrorCode` (ErrorCode 0x0003320000000000))) + (Just (`shouldBeErrorType` ErrorType "ExecutionError")) mkFakeSPV testFlags ,testCase "testCrossChainYield:succeeds with blessed module" $ @@ -608,7 +608,7 @@ testPactYield = testGroup "pact yield"$ [ testCrossChainYield "(bless \"kuBrddl82uCHbhV1ECaH7fMf00Pq9lc2mPShU4Us_Jg\")" -- pact-5 --explain-error-code 0x0003390000000000 -- Encountered failure in: PEExecutionError, caused by: ContinuationError - (Just $ (`shouldBeErrorCode` ErrorCode 0x0003380000000000)) + (Just $ (`shouldBeErrorType` ErrorType "ExecutionError")) (const noSPVSupport) testFlags ] testNestedPactYield :: TestTree @@ -709,7 +709,7 @@ testNestedPactYield = testGroup "nested pact yield" $ [ -- we expect the defpact to already be completed here -- pact-5 --explain-error-code 0x0003150000000000 -- Encountered failure in: PEExecutionError, caused by: DefPactAlreadyCompleted - chain1ContDupe `failsWithCode` (ErrorCode 0x0003150000000000) + chain1ContDupe `failsWithCode` (ErrorType "ExecutionError") testValidYield :: Text -> (Text -> Text) -> [ExecutionFlag] -> Assertion @@ -733,7 +733,7 @@ testValidYield moduleName mkCode flags = do executePactCmd `succeedsWith` (`shouldBe` textVal "testing->Step0") resumeAndYieldCmd `succeedsWith` (`shouldBe` textVal "testing->Step0->Step1") resumeOnlyCmd `succeedsWith` (`shouldBe` textVal "testing->Step0->Step1->Step2") - checkStateCmd `failsWithCode` (ErrorCode 0x0003150000000000) + checkStateCmd `failsWithCode` (ErrorType "ExecutionError") pactWithYield :: T.Text -> T.Text @@ -816,7 +816,7 @@ testNoYield moduleName mkCode flags = do executePactCmd `succeedsWith` (`shouldBe` textVal "testing->Step0") noYieldStepCmd `succeedsWith` (`shouldBe` textVal "step 1 has no yield") fails resumeErrCmd - checkStateCmd `failsWithCode` (ErrorCode 0x00031f0000000000) + checkStateCmd `failsWithCode` (ErrorType "ExecutionError") pactWithYieldErr :: T.Text -> T.Text @@ -887,7 +887,7 @@ testResetYield moduleName mkCode flags = do executePactCmd `succeedsWith` (`shouldBe` textVal "step 0") yieldSameKeyCmd `succeedsWith` (`shouldBe` textVal "step 1") resumeStepCmd `succeedsWith` (`shouldBe` textVal "step 1") - checkStateCmd `failsWithCode` (ErrorCode 0x0003150000000000) + checkStateCmd `failsWithCode` (ErrorType "ExecutionError") @@ -959,7 +959,7 @@ mkFakeSPV pe = return $ Left "Invalid proof" } -testCrossChainYield :: T.Text -> Maybe (PactErrorCode (LocatedErrorInfo Info) -> Assertion) -> (DefPactExec -> SPVSupport) -> [ExecutionFlag] -> Assertion +testCrossChainYield :: T.Text -> Maybe (PactOnChainError -> Assertion) -> (DefPactExec -> SPVSupport) -> [ExecutionFlag] -> Assertion testCrossChainYield blessCode expectFailure mkSpvSupport spvFlags = step0 where @@ -1036,7 +1036,7 @@ testCrossChainYield blessCode expectFailure mkSpvSupport spvFlags = step0 , PList $ V.fromList [ textVal "emily" ]] (ModuleName "pact" Nothing) mhash])) - chain1ContDupe `failsWithCode` (ErrorCode 0x0003150000000000) + chain1ContDupe `failsWithCode` (ErrorType "ExecutionError") Just expected -> chain1ContDupe `failsWith'` expected @@ -1131,7 +1131,7 @@ testTwoPartyEscrow = testGroup "two party escrow" $ [ twoPartyEscrow :: [Command Text] - -> (Hash -> ReaderT (M.Map RequestKey (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)))) IO ()) + -> (Hash -> ReaderT (M.Map RequestKey (CommandResult Hash (PactOnChainError))) IO ()) -> Assertion twoPartyEscrow testCmds act = do let setupPath = testDir ++ "cont-scripts/setup-" @@ -1163,9 +1163,9 @@ decValue = PDecimal checkContHash :: HasCallStack => [ApiReqParts] - -> ReaderT (M.Map RequestKey (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)))) IO () + -> ReaderT (M.Map RequestKey (CommandResult Hash (PactOnChainError))) IO () -> Hash - -> ReaderT (M.Map RequestKey (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)))) IO () + -> ReaderT (M.Map RequestKey (CommandResult Hash (PactOnChainError))) IO () checkContHash reqs act hsh = forM_ reqs $ \req -> let desc = show $ view (_1 . to _ylNonce) req in case preview (_1 . to _ylPactTxHash . _Just) req of @@ -1187,7 +1187,7 @@ testDebtorPreTimeoutCancel = do -- pact-5 --explain-error-code 0x0004000000000000 -- Encountered failure in: PEUserRecoverableError, caused by: UserEnforceError -- Printed, it's PEUserRecoverableError (UserEnforceError "Cancel can only be effected by creditor, or debitor after timeout") - tryCancelCmd `failsWithCode` (ErrorCode 0x0004000000000000) + tryCancelCmd `failsWithCode` (ErrorType "ExecutionError") checkStillEscrowCmd `succeedsWith` (`shouldBe` decValue 98.00) @@ -1236,9 +1236,9 @@ testFinishAlone = do twoPartyEscrow allCmds $ checkContHash [r1, r2] $ do -- PEUserRecoverableError (KeysetPredicateFailure KeysAll (fromList [PublicKeyText {_pubKey = "7d0c9ba189927df85c8c54f8b5c8acd76c1d27e923abbf25a957afdf25550804"}])) -- [StackFrame {_sfName = FullyQualifiedName {_fqModule = ModuleName {_mnName = "accounts", _mnNamespace = Nothing}, _fqName = "USER_GUARD", _fqHash = ModuleHash {_mhHash = "bgU2grm5I7_Jyx6Hb93izSWhNDNWcxYlLYOPhNCdIDU"}}, - tryCredAloneCmd `failsWithCode` (ErrorCode 0x0004040000000000) + tryCredAloneCmd `failsWithCode` (ErrorType "ExecutionError") -- PEUserRecoverableError (KeysetPredicateFailure KeysAll (fromList [PublicKeyText {_pubKey = "ac69d9856821f11b8e6ca5cdd84a98ec3086493fd6407e74ea9038407ec9eba9"}])) - tryDebAloneCmd `failsWithCode` (ErrorCode 0x0004040000000000) + tryDebAloneCmd `failsWithCode` (ErrorType "ExecutionError") testPriceNegUp :: Assertion @@ -1250,7 +1250,7 @@ testPriceNegUp = do -- Encountered failure in: PEUserRecoverableError, caused by: UserEnforceError -- PEUserRecoverableError (UserEnforceError "Price cannot negotiate up") twoPartyEscrow [tryNegUpCmd] $ checkContHash [req] $ do - tryNegUpCmd `failsWithCode` (ErrorCode 0x0004000000000000) + tryNegUpCmd `failsWithCode` (ErrorType "ExecutionError") testValidEscrowFinish :: Assertion @@ -1276,7 +1276,7 @@ testPriceNegDownBadCaps = do -- PEUserRecoverableError (KeysetPredicateFailure KeysAll (fromList -- [PublicKeyText {_pubKey = "7d0c9ba189927df85c8c54f8b5c8acd76c1d27e923abbf25a957afdf25550804"}])) twoPartyEscrow [tryNegUpCmd] $ checkContHash [req] $ do - tryNegUpCmd `failsWithCode` (ErrorCode 0x0004040000000000) + tryNegUpCmd `failsWithCode` (ErrorType "ExecutionError") testVerifiers :: TestTree testVerifiers = testGroup "using a verifier" $ [ @@ -1303,10 +1303,10 @@ shouldMatch :: HasCallStack => Command Text -> ExpectResult - -> ReaderT (M.Map RequestKey (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)))) IO () + -> ReaderT (M.Map RequestKey (CommandResult Hash (PactOnChainError))) IO () shouldMatch cmd er = ask >>= liftIO . shouldMatch' (makeCheck cmd er) -shouldMatch' :: HasCallStack => CommandResultCheck -> M.Map RequestKey (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info))) -> Assertion +shouldMatch' :: HasCallStack => CommandResultCheck -> M.Map RequestKey (CommandResult Hash (PactOnChainError)) -> Assertion shouldMatch' CommandResultCheck{..} results = checkResult _crcExpect apiRes where apiRes = M.lookup _crcReqKey results @@ -1315,34 +1315,34 @@ shouldMatch' CommandResultCheck{..} results = checkResult _crcExpect apiRes Just cr -> crTest cr succeeds :: HasCallStack => Command Text -> - ReaderT (M.Map RequestKey (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)))) IO () + ReaderT (M.Map RequestKey (CommandResult Hash (PactOnChainError))) IO () succeeds cmd = cmd `succeedsWith` (\_ -> pure ()) succeedsWith :: HasCallStack => Command Text -> (PactValue -> Assertion) -> - ReaderT (M.Map RequestKey (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)))) IO () + ReaderT (M.Map RequestKey (CommandResult Hash (PactOnChainError))) IO () succeedsWith cmd r = succeedsWith' cmd (\(pv,es) -> (es `shouldBe` []) *> r pv) succeedsWith' :: HasCallStack => Command Text -> ((PactValue,[PactEvent PactValue]) -> Assertion) -> - ReaderT (M.Map RequestKey (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)))) IO () + ReaderT (M.Map RequestKey (CommandResult Hash (PactOnChainError))) IO () succeedsWith' cmd r = shouldMatch cmd (resultShouldBe $ Right r) fails :: HasCallStack => Command Text -> - ReaderT (M.Map RequestKey (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)))) IO () + ReaderT (M.Map RequestKey (CommandResult Hash (PactOnChainError))) IO () fails cmd = cmd `failsWith` (\_ -> pure ()) -failsWith :: HasCallStack => Command Text -> (PactErrorCode (LocatedErrorInfo Info) -> Assertion) -> - ReaderT (M.Map RequestKey (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)))) IO () +failsWith :: HasCallStack => Command Text -> (PactOnChainError -> Assertion) -> + ReaderT (M.Map RequestKey (CommandResult Hash (PactOnChainError))) IO () failsWith cmd r = failsWith' cmd (\e -> r e) -failsWithCode :: HasCallStack => Command Text -> ErrorCode -> - ReaderT (M.Map RequestKey (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)))) IO () -failsWithCode cmd r = failsWith' cmd ((`shouldBe` r) . _peCode) +failsWithCode :: HasCallStack => Command Text -> ErrorType -> + ReaderT (M.Map RequestKey (CommandResult Hash (PactOnChainError))) IO () +failsWithCode cmd r = failsWith' cmd ((`shouldBe` r) . _peType) -shouldBeErrorCode :: HasCallStack => PactErrorCode info -> ErrorCode -> Assertion -shouldBeErrorCode pe code = _peCode pe `shouldBe` code +shouldBeErrorType :: HasCallStack => PactOnChainError -> ErrorType -> Assertion +shouldBeErrorType pe code = _peType pe `shouldBe` code -failsWith' :: HasCallStack => Command Text -> (PactErrorCode (LocatedErrorInfo Info) -> Assertion) -> - ReaderT (M.Map RequestKey (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)))) IO () +failsWith' :: HasCallStack => Command Text -> (PactOnChainError -> Assertion) -> + ReaderT (M.Map RequestKey (CommandResult Hash (PactOnChainError))) IO () failsWith' cmd r = shouldMatch cmd (resultShouldBe $ Left r) @@ -1401,7 +1401,7 @@ getDefPactId :: Command Text -> DefPactId getDefPactId cmd = DefPactId $ hashToText hsh where hsh = _cmdHash cmd -newtype ExpectResult = ExpectResult (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)) -> Assertion) +newtype ExpectResult = ExpectResult (CommandResult Hash (PactOnChainError) -> Assertion) deriving (Semigroup) data CommandResultCheck = CommandResultCheck @@ -1413,21 +1413,21 @@ data CommandResultCheck = CommandResultCheck makeCheck :: Command T.Text -> ExpectResult -> CommandResultCheck makeCheck c@Command{} expect = CommandResultCheck (cmdToRequestKey c) expect -runAll :: [Command T.Text] -> IO (M.Map RequestKey (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)))) +runAll :: [Command T.Text] -> IO (M.Map RequestKey (CommandResult Hash (PactOnChainError))) runAll cmds = runAll' cmds noSPVSupport [] runAll' :: [Command T.Text] -> SPVSupport -> [ExecutionFlag] - -> IO (M.Map RequestKey (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)))) + -> IO (M.Map RequestKey (CommandResult Hash (PactOnChainError))) runAll' cmds spv flags = withTestPactServerWithSpv "continuationspec" flags spv $ \clientEnv -> run clientEnv cmds -run :: ClientEnv -> [Command T.Text] -> IO (M.Map RequestKey (CommandResult Hash (PactErrorCompat (LocatedErrorInfo Info)))) +run :: ClientEnv -> [Command T.Text] -> IO (M.Map RequestKey (CommandResult Hash (PactOnChainError))) run clientEnv cmds = do sendResp <- doSend clientEnv . SendRequest . SubmitBatch $ NEL.fromList cmds case sendResp of @@ -1455,13 +1455,11 @@ doPoll clientEnv req = runClientM (pollClient req) clientEnv resultShouldBe :: HasCallStack - => Either (PactErrorCode (LocatedErrorInfo Info) -> Assertion) ((PactValue,[PactEvent PactValue]) -> Assertion) + => Either (PactOnChainError -> Assertion) ((PactValue,[PactEvent PactValue]) -> Assertion) -> ExpectResult resultShouldBe expect = ExpectResult $ \cr -> case (expect, _crResult cr) of - (Left expErr, PactResultErr e) -> case e of - PEPact5Error err -> expErr err - _ -> error "case impossible: no compat errors are emitted by pact-5" + (Left expErr, PactResultErr e) -> expErr e (Right expVal, PactResultOk pv) -> expVal (pv, _crEvents cr) _ -> assertFailure $ unwords [ "Expected", either (\_ -> "PactError") (\_ -> "PactValue") expect, ", found", show cr ] diff --git a/pact-tests/PactCoreTests.hs b/pact-tests/PactCoreTests.hs index ed6d29591..a8005c35e 100644 --- a/pact-tests/PactCoreTests.hs +++ b/pact-tests/PactCoreTests.hs @@ -24,6 +24,7 @@ import qualified Pact.Core.Test.SignatureSchemeTests as SignatureSchemeTests import qualified Pact.Core.Test.JSONRoundtripTests as JSONRoundtripTests import qualified Pact.Core.Test.LegacyDBRegression as LegacyDbRegression import qualified Pact.Core.Test.PactContinuationTest as PactContinuationTests +import qualified Pact.Core.Test.ClientTests as ClientTests main :: IO () main = do @@ -55,5 +56,6 @@ main = do , legacyDbRegression , PactServerTests.tests , PactContinuationTests.tests + , ClientTests.tests ] diff --git a/pact/Pact/Core/Errors.hs b/pact/Pact/Core/Errors.hs index 5314add71..8e8738534 100644 --- a/pact/Pact/Core/Errors.hs +++ b/pact/Pact/Core/Errors.hs @@ -28,15 +28,11 @@ module Pact.Core.Errors , peInfo , viewErrorStack , UserRecoverableError(..) - , ErrorCode(..) - , PactErrorCode(..) - , PrettyErrorCode(..) - , pactErrorToErrorCode - , prettyErrorCode - , errorCodeFromText + , ErrorType(..) + , PactOnChainError(..) + , pactErrorToOnChainError , LegacyPactError(..) , LegacyPactErrorType(..) - , PactErrorCompat(..) , VerifierError(..) , ErrorClosureType(..) , _PELexerError @@ -193,31 +189,21 @@ module Pact.Core.Errors , mkBoundedText , PactErrorOrigin(..) , LocatedErrorInfo(..) - , pactErrorToLocatedErrorCode - , _PELegacyError - , _PEPact5Error ) where import Control.Lens hiding (ix) -import Control.Monad import Control.Applicative -import Data.Bits -import Data.Foldable(find) import Data.Proxy import Data.Text(Text) import Data.Typeable(Typeable) import Data.Set(Set) -import Data.Word import Data.List(intersperse) import Data.Default -import Numeric (showHex) import GHC.TypeLits import qualified Data.Version as V import qualified Pact.Core.Version as PI import qualified Data.Set as S import qualified Data.Text as T -import qualified Data.Text.Read as T -import qualified Data.Char as C import qualified Pact.JSON.Decode as JD import qualified Pact.JSON.Encode as J @@ -238,6 +224,9 @@ import Pact.Core.DeriveConTag import Pact.Core.ChainData (ChainId(_chainId)) import Data.String (IsString(..)) import Pact.Core.Gas.Types +import qualified Text.Megaparsec as MP +import qualified Text.Megaparsec.Char as MP +import Text.Read (readMaybe) -- A common type alias, as `PactErrorI`s come straight from running -- the lexer + parser @@ -1120,7 +1109,9 @@ data PactError info data PactErrorOrigin = TopLevelErrorOrigin | FunctionErrorOrigin FullyQualifiedName - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance NFData PactErrorOrigin instance J.Encode PactErrorOrigin where build = \case @@ -1141,7 +1132,9 @@ data LocatedErrorInfo info = LocatedErrorInfo { _leiOrigin :: PactErrorOrigin , _leiInfo :: info - } deriving (Eq, Show, Functor, Foldable, Traversable) + } deriving (Eq, Show, Functor, Foldable, Traversable, Generic) + +instance NFData info => NFData (LocatedErrorInfo info) instance Default info => Default (LocatedErrorInfo info) where def = LocatedErrorInfo TopLevelErrorOrigin def @@ -1152,12 +1145,41 @@ locatePactErrorInfo pe = sf:_ -> fmap (LocatedErrorInfo (FunctionErrorOrigin (_sfName sf))) pe [] -> fmap (LocatedErrorInfo TopLevelErrorOrigin) pe +type Parser = MP.Parsec () Text + +locatedErrorInfoParser :: Parser (LocatedErrorInfo LineInfo) +locatedErrorInfoParser = do + origin <- parseOrigin + _ <- MP.char ':' + digits <- some MP.digitChar + case readMaybe digits of + Just i -> pure (LocatedErrorInfo origin (LineInfo i)) + Nothing -> fail "parsing located error info failed" + where + parseOrigin = + (TopLevelErrorOrigin <$ MP.chunk "") <|> (FunctionErrorOrigin <$> fullyQualNameParser) + +instance {-# OVERLAPPING #-} J.Encode (LocatedErrorInfo LineInfo) where + build (LocatedErrorInfo origin i) = + J.text (origin' <> ":" <> i') + where + i' = T.pack (show (_lineInfo i)) + origin' = case origin of + TopLevelErrorOrigin -> "" + FunctionErrorOrigin fqn -> renderFullyQualName fqn + instance J.Encode info => J.Encode (LocatedErrorInfo info) where build loc = J.object [ "origin" J..= _leiOrigin loc , "info" J..= _leiInfo loc ] + +instance {-# OVERLAPPING #-} JD.FromJSON (LocatedErrorInfo LineInfo) where + parseJSON = JD.withText "LocatedErrorInfo" $ \o -> case MP.parseMaybe (locatedErrorInfoParser <* MP.eof) o of + Just lei -> pure lei + Nothing -> fail "Invalid Located error info" + instance JD.FromJSON info => JD.FromJSON (LocatedErrorInfo info) where parseJSON = JD.withObject "LocatedErrorInfo" $ \o -> LocatedErrorInfo @@ -1213,7 +1235,7 @@ deriveConstrInfo ''PactError newtype BoundedText (k :: Nat) = BoundedText {_boundedText :: Text } - deriving newtype (Eq, Show, JD.FromJSON, J.Encode) + deriving newtype (Eq, Show, JD.FromJSON, J.Encode, NFData) instance KnownNat k => IsString (BoundedText k) where fromString = ensureBound . T.pack @@ -1829,129 +1851,61 @@ pactErrorToBoundedText = \case -- ------------------- Version -- Note [As of Jul 2 2024]: There are no error versions other than 0, -- so we don't have a versioning data type yet. -newtype ErrorCode - = ErrorCode Word64 - deriving (Eq, Ord) +newtype ErrorType + = ErrorType Text + deriving newtype (Eq, Ord, NFData) -- | Note: This Show actually defined the error code's serialization. -- TODO: is this kosher? Or should we expose an `errorCodeToHexString` function? -instance Show ErrorCode where - show (ErrorCode e) = - let h = showHex e "" - len = length h - in "0x" <> if len < 16 then replicate (16 - len) '0' <> h else h +instance Show ErrorType where + show (ErrorType e) = show e -- | Our data type for presenting error codes alongside -- a span info -data PactErrorCode info - = PactErrorCode - { _peCode :: ErrorCode +data PactOnChainError + = PactOnChainError + { _peType :: ErrorType , _peMsg :: BoundedText PactErrorMsgSize - , _peInfo :: info - } deriving (Eq, Show, Functor, Foldable, Traversable) - -errorCodeFromText :: Text -> Maybe ErrorCode -errorCodeFromText t = do - guard (T.length t == 18 && T.all C.isHexDigit (T.drop 2 t)) - case T.hexadecimal t of - Right (a, remaining) | T.null remaining -> pure $ ErrorCode a - _ -> Nothing - -instance {-# OVERLAPPING #-} J.Encode (PactErrorCode NoInfo) where - build (PactErrorCode ec msg _) = J.object - [ "errorCode" J..= T.pack (show ec) - , "message" J..= msg - ] + , _peInfo :: LocatedErrorInfo LineInfo + } deriving (Eq, Show, Generic) -instance {-# OVERLAPPING #-} JD.FromJSON (PactErrorCode NoInfo) where - parseJSON = JD.withObject "PactErrorCode" $ \o -> do - t <- o JD..: "errorCode" - case errorCodeFromText t of - Just a -> do - msg <- o JD..: "message" - pure $ PactErrorCode a msg NoInfo - _ -> fail "failed to parse pact error code" - -instance J.Encode info => J.Encode (PactErrorCode info) where - build (PactErrorCode ec msg info) = J.object +instance NFData PactOnChainError + +instance J.Encode PactOnChainError where + build (PactOnChainError (ErrorType e) msg info) = J.object -- Note: this is safe, the `Show` instance converts it to hex -- chessai: But what if it stops doing that? - [ "errorCode" J..= T.pack (show ec) + [ "callStack" J..= J.Array(mempty :: [Text]) + , "type" J..= J.text e , "message" J..= msg , "info" J..= info ] -instance JD.FromJSON info => JD.FromJSON (PactErrorCode info) where - parseJSON = JD.withObject "PactErrorCode" $ \o -> do - t <- o JD..: "errorCode" - case errorCodeFromText t of - Just a -> do - info <- o JD..: "info" - msg <- o JD..: "message" - pure $ PactErrorCode a msg info - _ -> fail "failed to parse pact error code" - -pactErrorToErrorCode :: PactError info -> PactErrorCode info -pactErrorToErrorCode pe = let - info = view peInfo pe +instance JD.FromJSON PactOnChainError where + parseJSON = JD.withObject "PactOnChainError" $ \o -> do + t <- ErrorType <$> o JD..: "type" + info <- o JD..: "info" + msg <- o JD..: "message" + pure $ PactOnChainError t msg info + +pactErrorToOnChainError :: PactError LineInfo -> PactOnChainError +pactErrorToOnChainError pe = let + info = view peInfo (locatePactErrorInfo pe) -- Inner tag is - innerTag = shiftL (fromIntegral (innerConstrTag pe)) innerErrorShiftBits - outerTag = shiftL (fromIntegral (constrIndex pe)) outerErrorShiftBits - code = ErrorCode (innerTag .|. outerTag) - in PactErrorCode code (pactErrorToBoundedText pe) info - where - innerConstrTag = \case - PELexerError e _ -> constrIndex e - PEParseError e _ -> constrIndex e - PEDesugarError e _ -> constrIndex e - PEExecutionError e _ _ -> constrIndex e - PEUserRecoverableError e _ _ -> constrIndex e - PEVerifierError e _ -> constrIndex e - -pactErrorToLocatedErrorCode :: PactError info -> PactErrorCode (LocatedErrorInfo info) -pactErrorToLocatedErrorCode = pactErrorToErrorCode . locatePactErrorInfo - -data PrettyErrorCode info - = PrettyErrorCode - { _pecFailurePhase :: Text - , _pecFailureCause :: Text - , _pecMsg :: Text - , _pecInfo :: info - } deriving Show - -_versionMask, outerErrorMask, innerErrorMask :: Word64 -_versionMask = 0xFF_00_00_00_00_00_00_00 -outerErrorMask = 0x00_FF_00_00_00_00_00_00 -innerErrorMask = 0x00_00_FF_00_00_00_00_00 - -_versionShiftBits, outerErrorShiftBits, innerErrorShiftBits :: Int -_versionShiftBits = 56 -outerErrorShiftBits = 48 -innerErrorShiftBits = 40 - --- | Get the inner and outer cause from an error code -prettyErrorCode :: PactErrorCode info -> PrettyErrorCode info -prettyErrorCode (PactErrorCode (ErrorCode ec) msg i) = - PrettyErrorCode phase cause (_boundedText msg) i + -- Drop the first 2 PE characters + -- NOTE: THIS WILL AFFECT REPLAY, DO NOT CHANGE WITHOUT A FORK + errType = toErrorType pe + in PactOnChainError (ErrorType errType) (pactErrorToBoundedText pe) info where - getCtorName ctorIx p = - case find ((== ctorIx) . _ciIndex) (allConstrInfos p) of - Just c -> _ciName c - Nothing -> "UNKNOWN_CODE" - phase = - let tagIx = (ec .&. outerErrorMask) `shiftR` outerErrorShiftBits - in getCtorName (fromIntegral tagIx) (Proxy :: Proxy (PactError ())) - causeTag :: Word8 - causeTag = - fromIntegral ((ec .&. innerErrorMask) `shiftR` innerErrorShiftBits) - cause = case phase of - "PELexerError" -> getCtorName causeTag (Proxy :: Proxy LexerError) - "PEParseError" -> getCtorName causeTag (Proxy :: Proxy ParseError) - "PEDesugarError" -> getCtorName causeTag (Proxy :: Proxy DesugarError) - "PEExecutionError" -> getCtorName causeTag (Proxy :: Proxy EvalError) - "PEUserRecoverableError" -> getCtorName causeTag (Proxy :: Proxy UserRecoverableError) - "PEVerifierError" -> getCtorName causeTag (Proxy :: Proxy VerifierError) - _ -> "UNKNOWN_CODE" + toErrorType = \case + PELexerError{} -> "SyntaxError" + PEParseError{} -> "SyntaxError" + PEExecutionError{} -> "ExecutionError" + PEUserRecoverableError{} -> "ExecutionError" + PEDesugarError{} -> "CompilationError" + PEVerifierError{} -> "VerifierError" + + makePrisms ''PactError makePrisms ''InvariantError @@ -2028,41 +1982,3 @@ toPrettyLegacyError pe = let stack = renderText <$> viewErrorStack pe info = renderText (view peInfo pe) in LegacyPactError (pactErrorToLegacyErrorType pe) info stack (renderText pe) - -instance J.Encode LegacyPactError where - build o = J.object - [ "callStack" J..= J.Array (_leCallStack o) - , "type" J..= _leType o - , "message" J..= _leMessage o - , "info" J..= _leInfo o - ] - {-# INLINE build #-} - - -instance JD.FromJSON LegacyPactError where - parseJSON = JD.withObject "LegacyPactError" $ \o -> do - cs <- o JD..: "callStack" - ty <- o JD..: "type" - msg <- o JD..: "message" - info <- o JD..: "info" - pure (LegacyPactError ty info cs msg) - --- | PactErrorCompat exists to provide a --- codec that can understand both pact 4 and pact 5 errors -data PactErrorCompat info - = PEPact5Error (PactErrorCode info) - -- TODO: rename? we are using this for some errors even in the Pact 5 integration - | PELegacyError LegacyPactError - deriving (Eq, Show, Functor, Foldable, Traversable) - -makePrisms ''PactErrorCompat - -instance J.Encode info => J.Encode (PactErrorCompat info) where - build = \case - PEPact5Error err -> J.build err - PELegacyError err -> J.build err - -instance JD.FromJSON info => JD.FromJSON (PactErrorCompat info) where - parseJSON v = - (PEPact5Error <$> JD.parseJSON v) <|> - (PELegacyError <$> JD.parseJSON v) diff --git a/pact/Pact/Core/Names.hs b/pact/Pact/Core/Names.hs index 9be8eadde..aaaf658a3 100644 --- a/pact/Pact/Core/Names.hs +++ b/pact/Pact/Core/Names.hs @@ -65,6 +65,7 @@ module Pact.Core.Names , parseParsedTyName , parseQualifiedName , parseFullyQualifiedName + , fullyQualNameParser , VerifierName(..) , renderTableName , jsonSafeRenderTableName diff --git a/test-utils/Pact/Core/Gen.hs b/test-utils/Pact/Core/Gen.hs index 2e8e13694..793789f84 100644 --- a/test-utils/Pact/Core/Gen.hs +++ b/test-utils/Pact/Core/Gen.hs @@ -40,6 +40,7 @@ import Pact.Core.Namespace import Pact.Core.Gas import Pact.Core.ModRefs import Pact.Core.Hash +import Pact.Core.Errors import Data.Ratio ((%), denominator) namespaceNameGen :: Gen NamespaceName @@ -89,6 +90,19 @@ lineInfoGen = LineInfo <$> Gen.integral Range.constantBounded +locatedErrorInfoGen :: Gen info -> Gen (LocatedErrorInfo info) +locatedErrorInfoGen i = + LocatedErrorInfo <$> locGen <*> i + where + locGen = Gen.choice [pure TopLevelErrorOrigin, FunctionErrorOrigin <$> fullyQualifiedNameGen] + +pactOnChainErrorGen :: Gen PactOnChainError +pactOnChainErrorGen = + PactOnChainError + <$> (ErrorType <$> identGen) + <*> (mkBoundedText <$> identGen) + <*> locatedErrorInfoGen lineInfoGen + capTokenGen :: Gen name -> Gen v -> Gen (CapToken name v) capTokenGen n v = CapToken <$> n <*> Gen.list (Range.linear 0 10) v