diff --git a/crypto/Pact/Core/Crypto/Pairing.hs b/crypto/Pact/Core/Crypto/Pairing.hs index 528fe9123..db1a75ea6 100644 --- a/crypto/Pact/Core/Crypto/Pairing.hs +++ b/crypto/Pact/Core/Crypto/Pairing.hs @@ -402,7 +402,6 @@ data CurvePoint a | CurveInf deriving (Eq, Show) --- todo: sort of scuffed, num instance? double :: (Field a, Num a, Eq a) => CurvePoint a -> CurvePoint a double CurveInf = CurveInf double (Point x y) diff --git a/gasmodel/Pact/Core/GasModel/InterpreterGas.hs b/gasmodel/Pact/Core/GasModel/InterpreterGas.hs index c573438f4..4aed8f29a 100644 --- a/gasmodel/Pact/Core/GasModel/InterpreterGas.hs +++ b/gasmodel/Pact/Core/GasModel/InterpreterGas.hs @@ -370,7 +370,7 @@ gasMtWithHandlerError pdb = let es = defaultGasEvalState ps = _eeDefPactStep ee frame = Mt - value = VError "foo" () + value = VError [] (UserEnforceError "foo") () env = CEKEnv { _cePactDb=pdb , _ceLocal=mempty , _ceInCap=False diff --git a/pact-lsp/Pact/Core/LanguageServer.hs b/pact-lsp/Pact/Core/LanguageServer.hs index a2382894b..455c6df2c 100644 --- a/pact-lsp/Pact/Core/LanguageServer.hs +++ b/pact-lsp/Pact/Core/LanguageServer.hs @@ -254,7 +254,7 @@ sendDiagnostics nuri mv content = liftIO runPact >>= \case PEParseError{} -> "Parse" PEDesugarError{} -> "Desugar" PEExecutionError{} -> "Execution" - PERecoverableError{} -> "Execution" + PEUserRecoverableError{} -> "Execution" spanInfoToRange :: SpanInfo -> Range spanInfoToRange (SpanInfo sl sc el ec) = mkRange diff --git a/pact-tests/Pact/Core/Test/GasGolden.hs b/pact-tests/Pact/Core/Test/GasGolden.hs index 9d4816dd3..581054122 100644 --- a/pact-tests/Pact/Core/Test/GasGolden.hs +++ b/pact-tests/Pact/Core/Test/GasGolden.hs @@ -38,7 +38,7 @@ tests = do cases <- gasTestFiles pure $ testGroup "Gas Goldens" [ testCase "Capture all builtins" $ captureBuiltins (fst <$> cases) - , goldenVsStringDiff "Gas Goldens: CEK" runDiff (gasTestDir "builtinGas.golden") (gasGoldenTests cases interpretReplProgram) + , goldenVsStringDiff "Gas Goldens: CEK" runDiff (gasTestDir "builtinGas.golden") (gasGoldenTests cases interpretReplProgramBigStep) , goldenVsStringDiff "Gas Goldens: CEK smallstep" runDiff (gasTestDir "builtinGas.golden") (gasGoldenTests cases interpretReplProgramSmallStep) , goldenVsStringDiff "Gas Goldens: Direct" runDiff (gasTestDir "builtinGas.golden") (gasGoldenTests cases interpretReplProgramDirect) ] diff --git a/pact-tests/Pact/Core/Test/LegacySerialiseTests.hs b/pact-tests/Pact/Core/Test/LegacySerialiseTests.hs index c78025ea7..4f712c367 100644 --- a/pact-tests/Pact/Core/Test/LegacySerialiseTests.hs +++ b/pact-tests/Pact/Core/Test/LegacySerialiseTests.hs @@ -62,7 +62,7 @@ legacyTests = do Nothing -> error "Reading existing modules failed" Just ms -> do modTests <- fmap concat $ forM repl $ \r -> do - sequence [runTest r interpretReplProgram "CEK", runTest r interpretReplProgramDirect "Direct"] + sequence [runTest r interpretReplProgramBigStep "CEK", runTest r interpretReplProgramDirect "Direct"] pure (testGroup p modTests) where runTest r interpreter interpName = do diff --git a/pact-tests/Pact/Core/Test/PersistenceTests.hs b/pact-tests/Pact/Core/Test/PersistenceTests.hs index 739191f5d..c8c782d78 100644 --- a/pact-tests/Pact/Core/Test/PersistenceTests.hs +++ b/pact-tests/Pact/Core/Test/PersistenceTests.hs @@ -234,7 +234,7 @@ sqliteRegression = evalLog <- newIORef Nothing ee <- defaultEvalEnv pdb replCoreBuiltinMap ref <- newIORef (ReplState mempty pdb def ee evalLog (SourceCode "" "") mempty mempty Nothing False) - Right _ <- runReplT ref (interpretReplProgram (SourceCode "test" src) (const (pure ()))) + Right _ <- runReplT ref (interpretReplProgramBigStep (SourceCode "test" src) (const (pure ()))) Just md <- readModule pdb (ModuleName "test" Nothing) pure md diff --git a/pact-tests/Pact/Core/Test/ReplTests.hs b/pact-tests/Pact/Core/Test/ReplTests.hs index e7161747c..b381df1fa 100644 --- a/pact-tests/Pact/Core/Test/ReplTests.hs +++ b/pact-tests/Pact/Core/Test/ReplTests.hs @@ -41,8 +41,8 @@ tests :: IO TestTree tests = do files <- replTestFiles pure $ testGroup "ReplTests" - [ testGroup "in-memory db:bigstep" (runFileReplTest interpretReplProgram <$> files) - , testGroup "sqlite db:bigstep" (runFileReplTestSqlite interpretReplProgram <$> files) + [ testGroup "in-memory db:bigstep" (runFileReplTest interpretReplProgramBigStep <$> files) + , testGroup "sqlite db:bigstep" (runFileReplTestSqlite interpretReplProgramBigStep <$> files) , testGroup "in-memory db:smallstep" (runFileReplTest interpretReplProgramSmallStep <$> files) , testGroup "sqlite db:smallstep" (runFileReplTestSqlite interpretReplProgramSmallStep <$> files) , testGroup "in-memory db:direct" (runFileReplTest interpretReplProgramDirect <$> files) diff --git a/pact-tests/Pact/Core/Test/StaticErrorTests.hs b/pact-tests/Pact/Core/Test/StaticErrorTests.hs index 34801871d..91ee201ff 100644 --- a/pact-tests/Pact/Core/Test/StaticErrorTests.hs +++ b/pact-tests/Pact/Core/Test/StaticErrorTests.hs @@ -24,16 +24,19 @@ import Pact.Core.Serialise (serialisePact_repl_spaninfo) import Pact.Core.Test.TestPrisms isParseError :: Prism' ParseError a -> PactErrorI -> Bool -isParseError p s = isJust $ preview (_PEParseError . _1 . p) s +isParseError p s = has (_PEParseError . _1 . p) s isDesugarError :: Prism' DesugarError a -> PactErrorI -> Bool -isDesugarError p s = isJust $ preview (_PEDesugarError . _1 . p) s +isDesugarError p s = has (_PEDesugarError . _1 . p) s isExecutionError :: Prism' EvalError a -> PactErrorI -> Bool -isExecutionError p s = isJust $ preview (_PEExecutionError . _1 . p) s +isExecutionError p s = has (_PEExecutionError . _1 . p) s -runStaticTest :: String -> Text -> (PactErrorI -> Bool) -> Assertion -runStaticTest label src predicate = do +isUserRecoverableError :: Prism' UserRecoverableError a -> PactErrorI -> Bool +isUserRecoverableError p s = has (_PEUserRecoverableError . _1 . p) s + +runStaticTest :: String -> Text -> ReplInterpreter -> (PactErrorI -> Bool) -> Assertion +runStaticTest label src interp predicate = do gasLog <- newIORef Nothing pdb <- mockPactDb serialisePact_repl_spaninfo ee <- defaultEvalEnv pdb replCoreBuiltinMap @@ -51,7 +54,7 @@ runStaticTest label src predicate = do , _replNativesEnabled = True } stateRef <- newIORef rstate - v <- runReplT stateRef (interpretReplProgram source (const (pure ()))) + v <- runReplT stateRef (interpretReplProgram interp source (const (pure ()))) case v of Left err -> assertBool ("Expected Error to match predicate, but got " <> show err <> " instead") (predicate err) @@ -573,7 +576,7 @@ executionTests = (defun foo:string ()) ) |]) - , ("enforce_ns_define_namespace", isExecutionError _DefineNamespaceError, [text| + , ("enforce_ns_define_namespace", isExecutionError _NativeExecutionError, [text| (module m g (defcap g () true) (defun manage (ns guard) false) ) @@ -627,7 +630,7 @@ executionTests = , ("get_module_unknown", isExecutionError _ModuleDoesNotExist, [text| (describe-module 'nonexistent) |]) - , ("reexposed_module_missing_name", isExecutionError _NameNotInScope, [text| + , ("reexposed_module_missing_name", isExecutionError _ModuleMemberDoesNotExist, [text| (module m g (defcap g () true) @@ -650,15 +653,15 @@ executionTests = , ("module_gov_keyset_nonexistent", isExecutionError _NoSuchKeySet, [text| (module m 'nonexistent (defun f () true)) |]) - , ("module_gov_keyset_different", isExecutionError _EvalError, [text| + , ("module_gov_keyset_different", isUserRecoverableError _KeysetPredicateFailure, [text| (env-data {"ks":["jose"]}) (define-keyset 'somekeyset (read-keyset 'ks)) (module m 'somekeyset (defun f () 1)) |]) - , ("module_gov_keyset_empty", isExecutionError _ModuleGovernanceFailure, [text| + , ("module_gov_keyset_empty", isExecutionError _InvalidKeysetNameFormat, [text| (module m "" (defun f () true)) |]) - , ("module_gov_keyset_not_in_sigs", isExecutionError _EvalError, [text| + , ("module_gov_keyset_not_in_sigs", isUserRecoverableError _KeysetPredicateFailure, [text| (env-data { "kall": ["a" "b" "c"], "kadmin": ["admin"] }) (define-keyset 'kall) (define-keyset 'kadmin) @@ -678,7 +681,7 @@ executionTests = |]) -- CEK errors - , ("modref_no_ns", isExecutionError _ModRefNotRefined, [text| + , ("modref_no_ns", isExecutionError _ModRefImplementsNoInterfaces, [text| (module m g (defcap g () true)) m |]) @@ -1080,8 +1083,8 @@ builtinTests = , ("at_oob_bound", isExecutionError _ArrayOutOfBoundsException, "(at 3 [1 2 3])") , ("at_oob_smaller", isExecutionError _ArrayOutOfBoundsException, "(at -1 [1 2 3])") , ("at_oob_empty", isExecutionError _ArrayOutOfBoundsException, "(at 0 [])") - , ("at_key_missing", isExecutionError _EvalError, "(at 'bar { 'foo: 1 })") - , ("yield_outside", isExecutionError _YieldOutsiteDefPact, "(yield {})") + , ("at_key_missing", isExecutionError _ObjectIsMissingField, "(at 'bar { 'foo: 1 })") + , ("yield_outside", isExecutionError _YieldOutsideDefPact, "(yield {})") , ("resume_no_defpact", isExecutionError _NoActiveDefPactExec, "(resume { 'field := binder } binder)") , ("resume_no_yield", isExecutionError _NoYieldInDefPactStep, [text| (module m g (defcap g () true) @@ -1203,6 +1206,10 @@ builtinTests = tests :: TestTree tests = - testGroup "CoreStaticTests" (go <$> parseTests <> desugarTests <> executionTests <> builtinTests) + testGroup "CoreStaticTests" + [ testGroup "CoreStaticTests:CEK" (go interpretEvalBigStep <$> allTests) + , testGroup "CoreStaticTests:Direct" (go interpretEvalDirect <$> allTests) + ] where - go (label, p, srcText) = testCase label $ runStaticTest label srcText p + allTests = parseTests <> desugarTests <> executionTests <> builtinTests + go interp (label, p, srcText) = testCase label $ runStaticTest label srcText interp p diff --git a/pact-tests/Pact/Core/Test/TestPrisms.hs b/pact-tests/Pact/Core/Test/TestPrisms.hs index 894451e3b..2feffb6b2 100644 --- a/pact-tests/Pact/Core/Test/TestPrisms.hs +++ b/pact-tests/Pact/Core/Test/TestPrisms.hs @@ -10,4 +10,5 @@ makePrisms ''LexerError makePrisms ''ParseError makePrisms ''DesugarError makePrisms ''EvalError +makePrisms ''UserRecoverableError makePrisms ''PactError diff --git a/pact-tests/legacy-serial-tests/coin-v5/coin-v5.repl b/pact-tests/legacy-serial-tests/coin-v5/coin-v5.repl index 787bb16ed..dc737a859 100644 --- a/pact-tests/legacy-serial-tests/coin-v5/coin-v5.repl +++ b/pact-tests/legacy-serial-tests/coin-v5/coin-v5.repl @@ -421,7 +421,7 @@ (transfer 'emily 'doug 1.0)) (expect-failure "No account for will" - "no such read object" + "No value found in table coin:coin-table for key: will" (get-balance 'will)) (test-capability (TRANSFER 'doug 'will 1.0)) @@ -485,7 +485,7 @@ (env-data { "miner2": ["miner2"] }) (expect-failure "no account for miner2" - "no such read object" + "No value found in table coin:coin-table for key: miner2" (get-balance 'miner2)) (test-capability (COINBASE)) diff --git a/pact-tests/pact-tests/caps.repl b/pact-tests/pact-tests/caps.repl index 0822ca296..485851eac 100644 --- a/pact-tests/pact-tests/caps.repl +++ b/pact-tests/pact-tests/caps.repl @@ -814,7 +814,7 @@ (expect-failure "cap guard fails on wrong cap" - "Capability guard enforce failure cap not in scope" + "Capability not acquired" (test-cap-guard "A" "B")) (env-hash (hash 1)) @@ -831,7 +831,7 @@ (cg-pact 'k2 'k2 "D" "E") (expect-failure "cap pact guard fails on wrong cap" - "Capability guard enforce failure cap not in scope" + "Capability not acquired" (continue-pact 1)) (pact-state true) @@ -914,7 +914,7 @@ (expect-failure "out-of-band call fails" - "Capability guard enforce failure cap not in scope" + "Capability not acquired" (call-op1 "hello" 2)) (expect "normal case succeeds for both callees post-fork" diff --git a/pact-tests/pact-tests/coin-v1.repl b/pact-tests/pact-tests/coin-v1.repl index fc0a526f1..fd40e1dc2 100644 --- a/pact-tests/pact-tests/coin-v1.repl +++ b/pact-tests/pact-tests/coin-v1.repl @@ -422,7 +422,7 @@ (transfer 'emily 'doug 1.0)) (expect-failure "No account for will" - "no such read object" + "No value found in table coin:coin-table for key: will" (get-balance 'will)) (test-capability (TRANSFER 'doug 'will 1.0)) @@ -484,7 +484,7 @@ (env-data { "miner2": ["miner2"] }) (expect-failure "no account for miner2" - "no such read object" + "No value found in table coin:coin-table for key: miner2" (get-balance 'miner2)) (coinbase 'miner2 (read-keyset 'miner2) 1.0) diff --git a/pact-tests/pact-tests/coin-v5.repl b/pact-tests/pact-tests/coin-v5.repl index 71e766d87..4f3780ccc 100644 --- a/pact-tests/pact-tests/coin-v5.repl +++ b/pact-tests/pact-tests/coin-v5.repl @@ -435,7 +435,7 @@ (transfer 'emily 'doug 1.0)) (expect-failure "No account for will" - "no such read object" + "No value found in table coin:coin-table for key: will" (get-balance 'will)) (test-capability (TRANSFER 'doug 'will 1.0)) @@ -499,7 +499,7 @@ (env-data { "miner2": ["miner2"] }) (expect-failure "no account for miner2" - "no such read object" + "No value found in table coin:coin-table for key: miner2" (get-balance 'miner2)) (test-capability (COINBASE)) diff --git a/pact/Pact/Core/Builtin.hs b/pact/Pact/Core/Builtin.hs index 6630cef4f..ceca4e671 100644 --- a/pact/Pact/Core/Builtin.hs +++ b/pact/Pact/Core/Builtin.hs @@ -19,7 +19,7 @@ module Pact.Core.Builtin , IsBuiltin(..) , ReplCoreBuiltin , BuiltinForm(..) - , ReplBuiltins(..) + , ReplOnlyBuiltin(..) )where import Data.Text(Text) @@ -697,9 +697,8 @@ coreBuiltinMap = M.fromList | b <- [minBound .. maxBound] , b `notElem` coreBuiltinOverloads] --- Todo: rename -- | Our repl builtins. -data ReplBuiltins +data ReplOnlyBuiltin = RExpect | RExpectFailure | RExpectFailureMatch @@ -747,7 +746,7 @@ data ReplBuiltins deriving (Show, Enum, Bounded, Eq, Generic) -instance IsBuiltin ReplBuiltins where +instance IsBuiltin ReplOnlyBuiltin where builtinName = NativeName . replBuiltinsToText builtinArity = \case RExpect -> 3 @@ -798,7 +797,7 @@ instance IsBuiltin ReplBuiltins where -- to be implemented later data ReplBuiltin b = RBuiltinWrap b - | RBuiltinRepl ReplBuiltins + | RBuiltinRepl ReplOnlyBuiltin deriving (Eq, Show, Generic) -- NOTE: Maybe `ReplBuiltin` is not a great abstraction, given @@ -830,7 +829,7 @@ instance (Enum b, Bounded b) => Enum (ReplBuiltin b) where RBuiltinRepl rb -> maxContained + fromEnum rb {-# SPECIALIZE fromEnum :: ReplBuiltin CoreBuiltin -> Int #-} -replBuiltinsToText :: ReplBuiltins -> Text +replBuiltinsToText :: ReplOnlyBuiltin -> Text replBuiltinsToText = \case RExpect -> "expect" RExpectFailure -> "expect-failure" @@ -904,8 +903,10 @@ replCoreBuiltinMap = , let !txtRepr = replCoreBuiltinToText b] --- Todo: is not a great abstraction. --- In particular: the arity could be gathered from the type. +-- | A typeclass for general information about pact builtins, mostly +-- useful for runtime native information and for error messages. Note that +-- builtinArity only has 1 value per builtin, meaning overload resolution must +-- happen before using `builtinArity` to check for app saturation. class Show b => IsBuiltin b where builtinArity :: b -> Int builtinName :: b -> NativeName diff --git a/pact/Pact/Core/Capabilities.hs b/pact/Pact/Core/Capabilities.hs index 80471e14a..3b5c3c9f8 100644 --- a/pact/Pact/Core/Capabilities.hs +++ b/pact/Pact/Core/Capabilities.hs @@ -107,8 +107,10 @@ data CapState name v instance (Ord name, Ord v) => Default (CapState name v) where def = CapState mempty mempty mempty mempty mempty --- Todo: Is there a reason why module + name is --- an unqualified +-- | Our pact event type. +-- Note: the name + module are isomorphic to a +-- QualifiedName, but it is kept in this format currently for +-- ease of legacy integration data PactEvent v = PactEvent { _peName :: Text @@ -163,6 +165,9 @@ data Signer name v = Signer -- ^ clist for designating signature to specific caps } deriving (Eq, Ord, Show, Generic) +instance (Pretty name, Pretty v) => Pretty (CapToken name v) where + pretty (CapToken qn args) = + pretty $ PrettyLispApp qn args instance (NFData name, NFData v) => NFData (Signer name v) instance (NFData name, NFData e) => NFData (CapForm name e) diff --git a/pact/Pact/Core/Compile.hs b/pact/Pact/Core/Compile.hs index 3563f11c7..1127ac731 100644 --- a/pact/Pact/Core/Compile.hs +++ b/pact/Pact/Core/Compile.hs @@ -89,7 +89,6 @@ enforceNamespaceInstall info interpreter = useEvalState (esLoaded . loNamespace) >>= \case Just ns -> void $ interpretGuard interpreter info (_nsUser ns) - -- Eval.interpretGuard info bEnv (_nsUser ns) Nothing -> enforceRootNamespacePolicy where diff --git a/pact/Pact/Core/DefPacts/Types.hs b/pact/Pact/Core/DefPacts/Types.hs index e062675f5..bbdf4f8dd 100644 --- a/pact/Pact/Core/DefPacts/Types.hs +++ b/pact/Pact/Core/DefPacts/Types.hs @@ -23,6 +23,7 @@ import Pact.Core.PactValue import Pact.Core.Names import Pact.Core.Hash import Pact.Core.ChainData +import Pact.Core.Pretty data DefPactContinuation name v = DefPactContinuation @@ -42,6 +43,10 @@ data Provenance = Provenance -- ^ a hash of current containing module } deriving (Eq, Show, Generic) +instance Pretty Provenance where + pretty (Provenance (ChainId cid) mh) = + parens $ + "Provenance" <+> pretty cid <+> pretty mh -- | `Yield` representing an object data Yield @@ -79,3 +84,7 @@ instance NFData Yield instance NFData DefPactStep instance (NFData name, NFData v) => NFData (DefPactContinuation name v) instance NFData DefPactExec + +instance (Pretty name, Pretty v) => Pretty (DefPactContinuation name v) where + pretty (DefPactContinuation n v) = + pretty $ PrettyLispApp n v diff --git a/pact/Pact/Core/Environment/Utils.hs b/pact/Pact/Core/Environment/Utils.hs index 8ab2a106c..8c43aec9c 100644 --- a/pact/Pact/Core/Environment/Utils.hs +++ b/pact/Pact/Core/Environment/Utils.hs @@ -20,14 +20,15 @@ module Pact.Core.Environment.Utils , lookupModule , lookupModuleData , throwExecutionError - , throwExecutionError' - , throwRecoverableError , toFqDep , mangleNamespace , getAllStackCaps , checkSigCaps , allModuleExports , liftDbFunction + , throwUserRecoverableError + , throwUserRecoverableError' + , throwNativeExecutionError ) where import Control.Lens @@ -36,7 +37,6 @@ import Control.Monad.Except import Control.Exception import Control.Monad.IO.Class(MonadIO(..)) import Data.Text(Text) -import Data.Default import Data.Maybe(mapMaybe) import qualified Data.Map.Strict as M import qualified Data.Set as S @@ -51,6 +51,7 @@ import Pact.Core.Namespace import Pact.Core.Guards import Pact.Core.Capabilities import Pact.Core.PactValue +import Pact.Core.Builtin viewEvalEnv :: (MonadEvalEnv b i m) => Lens' (EvalEnv b i) s -> m s viewEvalEnv l = view l <$> readEnv @@ -100,16 +101,22 @@ liftDbFunction info action = do Left dbopErr -> throwExecutionError info (DbOpFailure dbopErr) Right e -> pure e +throwUserRecoverableError :: (MonadError (PactError info) m, MonadEvalState b info m) => info -> UserRecoverableError -> m a +throwUserRecoverableError i err = do + st <- useEvalState esStack + throwUserRecoverableError' i st err + +throwUserRecoverableError' :: MonadError (PactError info) m => info -> [StackFrame info] -> UserRecoverableError -> m a +throwUserRecoverableError' info stack err = throwError (PEUserRecoverableError err stack info) + throwExecutionError :: (MonadEvalState b i m, MonadError (PactError i) m) => i -> EvalError -> m a throwExecutionError i e = do st <- useEvalState esStack throwError (PEExecutionError e st i) -throwRecoverableError :: MonadEval b i m => i -> Text -> m a -throwRecoverableError i e = throwError (PERecoverableError (RecoverableError e) i) - -throwExecutionError' :: (MonadEvalState b i m, MonadError (PactError i) m, Default i) => EvalError -> m a -throwExecutionError' = throwExecutionError def +throwNativeExecutionError :: (MonadEvalState b i m, MonadError (PactError i) m, IsBuiltin b) => i -> b -> Text -> m a +throwNativeExecutionError info b msg = + throwExecutionError info (NativeExecutionError (builtinName b) msg) -- | lookupModuleData for only modules lookupModule :: (MonadEval b i m) => i -> PactDb b i -> ModuleName -> m (Maybe (EvalModule b i)) @@ -170,7 +177,7 @@ getModuleMember info pdb (QualifiedName qn mn) = do Just d -> pure d Nothing -> do let fqn = FullyQualifiedName mn qn (_mHash md) - throwExecutionError info (NameNotInScope fqn) + throwExecutionError info (ModuleMemberDoesNotExist fqn) getModuleMemberWithHash :: (MonadEval b i m) => i -> PactDb b i -> QualifiedName -> m (EvalDef b i, ModuleHash) getModuleMemberWithHash info pdb (QualifiedName qn mn) = do @@ -179,7 +186,7 @@ getModuleMemberWithHash info pdb (QualifiedName qn mn) = do Just d -> pure (d, _mHash md) Nothing -> do let fqn = FullyQualifiedName mn qn (_mHash md) - throwExecutionError info (NameNotInScope fqn) + throwExecutionError info (ModuleMemberDoesNotExist fqn) mangleNamespace :: (MonadEvalState b i m) => ModuleName -> m ModuleName diff --git a/pact/Pact/Core/Errors.hs b/pact/Pact/Core/Errors.hs index e726b94af..bc8bf49bb 100644 --- a/pact/Pact/Core/Errors.hs +++ b/pact/Pact/Core/Errors.hs @@ -3,30 +3,36 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} module Pact.Core.Errors ( PactErrorI , LexerError(..) , ParseError(..) , DesugarError(..) + , InvariantError(..) , EvalError(..) , PactError(..) , ArgTypeError(..) , DbOpException(..) - , RecoverableError(..) , peInfo , viewErrorStack + , UserRecoverableError(..) ) where import Control.Lens hiding (ix) import Control.Exception import Data.Text(Text) import Data.Dynamic (Typeable) +import Data.Set(Set) import qualified Data.Version as V import qualified PackageInfo_pact_tng as PI +import qualified Data.Set as S +import qualified Data.Text as T import Control.DeepSeq import GHC.Generics @@ -40,6 +46,9 @@ import Pact.Core.Pretty as Pretty import Pact.Core.Hash import Pact.Core.StackFrame import Pact.Core.DefPacts.Types +import Pact.Core.PactValue +import Pact.Core.Capabilities +import Pact.Core.Verifiers type PactErrorI = PactError SpanInfo @@ -137,21 +146,29 @@ data DesugarError | InvalidModuleReference ModuleName -- ^ Invalid: Interface used as module reference | EmptyBindingBody - -- + -- ^ Binding form has no expressions to bind to | EmptyDefPact Text -- ^ Defpact without steps | LastStepWithRollback QualifiedName -- ^ Last Step has Rollback error | ExpectedFreeVariable Text + -- ^ Expected free variable for ident | InvalidManagedArg Text - | InvalidImports [Text] + -- ^ Invalid @managed argument, there is no named argument with name + | InvalidImports ModuleName [Text] + -- ^ Imports for do not exist | InvalidImportModuleHash ModuleName ModuleHash -- ^ Expected free variable | InvalidSyntax Text + -- ^ Desugaring failed on invalid syntactic transformation (e.g within `cond`) | InvalidDefInSchemaPosition Text - | InvalidDynamicInvoke Text - | DuplicateDefinition Text + -- ^ Found a non-defschema in a type name position + | InvalidDynamicInvoke DynamicName + -- ^ Dynamic invoke is invalid + | DuplicateDefinition QualifiedName + -- ^ Name was defined twice | InvalidBlessedHash Text + -- ^ Blessed hash has invalid format deriving (Show, Generic) instance NFData DesugarError @@ -202,17 +219,27 @@ instance Pretty DesugarError where ExpectedFreeVariable t -> Pretty.hsep ["Expected free variable in expression, found locally bound: ", pretty t] -- Todo: pretty these - e@InvalidManagedArg{} -> pretty (show e) - e@NotImplemented{} -> pretty (show e) - e@InvalidImports{} -> pretty (show e) - e@InvalidImportModuleHash{} -> pretty (show e) - -- todo: maybe this is a syntaxError??? - e@InvalidSyntax{} -> pretty (show e) - e@InvalidDefInSchemaPosition{} -> pretty (show e) - e@InvalidDynamicInvoke{} -> pretty (show e) - e@DuplicateDefinition{} -> pretty (show e) - e@InvalidBlessedHash{} -> pretty (show e) - -- e -> pretty (show e) + InvalidManagedArg arg -> + "Invalid Managed arg: no such arg with name" <+> pretty arg + NotImplemented mn ifn ifdn -> + "Interface member not implemented, module" <+> pretty mn <+> "does not implement interface" + <+> pretty ifn <+> "member:" <+> pretty ifdn + InvalidImports mn imps -> + "Invalid imports, module or interface" <+> pretty mn <+> "does not implement the following members:" + <+> pretty imps + InvalidImportModuleHash mn mh -> + "Import error for module" <+> pretty mn <+> ", hash not blessed:" + <+> pretty mh + InvalidSyntax msg -> + "Desugar syntax failure:" <+> pretty msg + InvalidDefInSchemaPosition n -> + "Invalid def in defschema position:" <+> pretty n <+> "is not a valid schema" + InvalidDynamicInvoke dn -> + "Invalid dynamic call:" <+> pretty dn + DuplicateDefinition qn -> + "Duplicate definition:" <+> pretty qn + InvalidBlessedHash hs -> + "Invalid blessed hash, incorrect format:" <+> pretty hs -- | Argument type mismatch meant for errors -- that does not force you to show the whole PactValue @@ -236,6 +263,80 @@ instance Pretty ArgTypeError where ATEClosure -> "closure" ATEModRef -> "modref" +data InvariantError + = InvariantInvalidDefKind DefKind Text + -- ^ An illegal `def` form was found in a term variable position + -- | InvariantNameNotInScope FullyQualifiedName + -- ^ Unbound free + | InvariantDefConstNotEvaluated FullyQualifiedName + -- ^ Defconst found but was not evaluated + -- note this is an invariant failure because evaluating a defconst term during + -- regular runtime execution has different semantics to pre-evaluating it. + | InvariantExpectedDefCap FullyQualifiedName + -- ^ Expected a defcap in some position (e.g evalCAp) + | InvariantExpectedDefun FullyQualifiedName + -- ^ Expected a defun in some position (e.g user managed cap) + | InvariantExpectedDefPact FullyQualifiedName + -- ^ Expected a defcap in some position (e.g applyPact) + | InvariantInvalidBoundVariable Text + -- ^ Bound variable has no accompanying binder + | InvariantUnboundFreeVariable FullyQualifiedName + -- ^ Unbound free variable + | InvariantMalformedDefun FullyQualifiedName + -- ^ Defun term is malformed somehow (e.g no bound variables at all, not a nullary closure) + | InvariantPactExecNotInEnv (Maybe (DefPactContinuation QualifiedName PactValue)) + -- ^ Defpact Exec expected to be in environment but not found + | InvariantPactStepNotInEnv (Maybe (DefPactContinuation QualifiedName PactValue)) + -- ^ Defpact Exec expected to be in environment but not found + | InvariantInvalidManagedCapIndex Int FullyQualifiedName + -- ^ managed cap index outside of allowable range + | InvariantArgLengthMismatch FullyQualifiedName Int Int + -- ^ Argument length mismatch within some internal function + | InvariantInvalidManagedCapKind Text + -- ^ Invariant managed cap kind, expected, got + | InvariantNoSuchKeyInTable TableName RowKey + -- ^ Keys were pulled from the table (e.g select, fold-db) but + -- there was no corresponding entry + | InvariantEmptyCapStackFailure + -- ^ Attempted to pop or manipulate the capstack, but it was found to be empty + deriving (Eq, Show, Generic) + +instance NFData InvariantError + +instance Pretty InvariantError where + pretty = \case + InvariantInvalidDefKind dk t -> + "Invalid def kind, received" <+> pretty dk <+> pretty t + InvariantDefConstNotEvaluated fqn -> + "Defconst was not evaluated prior to execution:" <+> pretty fqn + InvariantExpectedDefCap fqn -> + "Expected a defcap for free variable" <+> pretty fqn + InvariantExpectedDefun fqn -> + "Expected a defun for free variable" <+> pretty fqn + InvariantExpectedDefPact fqn -> + "Expected a defpact for free variable" <+> pretty fqn + InvariantUnboundFreeVariable fqn -> + "Unbound free variable" <+> pretty fqn + InvariantInvalidBoundVariable v -> + "Invalid bound or free variable:" <+> pretty v + InvariantMalformedDefun dfn -> + "Malformed defun: Body is not a lambda" <+> pretty dfn + InvariantPactExecNotInEnv loc -> + "No pact exec found" <+> pretty loc + InvariantPactStepNotInEnv loc -> + "No pact stepfound" <+> pretty loc + InvariantInvalidManagedCapIndex i fqn -> + "Invalid managed cap argument index" <+> pretty i <+> "for function" <+> pretty fqn + InvariantArgLengthMismatch fqn expected got -> + "Argument length mismatch for" <+> pretty fqn <> ", expected" <+> pretty expected <> ", got" + <+> pretty got + InvariantInvalidManagedCapKind msg -> + "Invalid managed cap kind" <+> pretty msg + InvariantNoSuchKeyInTable tbl (RowKey rk) -> + "No such key" <+> pretty rk <+> "in table" <+> pretty tbl + InvariantEmptyCapStackFailure -> + "Attempted to pop or manipulate the capstack, but it was found to be empty" + -- | All fatal execution errors which should pause -- @@ -254,38 +355,31 @@ data EvalError -- ^ Floating point operation exception | CapNotInScope Text -- ^ Capability not in scope - | InvariantFailure Text + | InvariantFailure InvariantError -- ^ Invariant violation in execution. This is a fatal Error. | EvalError Text -- ^ Error raised by the program that went unhandled | NativeArgumentsError NativeName [ArgTypeError] -- ^ Error raised: native called with the wrong arguments - | ModRefNotRefined Text -- ^ Module reference not refined to a value - | InvalidDefKind DefKind Text - -- ^ Def used in method has wrong type + reason - | NoSuchDef FullyQualifiedName - -- ^ Could not find a definition with the above name | InvalidManagedCap FullyQualifiedName -- ^ Name does not point to a managed capability - | CapNotInstalled FullyQualifiedName + | CapNotInstalled (CapToken QualifiedName PactValue) -- ^ Capability not installed - | CapAlreadyInstalled FullyQualifiedName + | CapAlreadyInstalled (CapToken QualifiedName PactValue) -- ^ Capability already installed - | NameNotInScope FullyQualifiedName + | ModuleMemberDoesNotExist FullyQualifiedName -- ^ Name not found in the top level environment - | DefIsNotClosure Text - -- ^ Def is not a closure | NoSuchKeySet KeySetName -- ^ No such keyset - | YieldOutsiteDefPact + | YieldOutsideDefPact -- ^ Yield a value outside a running DefPactExec | NoActiveDefPactExec -- ^ No Active DefPactExec in the environment | NoYieldInDefPactStep DefPactStep -- ^ No Yield available in DefPactStep - | InvalidDefPactStepSupplied DefPactStep DefPactExec - -- ^ Supplied DefPactStep requests an invalid step + | InvalidDefPactStepSupplied DefPactStep Int + -- ^ Supplied DefPactStep requests an invalid step, stepCount | DefPactIdMismatch DefPactId DefPactId -- ^ Requested PactId does not match context PactId | CCDefPactContinuationError DefPactStep DefPactExec DefPactExec @@ -317,36 +411,95 @@ data EvalError -- ^ DefPact missmatch | CannotUpgradeInterface ModuleName -- ^ Interface cannot be upgrade - | ModuleGovernanceFailure ModuleName - -- ^ Failed to acquire module governance | DbOpFailure DbOpException - -- ^ DynName is not a module ref + -- ^ Db operation failure | DynNameIsNotModRef Text + -- ^ Dynamic name does not point to a module reference | ModuleDoesNotExist ModuleName + -- ^ Module was not found in the db nor in the environment | ExpectedModule ModuleName - -- ^ Module does not exist + -- ^ Expected Module, found interface | HashNotBlessed ModuleName ModuleHash + -- ^ Hash not blessed for at | CannotApplyPartialClosure + -- ^ Intentional nerf to partially applied closures + -- outside of native code | ClosureAppliedToTooManyArgs + -- ^ Closure called with too many arguments | FormIllegalWithinDefcap Text + -- ^ Invalid function within a defcap | RunTimeTypecheckFailure ArgTypeError Type + -- ^ Runtime TC failure, note: ArgTypeError simply allows us to + -- abbreviate the type of the argument, instead of fully syntesizing it | NativeIsTopLevelOnly NativeName + -- ^ Native called within module scope | EventDoesNotMatchModule ModuleName + -- ^ Emitted event does not match the emitting module, or + -- is called outside of module | InvalidEventCap FullyQualifiedName + -- ^ Capability is not @event or @managed, thus it should not be able + -- to emit an event | NestedDefpactsNotAdvanced DefPactId + -- ^ Nested defpact not advanced. Note: All nested defpacts + -- semantically must be advanced in lockstep. That is, for some defpact execution at + -- step n, all nested defpacts prior to execution at step (n-1) should also be advanced to + -- step n at the end of execution | ExpectedPactValue + -- ^ Expected a pact value, received a closure or table reference | NotInDefPactExecution + -- ^ Expected function to be called within a defpact. E.g (pact-id) | NamespaceInstallError Text - | DefineNamespaceError Text - -- ^ Non-recoverable guard enforces. + -- ^ Error installing namespace | PointNotOnCurve + -- ^ Pairing-related: Point lies outside of elliptic curve | YieldProvenanceDoesNotMatch Provenance [Provenance] + -- ^ Yield provenance mismatch | MismatchingKeysetNamespace NamespaceName + -- ^ Keyset declared outside of relevant namespace | EnforcePactVersionFailure V.Version (Maybe V.Version) + -- ^ Pact version fails | EnforcePactVersionParseFailure Text + -- ^ Pact version parsing error | RuntimeRecursionDetected QualifiedName + -- ^ Attempted to call recursively | SPVVerificationFailure Text + -- ^ Failure in SPV verification | ContinuationError Text + -- ^ Failure in evalContinuation (chainweb) + | ModRefImplementsNoInterfaces ModuleName + -- ^ Attempted to use a module as a modref, despite + -- implementing no interfaces + | UserGuardMustBeADefun QualifiedName DefKind + -- ^ User guard closure must refer to a defun + | ExpectedBoolValue PactValue + -- ^ Expected a boolean result in evaluation + -- (e.g if, or, and) + | ExpectedStringValue PactValue + -- ^ Expected a string value during evaluation + -- (e.g enforce) + | ExpectedCapToken PactValue + -- ^ Expected a string value during evaluation + -- (e.g enforce) + | WriteValueDidNotMatchSchema Schema (ObjectData PactValue) + -- ^ Attempted to write a value to the database that does not match + -- the database's schema + | ObjectIsMissingField Field (ObjectData PactValue) + -- ^ Object access is missing a field + | InvalidKeysetFormat KeySet + -- ^ Keyset format validation failure (e.g ED25519Hex or Webauthn) + | InvalidKeysetNameFormat Text + -- ^ define-keyset name invalid format + | CannotDefineKeysetOutsideNamespace + -- ^ User attempted define a keyset outside of a namespace + | NamespaceNotFound NamespaceName + -- ^ Namespace not found in pactdb + | NativeExecutionError NativeName Text + -- ^ Native execution error, with reason + | OperationIsLocalOnly NativeName + -- ^ Native function is local-only + | CannotApplyValueToNonClosure + -- ^ Attempted to apply a non-closure + | InvalidCustomKeysetPredicate Text deriving (Show, Generic) instance NFData EvalError @@ -373,23 +526,23 @@ instance Pretty EvalError where Pretty.hsep ["Capability not in scope:", pretty txt] GasExceeded (MilliGasLimit (milliGasToGas -> Gas limit)) (milliGasToGas -> Gas amt) -> "Gas Limit:" <+> parens (pretty limit) <+> "exceeded:" <+> pretty amt - InvariantFailure txt -> - Pretty.hsep ["Fatal execution error, invariant violated:", pretty txt] - NativeArgumentsError (NativeName n) tys -> + InvariantFailure msg -> + Pretty.hsep ["Fatal execution error, invariant violated:", pretty msg] + NativeArgumentsError n tys -> Pretty.hsep ["Native evaluation error for native", pretty n <> ",", "received incorrect argument(s) of type(s)", Pretty.commaSep tys] EvalError txt -> Pretty.hsep ["Program encountered an unhandled raised error:", pretty txt] - YieldOutsiteDefPact -> + YieldOutsideDefPact -> "Try to yield a value outside a running DefPact execution" NoActiveDefPactExec -> "No active DefPact execution in the environment" NoYieldInDefPactStep (DefPactStep step _ i _) -> Pretty.hsep ["No yield in DefPactStep:", "Step: " <> pretty step, "DefPactId: " <> pretty i] - InvalidDefPactStepSupplied (DefPactStep step _ _ _) pe -> + InvalidDefPactStepSupplied (DefPactStep step _ _ _) stepCount -> Pretty.hsep [ "DefPactStep does not match DefPact properties:" , "requested: "<> pretty step - , "step count:" <> pretty (_peStepCount pe)] + , "step count:" <> pretty stepCount] DefPactIdMismatch reqId envId -> Pretty.hsep [ "Requested DefPactId:", pretty reqId @@ -451,40 +604,93 @@ instance Pretty EvalError where , "Could not parse " <> pretty str <> ", expect list of dot-separated integers" ] -- Todo: Fix each case - e@ModRefNotRefined{} -> pretty (show e) - e@InvalidDefKind{} -> pretty (show e) - e@NoSuchDef{} -> pretty (show e) - e@InvalidManagedCap{} -> pretty (show e) - e@CapNotInstalled{} -> pretty (show e) - e@CapAlreadyInstalled{} -> pretty (show e) - e@NameNotInScope{} -> pretty (show e) - e@DefIsNotClosure{} -> pretty (show e) - e@NoSuchKeySet{} -> pretty (show e) - e@CannotUpgradeInterface{} -> pretty (show e) - e@ModuleGovernanceFailure{} -> pretty (show e) - e@DbOpFailure{} -> pretty (show e) - e@DynNameIsNotModRef{} -> pretty (show e) - e@ModuleDoesNotExist{} -> pretty (show e) - e@ExpectedModule{} -> pretty (show e) - e@HashNotBlessed{} -> pretty (show e) - e@CannotApplyPartialClosure{} -> pretty (show e) - e@ClosureAppliedToTooManyArgs{} -> pretty (show e) - e@FormIllegalWithinDefcap{} -> pretty (show e) - e@RunTimeTypecheckFailure{} -> pretty (show e) - e@NativeIsTopLevelOnly{} -> pretty (show e) - e@EventDoesNotMatchModule{} -> pretty (show e) - e@InvalidEventCap{} -> pretty (show e) - e@NestedDefpactsNotAdvanced{} -> pretty (show e) - e@ExpectedPactValue{} -> pretty (show e) - e@NotInDefPactExecution{} -> pretty (show e) - e@NamespaceInstallError{} -> pretty (show e) - e@DefineNamespaceError{} -> pretty (show e) - e@PointNotOnCurve{} -> pretty (show e) - e@YieldProvenanceDoesNotMatch{} -> pretty (show e) - e@MismatchingKeysetNamespace{} -> pretty (show e) - e@RuntimeRecursionDetected{} -> pretty (show e) - e@SPVVerificationFailure{} -> pretty (show e) - e@ContinuationError{} -> pretty (show e) + InvalidManagedCap fqn -> + "Install capability error: capability is not managed and cannot be installed:" <+> pretty (fqnToQualName fqn) + CapNotInstalled cap -> + "Capability not installed:" <+> pretty cap + CapAlreadyInstalled cap -> + "Capability already installed:" <+> pretty cap + ModuleMemberDoesNotExist fqn -> + "Module member does not exist" <+> pretty fqn + NoSuchKeySet ksn -> + "Cannot find keyset in database:" <+> pretty ksn + CannotUpgradeInterface ifn -> + "Interface cannot be upgraded:" <+> pretty ifn + + DbOpFailure dbe -> + "Error during database operation:" <+> pretty dbe + DynNameIsNotModRef n -> + "Attempted to use" <+> pretty n <+> "as dynamic name, but it is not a modref" + ModuleDoesNotExist m -> + "Cannot find module:" <+> pretty m + ExpectedModule mn -> + "Expected module, found interface:" <+> pretty mn + HashNotBlessed mn hs -> + "Execution aborted, hash not blessed for module" <+> pretty mn <> ":" <+> pretty hs + CannotApplyPartialClosure -> + "Attempted to apply a closure outside of native callsite" + ClosureAppliedToTooManyArgs -> + "Attempted to apply a closure to too many arguments" + FormIllegalWithinDefcap msg -> + "Form illegal within defcap" <+> pretty msg + RunTimeTypecheckFailure argErr ty -> + "Runtime typecheck failure, argument is" <+> pretty argErr <+> ", but expected type" <+> pretty ty + NativeIsTopLevelOnly b -> + "Top-level call used in module" <+> pretty b + EventDoesNotMatchModule mn -> + "Emitted event does not match module" <+> pretty mn + InvalidEventCap fqn -> + "Invalid event capability" <+> pretty fqn + NestedDefpactsNotAdvanced dpid -> + "Nested defpacts not advanced" <+> pretty dpid + ExpectedPactValue -> + "Expected Pact Value, got closure or table reference" + NotInDefPactExecution -> "not in pact execution" + NamespaceInstallError e -> + "Namespace installation error:" <+> pretty e + PointNotOnCurve -> + "Point lies outside of ellptic curve" + YieldProvenanceDoesNotMatch received expected -> + "Yield provenance does not match, received" <+> pretty received <> ", expected" <+> pretty expected + MismatchingKeysetNamespace ns -> + "Error defining keyset, namespace mismatch, expected " <> pretty ns + RuntimeRecursionDetected qn -> + "Runtime recursion detected in function:" <+> pretty qn + SPVVerificationFailure e -> + "SPV verification failure:" <+> pretty e + ExpectedBoolValue pv -> + "expected bool value, got" <+> pretty pv + UserGuardMustBeADefun qn dk -> + "User guard closure" <+> pretty qn <+> "must be defun, got" <> pretty dk + WriteValueDidNotMatchSchema (Schema _ sc) od -> + "Attempted insert failed due to schema mismatch. Expected:" <+> pretty (ObjectData sc) + <> ", received" <+> pretty od + ObjectIsMissingField f b -> + "Key" <+> dquotes (pretty f) <+> "not found in object:" <+> pretty b + NativeExecutionError n msg -> + "native execution failure," <+> pretty n <+> "failed with message:" <+> pretty msg + ExpectedStringValue pv -> + "expected string value, got:" <+> pretty pv + ExpectedCapToken pv -> + "expected capability token value, got:" <+> pretty pv + InvalidKeysetFormat ks -> + "Invalid keyset format:" <+> pretty ks + InvalidKeysetNameFormat ksn -> + "Invalid keyset name format:" <+> pretty ksn + CannotDefineKeysetOutsideNamespace -> + "Cannot define keyset outside of a namespace" + NamespaceNotFound nsn -> + "Module not found:" <+> pretty nsn + ModRefImplementsNoInterfaces mn -> + "Invalid modref, module" <+> pretty mn <+> "implements no interfaces" + ContinuationError msg -> + "Continuation Error:" <+> pretty msg + OperationIsLocalOnly n -> + "Operation only permitted in local execution mode:" <+> pretty n + CannotApplyValueToNonClosure -> + "Cannot apply value to non-closure" + InvalidCustomKeysetPredicate pn -> + "Invalid custom predicate for keyset" <+> pretty pn instance Exception EvalError @@ -497,7 +703,6 @@ data DbOpException | TableAlreadyExists TableName | TxAlreadyBegun Text | NoTxToCommit - | NoTxLog TableName Text | OpDisallowed | MultipleRowsReturnedFromSingleWrite deriving (Show, Eq, Typeable, Generic) @@ -506,17 +711,74 @@ instance NFData DbOpException instance Exception DbOpException -data RecoverableError - = RecoverableError Text - deriving (Show, Typeable, Generic) - -instance Exception RecoverableError - -instance Pretty RecoverableError where +instance Pretty DbOpException where pretty = \case - RecoverableError txt -> pretty txt - -instance NFData RecoverableError + WriteException -> + "Error found while writing value" + RowFoundException tn rk -> + "Value already found while in Insert mode in table" <+> pretty tn <+> "at key" <+> dquotes (pretty rk) + NoRowFound tn rk -> + "No row found during update in table" <+> pretty tn <+> "at key" <+> pretty rk + NoSuchTable tn -> + "Table" <+> pretty tn <+> "not found" + TableAlreadyExists tn -> + "Table" <+> pretty tn <+> "already exists" + TxAlreadyBegun tx -> + "Attempted to begin tx" <+> dquotes (pretty tx) <> ", but a tx already has been initiated" + NoTxToCommit -> + "No Transaction to commit" + OpDisallowed -> + "Operation disallowed in read-only or sys-only mode" + MultipleRowsReturnedFromSingleWrite -> + "Multiple rows returned from single write" + + + +data UserRecoverableError + = UserEnforceError Text + -- ^ Errors produced by `enforce` or `enforceOne` + | OneShotCapAlreadyUsed + -- ^ A one-shot capability has already been fired + | CapabilityNotGranted (CapToken QualifiedName PactValue) + -- ^ Capability not granted in require-cap + | NoSuchObjectInDb TableName RowKey + -- ^ Did not find an object in the specified table for some rowkey + | KeysetPredicateFailure KSPredicate (Set PublicKeyText) + -- ^ Keyset Predicate failed for some reason + | CapabilityPactGuardInvalidPactId DefPactId DefPactId + -- ^ Mismatching pact ID's in capability guard + | EnvReadFunctionFailure NativeName + -- ^ read-* function failure + | VerifierFailure VerifierName Text + -- ^ Verifier failure + | CapabilityGuardNotAcquired (CapabilityGuard QualifiedName PactValue) + deriving (Show, Eq, Generic, Typeable) + +instance NFData UserRecoverableError +instance Exception UserRecoverableError + +instance Pretty UserRecoverableError where + pretty = \case + UserEnforceError t -> pretty t + OneShotCapAlreadyUsed -> "Automanaged capability used more than once" + CapabilityNotGranted ct -> + "require-capability: not granted:" <+> parens (pretty (_ctName ct)) + NoSuchObjectInDb tn (RowKey rk) -> + "No value found in table" <+> pretty tn <+> "for key:" <+> pretty rk + KeysetPredicateFailure ksPred kskeys -> + "Keyset failure (" <> pretty ksPred <> "): " + <> pretty (map (elide . renderPublicKeyText) $ S.toList kskeys) + where + elide pk = T.take 8 pk <> "..." + CapabilityPactGuardInvalidPactId currPid pgId -> + "Capability pact guard failed: invalid pact id, expected" <+> pretty pgId <+> "got" + <+> pretty currPid + EnvReadFunctionFailure desc -> + pretty desc <+> "failure" + VerifierFailure (VerifierName verif) msg -> + "Verifier failure" <+> pretty verif <> ":" <+> pretty msg + CapabilityGuardNotAcquired cg -> + "Capability not acquired:" <+> pretty cg data PactError info = PELexerError LexerError info @@ -525,7 +787,7 @@ data PactError info -- | PETypecheckError TypecheckError info -- | PEOverloadError OverloadError info | PEExecutionError EvalError [StackFrame info] info - | PERecoverableError RecoverableError info + | PEUserRecoverableError UserRecoverableError [StackFrame info] info deriving (Show, Functor, Generic) instance NFData info => NFData (PactError info) @@ -537,7 +799,8 @@ instance Pretty (PactError info) where PEDesugarError e _ -> pretty e PEExecutionError e _ _ -> pretty e - PERecoverableError e _ -> pretty e + PEUserRecoverableError e _ _ -> + pretty e peInfo :: Lens (PactError info) (PactError info) info info peInfo f = \case @@ -549,12 +812,13 @@ peInfo f = \case PEDesugarError de <$> f info PEExecutionError ee stack info -> PEExecutionError ee stack <$> f info - PERecoverableError ee info -> - PERecoverableError ee <$> f info + PEUserRecoverableError ee stack info -> + PEUserRecoverableError ee stack <$> f info viewErrorStack :: PactError info -> [StackFrame info] viewErrorStack = \case PEExecutionError _ stack _ -> stack + PEUserRecoverableError _ stack _ -> stack _ -> [] instance (Show info, Typeable info) => Exception (PactError info) diff --git a/pact/Pact/Core/Hash.hs b/pact/Pact/Core/Hash.hs index 05ee2e8d5..4d44b9e7b 100644 --- a/pact/Pact/Core/Hash.hs +++ b/pact/Pact/Core/Hash.hs @@ -136,6 +136,9 @@ newtype ModuleHash = ModuleHash { _mhHash :: Hash } deriving (Eq, Ord, Show, Generic) deriving newtype (NFData) +instance Pretty ModuleHash where + pretty (ModuleHash h) = pretty h + placeholderHash :: ModuleHash placeholderHash = ModuleHash (Hash "#placeholder") diff --git a/pact/Pact/Core/IR/ConstEval.hs b/pact/Pact/Core/IR/ConstEval.hs index e3c45fb38..da3f4173f 100644 --- a/pact/Pact/Core/IR/ConstEval.hs +++ b/pact/Pact/Core/IR/ConstEval.hs @@ -42,8 +42,8 @@ evalModuleDefConsts interpreter (Module mname mgov defs blessed imports implemen DConst dc -> case _dcTerm dc of TermConst term -> do pv <- eval interpreter PSysOnly term - pv' <- maybeTCType (_dcInfo dc) pv (_argType $ _dcSpec dc) - pure (DConst (set dcTerm (EvaledConst pv') dc)) + maybeTCType (_dcInfo dc) (_argType $ _dcSpec dc) pv + pure (DConst (set dcTerm (EvaledConst pv) dc)) EvaledConst _ -> pure defn _ -> pure defn let dn = defName defn diff --git a/pact/Pact/Core/IR/Desugar.hs b/pact/Pact/Core/IR/Desugar.hs index dc8691bd8..a8ba443f3 100644 --- a/pact/Pact/Core/IR/Desugar.hs +++ b/pact/Pact/Core/IR/Desugar.hs @@ -865,21 +865,21 @@ loadTopLevelMembers i mimports mdata binds = case mdata of mhash = _mHash md let depMap = M.fromList $ toLocalDepMap modName mhash <$> _mDefs md loadedDeps = M.fromList $ toLoadedDepMap modName mhash <$> _mDefs md - loadWithImports depMap loadedDeps + loadWithImports modName depMap loadedDeps InterfaceData iface _ -> do let ifname = _ifName iface let ifhash = _ifHash iface dcDeps = mapMaybe ifDefToDef (_ifDefns iface) depMap = M.fromList $ toLocalDepMap ifname ifhash <$> dcDeps loadedDeps = M.fromList $ toLoadedDepMap ifname ifhash <$> dcDeps - loadWithImports depMap loadedDeps + loadWithImports ifname depMap loadedDeps where toLocalDepMap modName mhash defn = (defName defn, (NTopLevel modName mhash, Just (defKind modName defn))) toLoadedDepMap modName mhash defn = (defName defn, (FullyQualifiedName modName (defName defn) mhash, defKind modName defn)) - loadWithImports depMap loadedDeps = case mimports of + loadWithImports mn depMap loadedDeps = case mimports of Just st -> do let depsKeys = M.keysSet depMap - unless (S.isSubsetOf st depsKeys) $ throwDesugarError (InvalidImports (S.toList (S.difference st depsKeys))) i + unless (S.isSubsetOf st depsKeys) $ throwDesugarError (InvalidImports mn (S.toList (S.difference st depsKeys))) i (esLoaded . loToplevel) %== (`M.union` (M.restrictKeys loadedDeps st)) pure (M.union (M.restrictKeys depMap st) binds) Nothing -> do @@ -1295,7 +1295,7 @@ resolveDynamic => i -> DynamicName -> RenamerT b i m Name -resolveDynamic i (DynamicName dn dArg) = views reBinds (M.lookup dn) >>= \case +resolveDynamic i dynName@(DynamicName dn dArg) = views reBinds (M.lookup dn) >>= \case Just tnk -> case tnk of (NBound d, _) -> do depth <- view reVarDepth @@ -1303,7 +1303,7 @@ resolveDynamic i (DynamicName dn dArg) = views reBinds (M.lookup dn) >>= \case dr = NDynRef (DynamicRef dArg dbjIx) pure (Name dn dr) _ -> - throwDesugarError (InvalidDynamicInvoke dn) i + throwDesugarError (InvalidDynamicInvoke dynName) i Nothing -> throwDesugarError (UnboundTermVariable dn) i @@ -1405,7 +1405,7 @@ renameModule (Module unmangled mgov defs blessed imports implements mhash i) = d where -- Our deps are acyclic, so we resolve all names go mname (!defns, !s, !m, !mlocals) defn = do - when (S.member (defName defn) s) $ throwDesugarError (DuplicateDefinition (defName defn)) i + when (S.member (defName defn) s) $ throwDesugarError (DuplicateDefinition (QualifiedName (defName defn) mname)) i let dn = defName defn defn' <- local (set reCurrModule (Just $ CurrModule mname implements MTModule) . set reCurrModuleTmpBinds mlocals) $ local (set reBinds m) $ renameDef defn @@ -1417,7 +1417,7 @@ renameModule (Module unmangled mgov defs blessed imports implements mhash i) = d resolveGov mname = \case KeyGov rawKsn -> case parseAnyKeysetName (_keysetName rawKsn) of - Left {} -> lift $ throwExecutionError i (ModuleGovernanceFailure mname) + Left {} -> lift $ throwExecutionError i (InvalidKeysetNameFormat (_keysetName rawKsn)) Right ksn -> pure (KeyGov ksn) CapGov (FQParsed govName) -> @@ -1531,7 +1531,7 @@ renameInterface (Interface unmangled defs imports ih info) = do go ifn (ds, s, m, dfnSet) d = do let dn = ifDefName d when (S.member dn s) $ - throwDesugarError (DuplicateDefinition dn) info + throwDesugarError (DuplicateDefinition (QualifiedName dn ifn)) info d' <- local (set reBinds m) $ local (set reCurrModule (Just $ CurrModule ifn [] MTInterface)) $ renameIfDef ifn dfnSet d let m' = case ifDefToDef d' of diff --git a/pact/Pact/Core/IR/Eval/CEK.hs b/pact/Pact/Core/IR/Eval/CEK.hs index 6aa2a8200..95d25a1fd 100644 --- a/pact/Pact/Core/IR/Eval/CEK.hs +++ b/pact/Pact/Core/IR/Eval/CEK.hs @@ -39,15 +39,14 @@ module Pact.Core.IR.Eval.CEK , CEKEval(..) , module Pact.Core.IR.Eval.CEK.Types , module Pact.Core.IR.Eval.CEK.Utils + , returnCEKError ) where import Control.Lens import Control.Monad -import Data.Default import Data.List.NonEmpty(NonEmpty(..)) -import Data.Foldable(find, foldl', traverse_) -import Data.Maybe(isJust) +import Data.Foldable(find, foldl') import qualified Data.RAList as RAList import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -63,7 +62,6 @@ import Pact.Core.Errors import Pact.Core.Gas import Pact.Core.Literal import Pact.Core.PactValue -import Pact.Core.Pretty import Pact.Core.Capabilities import Pact.Core.Type import Pact.Core.Guards @@ -136,7 +134,7 @@ evaluateTerm cont handler env (Var n info) = do NBound i -> do case RAList.lookup (_ceLocal env) i of Just v -> returnCEKValue cont handler v - Nothing -> failInvariant info ("unbound identifier" <> T.pack (show n)) + Nothing -> failInvariant info (InvariantInvalidBoundVariable (_nName n)) -- Top level names are not closures, so we wipe the env NTopLevel mname mh -> do let fqn = FullyQualifiedName mname (_nName n) mh @@ -151,7 +149,7 @@ evaluateTerm cont handler env (Var n info) = do -- this can cause semantic divergences, due to things like provided data. -- moreover defcosts are always evaluated in `SysOnly` mode. TermConst _term -> - failInvariant info "Defconst not fully evaluated" + failInvariant info (InvariantDefConstNotEvaluated fqn) EvaledConst v -> returnCEKValue cont handler (VPactValue v) Just (DPact d) -> do @@ -167,20 +165,21 @@ evaluateTerm cont handler env (Var n info) = do clo = CapTokenClosure fqn args (length args) info returnCEKValue cont handler (VClosure (CT clo)) Just d -> - failInvariant info ("invalid def kind in var position: " <> T.pack (show $ defKind mname d)) + failInvariant info (InvariantInvalidDefKind (defKind mname d) "in var position") Nothing -> - failInvariant info ("name not in scope: " <> T.pack (show $ FullyQualifiedName mname (_nName n) mh)) + failInvariant info (InvariantInvalidBoundVariable (_nName n)) NModRef m ifs -> case ifs of - [x] -> returnCEKValue cont handler (VModRef (ModRef m ifs (Just (S.singleton x)))) - [] -> throwExecutionError info (ModRefNotRefined (_nName n)) - _ -> returnCEKValue cont handler (VModRef (ModRef m ifs Nothing)) + [] -> throwExecutionError info (ModRefImplementsNoInterfaces m) + _ -> + returnCEKValue cont handler (VModRef (ModRef m (S.fromList ifs))) NDynRef (DynamicRef dArg i) -> case RAList.lookup (view ceLocal env) i of Just (VModRef mr) -> do modRefHash <- _mHash <$> getModule info (view cePactDb env) (_mrModule mr) let nk = NTopLevel (_mrModule mr) modRefHash evalCEK cont handler env (Var (Name dArg nk) info) - Just _ -> returnCEK cont handler (VError "dynamic name pointed to non-modref" info) - Nothing -> failInvariant info ("unbound identifier" <> T.pack (show n)) + Just _ -> + throwExecutionError info (DynNameIsNotModRef (_nName n)) + Nothing -> failInvariant info (InvariantInvalidBoundVariable (_nName n)) -- | ------ From ------ | ------ To ------ | -- -- @@ -249,7 +248,8 @@ evaluateTerm cont handler env (Conditional c info) = case c of CEnforceOne str conds -> do case conds of [] -> - returnCEK cont handler (VError "enforce-one failure" info) + -- Note: this will simply be re-thrown within EnforceErrorC, so we don't need anything fancy here + returnCEK cont handler (VError [] (UserEnforceError "internal CEnforceOne error") info) x:xs -> do -- Todo: is this a bit too cheap?? chargeGasArgs info (GAConstant unconsWorkNodeGas) @@ -335,7 +335,7 @@ mkDefunClosure d fqn e = case _dfunTerm d of Nullary body i -> pure (Closure fqn NullaryClosure 0 body (_dfunRType d) e i) _ -> - failInvariant (_dfunInfo d) ("definition is not a closure: " <> T.pack (show d)) + failInvariant (_dfunInfo d) (InvariantMalformedDefun fqn) mkDefPactClosure :: i @@ -404,9 +404,7 @@ applyPact i pc ps cont handler cenv nested = useEvalState esDefPactExec >>= \cas -- `initPact` ensures that the step is 0, -- and there are guaranteed more than 0 steps due to how the parser is written. -- `resumePact` does a similar check before calling this function. - when (ps ^. psStep >= nSteps) $ failInvariant i "Step not found" - - step <- maybe (failInvariant i "Step not found") pure + step <- maybe (throwExecutionError i (InvalidDefPactStepSupplied ps nSteps)) pure $ _dpSteps defPact ^? ix (ps ^. psStep) let pe = DefPactExec @@ -429,7 +427,7 @@ applyPact i pc ps cont handler cenv nested = useEvalState esDefPactExec >>= \cas (True, StepWithRollback _ rollbackExpr) -> evalWithStackFrame i cont' handler cenv Nothing sf rollbackExpr (True, Step{}) -> throwExecutionError i (DefPactStepHasNoRollback ps) - _otherwise -> failInvariant i "defpact continuation does not point to defun" + (_, mh) -> failInvariant i (InvariantExpectedDefPact (qualNameToFqn (pc ^. pcName) mh)) {-# SPECIALIZE applyPact :: () -> DefPactContinuation QualifiedName PactValue @@ -474,12 +472,11 @@ applyNestedPact -> CEKEnv step b i m -> m (CEKEvalResult step b i m) applyNestedPact i pc ps cont handler cenv = useEvalState esDefPactExec >>= \case - Nothing -> failInvariant i $ - "applyNestedPact: Nested DefPact attempted but no pactExec found" <> T.pack (show pc) + Nothing -> failInvariant i $ InvariantPactExecNotInEnv (Just pc) Just pe -> getModuleMemberWithHash i (_cePactDb cenv) (pc ^. pcName) >>= \case (DPact defPact, mh) -> do - step <- maybe (failInvariant i "Step not found") pure + step <- maybe (throwExecutionError i (InvalidDefPactStepSupplied ps (_peStepCount pe))) pure $ _dpSteps defPact ^? ix (ps ^. psStep) let @@ -526,7 +523,7 @@ applyNestedPact i pc ps cont handler cenv = useEvalState esDefPactExec >>= \case (True, StepWithRollback _ rollbackExpr) -> evalWithStackFrame i cont' handler cenv' Nothing sf rollbackExpr (True, Step{}) -> throwExecutionError i (DefPactStepHasNoRollback ps) - _otherwise -> failInvariant i "applyNestedPact: Expected a DefPact bot got something else" + (_, mh) -> failInvariant i (InvariantExpectedDefPact (qualNameToFqn (pc ^. pcName) mh)) {-# SPECIALIZE applyNestedPact :: () -> DefPactContinuation QualifiedName PactValue @@ -593,7 +590,7 @@ resumePact i cont handler env crossChainContinuation = viewEvalEnv eeDefPactStep throwExecutionError i (DefPactIdMismatch (_psDefPactId ps) (_peDefPactId pe)) -- TODO check with multichain when (_psStep ps < 0 || _psStep ps >= _peStepCount pe) $ - throwExecutionError i (InvalidDefPactStepSupplied ps pe) + throwExecutionError i (InvalidDefPactStepSupplied ps (_peStepCount pe)) if _psRollback ps then when (_psStep ps /= _peStep pe) $ @@ -632,9 +629,9 @@ nameToFQN info env (Name n nk) = case nk of Just (VModRef mr) -> do md <- getModule info (view cePactDb env) (_mrModule mr) pure (FullyQualifiedName (_mrModule mr) dArg (_mHash md)) - Just _ -> throwExecutionError info (DynNameIsNotModRef dArg) - Nothing -> failInvariant info ("unbound identifier " <> n) - _ -> failInvariant info ("invalid name in fq position " <> n) + Just _ -> throwExecutionError info (DynNameIsNotModRef n) + Nothing -> failInvariant info (InvariantInvalidBoundVariable n) + _ -> failInvariant info (InvariantInvalidBoundVariable n) {-# SPECIALIZE nameToFQN :: () -> CoreCEKEnv @@ -802,7 +799,8 @@ evalCap info currCont handler env origToken@(CapToken fqn args) popType ecType c go = do capsBeingEvaluated <- useEvalState (esCaps.csCapsBeingEvaluated) d <- getDefCap info fqn - when (length args /= length (_dcapArgs d)) $ failInvariant info "Dcap argument length mismatch" + when (length args /= length (_dcapArgs d)) $ failInvariant info $ + (InvariantArgLengthMismatch fqn (length args) (length (_dcapArgs d))) let newLocals = RAList.fromList $ fmap VPactValue (reverse args) capBody = _dcapTerm d -- Todo: clean up the staircase of doom. @@ -825,15 +823,15 @@ evalCap info currCont handler env origToken@(CapToken fqn args) popType ecType c emittedEvent = fqctToPactEvent origToken <$ guard (ecType == NormalCapEval) cbState = CapBodyState popType (Just qualCapToken) emittedEvent contbody contWithCapBody = CapBodyC env info cbState currCont - contWithPop = CapPopC (PopCurrCapEval capsBeingEvaluated) contWithCapBody + contWithPop = CapPopC (PopCurrCapEval capsBeingEvaluated) info contWithCapBody installCap info env c' False >>= evalUserManagedCap contWithPop newLocals capBody Nothing -> - throwExecutionError info (CapNotInstalled fqn) + throwExecutionError info (CapNotInstalled qualCapToken) Just managedCap -> do let emittedEvent = fqctToPactEvent origToken <$ guard (ecType == NormalCapEval) let cbState = CapBodyState popType (Just qualCapToken) emittedEvent contbody let contWithCapBody = CapBodyC env info cbState currCont - contWithPop = CapPopC (PopCurrCapEval capsBeingEvaluated) contWithCapBody + contWithPop = CapPopC (PopCurrCapEval capsBeingEvaluated) info contWithCapBody evalUserManagedCap contWithPop newLocals capBody managedCap -- handle autonomous caps AutoManagedMeta -> do @@ -841,7 +839,7 @@ evalCap info currCont handler env origToken@(CapToken fqn args) popType ecType c let emittedEvent = fqctToPactEvent origToken <$ guard (ecType == NormalCapEval) let cbState = CapBodyState popType Nothing emittedEvent contbody let contWithCapBody = CapBodyC env info cbState currCont - contWithPop = CapPopC (PopCurrCapEval capsBeingEvaluated) contWithCapBody + contWithPop = CapPopC (PopCurrCapEval capsBeingEvaluated) info contWithCapBody mgdCaps <- useEvalState (esCaps . csManaged) case find ((==) qualCapToken . _mcCap) mgdCaps of Nothing -> do @@ -851,13 +849,13 @@ evalCap info currCont handler env origToken@(CapToken fqn args) popType ecType c let c' = set ctName fqn c installCap info env c' False >>= evalAutomanagedCap contWithPop newLocals capBody Nothing -> - throwExecutionError info (CapNotInstalled fqn) + throwExecutionError info (CapNotInstalled qualCapToken) Just managedCap -> evalAutomanagedCap contWithPop newLocals capBody managedCap DefEvent -> do let cbState = CapBodyState popType Nothing (Just (fqctToPactEvent origToken)) contbody let contWithCapBody = CapBodyC env info cbState currCont - contWithPop = CapPopC (PopCurrCapEval capsBeingEvaluated) contWithCapBody + contWithPop = CapPopC (PopCurrCapEval capsBeingEvaluated) info contWithCapBody let inCapEnv = set ceInCap True $ set ceLocal newLocals env (esCaps . csSlots) %== (CapSlot qualCapToken []:) (esCaps . csCapsBeingEvaluated) %== S.insert qualCapToken @@ -869,7 +867,7 @@ evalCap info currCont handler env origToken@(CapToken fqn args) popType ecType c let cbState = CapBodyState popType Nothing Nothing contbody let contWithBody = if ecType == NormalCapEval then CapBodyC env info cbState currCont else currCont - contWithPop = CapPopC (PopCurrCapEval capsBeingEvaluated) contWithBody + contWithPop = CapPopC (PopCurrCapEval capsBeingEvaluated) info contWithBody inCapEnv = set ceInCap True $ set ceLocal newLocals env (esCaps . csCapsBeingEvaluated) %== S.insert qualCapToken (esCaps . csSlots) %== (CapSlot qualCapToken []:) @@ -883,7 +881,7 @@ evalCap info currCont handler env origToken@(CapToken fqn args) popType ecType c ManagedParam mpfqn oldV managedIx -> do dfun <- getDefun info mpfqn dfunClo <- mkDefunClosure dfun mpfqn env - newV <- maybe (failInvariant info "Managed param does not exist at index") pure (args ^? ix managedIx) + newV <- maybe (failInvariant info (InvariantInvalidManagedCapIndex managedIx fqn)) pure (args ^? ix managedIx) -- Set the mgr fun to evaluate after we apply the capability body -- NOTE: test-capability doesn't actually run the manager function, it just runs the cap pop then -- pops it. It would be great to do without this, but a lot of our regressions rely on this. @@ -902,10 +900,10 @@ evalCap info currCont handler env origToken@(CapToken fqn args) popType ecType c (esCaps . csCapsBeingEvaluated) %== S.insert inCapBodyToken sfCont <- pushStackFrame info mgrFunCont Nothing capStackFrame evalCEK sfCont handler inCapEnv capBody - _ -> failInvariant info "Invalid managed cap type" + _ -> failInvariant info (InvariantInvalidManagedCapKind "expected user managed, received automanaged") evalAutomanagedCap cont' env' capBody managedCap = case _mcManaged managedCap of AutoManaged b -> do - if b then returnCEK currCont handler (VError "Automanaged capability used more than once" info) + if b then returnCEKError info currCont handler OneShotCapAlreadyUsed else do let newManaged = AutoManaged True esCaps . csManaged %== S.union (S.singleton (set mcManaged newManaged managedCap)) @@ -914,7 +912,7 @@ evalCap info currCont handler env origToken@(CapToken fqn args) popType ecType c let inCapEnv = set ceLocal env' $ set ceInCap True $ env sfCont <- pushStackFrame info cont' Nothing capStackFrame evalCEK sfCont handler inCapEnv capBody - _ -> failInvariant info "Invalid managed cap type" + _ -> failInvariant info (InvariantInvalidManagedCapKind "expected automanaged, received user managed") {-# SPECIALIZE evalCap :: () -> CoreCEKCont @@ -927,6 +925,16 @@ evalCap info currCont handler env origToken@(CapToken fqn args) popType ecType c -> Eval (EvalResult CEKBigStep CoreBuiltin () Eval) #-} +returnCEKError + :: (CEKEval step b i m, MonadEval b i m) + => i + -> Cont step b i m + -> CEKErrorHandler step b i m + -> UserRecoverableError + -> m (CEKEvalResult step b i m) +returnCEKError info cont handler err = do + stack <- useEvalState esStack + returnCEK cont handler (VError stack err info) emitEvent :: (MonadEval b i m) @@ -942,7 +950,7 @@ emitEvent info pe = findCallingModule >>= \case if ctModule == mn then do esEvents %== (++ [pe]) else throwExecutionError info (EventDoesNotMatchModule mn) - Nothing -> failInvariant info "emit-event called outside of module code" + Nothing -> throwExecutionError info (EventDoesNotMatchModule (_peModule pe)) emitEventUnsafe :: (MonadEval b i m) @@ -995,10 +1003,10 @@ requireCap -> FQCapToken -> m (CEKEvalResult step b i m) requireCap info cont handler (CapToken fqn args) = do - capInStack <- isCapInStack (CapToken (fqnToQualName fqn) args) + let qualCapToken = CapToken (fqnToQualName fqn) args + capInStack <- isCapInStack qualCapToken if capInStack then returnCEKValue cont handler (VBool True) - else returnCEK cont handler $ - VError ("require-capability: not granted: (" <> renderQualName (fqnToQualName fqn) <> ")") info + else returnCEKError info cont handler (CapabilityNotGranted qualCapToken) {-# SPECIALIZE requireCap :: () -> CoreCEKCont @@ -1072,12 +1080,12 @@ installCap info _env (CapToken fqn args) autonomous = do case _dcapMeta d of DefManaged m -> case m of DefManagedMeta (paramIx,_) (FQName fqnMgr) -> do - managedParam <- maybe (failInvariant info $ "invalid managed cap idx: " <> T.pack (show fqn)) pure (args ^? ix paramIx) + managedParam <- maybe (failInvariant info $ InvariantInvalidManagedCapIndex paramIx fqn) pure (args ^? ix paramIx) let mcapType = ManagedParam fqnMgr managedParam paramIx ctFiltered = CapToken (fqnToQualName fqn) (filterIndex paramIx args) mcap = ManagedCap ctFiltered ct mcapType capAlreadyInstalled <- S.member mcap <$> useEvalState (esCaps . csManaged) - when capAlreadyInstalled $ throwExecutionError info (CapAlreadyInstalled fqn) + when capAlreadyInstalled $ throwExecutionError info (CapAlreadyInstalled ct) (esCaps . csManaged) %== S.insert mcap when autonomous $ (esCaps . csAutonomous) %== S.insert ct @@ -1086,7 +1094,7 @@ installCap info _env (CapToken fqn args) autonomous = do let mcapType = AutoManaged False mcap = ManagedCap ct ct mcapType capAlreadyInstalled <- S.member mcap <$> useEvalState (esCaps . csManaged) - when capAlreadyInstalled $ throwExecutionError info (CapAlreadyInstalled fqn) + when capAlreadyInstalled $ throwExecutionError info (CapAlreadyInstalled ct) (esCaps . csManaged) %== S.insert mcap when autonomous $ (esCaps . csAutonomous) %== S.insert ct @@ -1111,14 +1119,19 @@ createUserGuard -> FullyQualifiedName -> [PactValue] -> m (CEKEvalResult step b i m) -createUserGuard info cont handler fqn args = +createUserGuard info cont handler fqn args = do + -- Note: we could use `getDefun` here, but this gives us a better error lookupFqName fqn >>= \case Just (Dfun _) -> returnCEKValue cont handler (VGuard (GUserGuard (UserGuard (fqnToQualName fqn) args))) - Just _ -> - returnCEK cont handler (VError "create-user-guard pointing to non-guard" info) + Just d -> + -- Note: this error is not recoverable in prod + -- :0:26:Error: User guard closure must be defun, found: defcap + -- at :0:7: (create-user-guard ((defcap m.g: ()))) + -- at :0:0: (try 1 (native `create-user-guard` Defines a custom guar...) + throwExecutionError info $ UserGuardMustBeADefun (fqnToQualName fqn) (defKind (_fqModule fqn) d) Nothing -> - failInvariant info "User guard pointing to no defn" + failInvariant info (InvariantUnboundFreeVariable fqn) {-# SPECIALIZE createUserGuard :: () -> CoreCEKCont @@ -1226,7 +1239,7 @@ applyContToValue (Args env i args cont) handler fn = do VClosure _ -> throwExecutionError i CannotApplyPartialClosure -- Todo: this is _not_ an invariant failure. Requires a better error - _ -> failInvariant i "Cannot apply non-function to arguments" + _ -> throwExecutionError i CannotApplyValueToNonClosure -- | ------ From ------------------------- | ------ To ----------------------- | -- -- (apply clo (reverse (v:acc)) K H) @@ -1286,7 +1299,9 @@ applyContToValue (CondC env info frame cont) handler v = do [] -> returnCEKValue cont handler (VList (V.fromList (reverse acc'))) EnforceOneC -> if b then returnCEKValue cont handler v - else returnCEK cont handler (VError "enforce-one bool check failure" info) + else + -- Note: this will simply be re-thrown within EnforceErrorC, so we don't need anything fancy here + returnCEK cont handler (VError [] (UserEnforceError "internal CEnforceOne error") info) AndQC clo pv -> if b then applyLam clo [VPactValue pv] (EnforceBoolC info cont) handler else returnCEKValue cont handler v @@ -1294,8 +1309,10 @@ applyContToValue (CondC env info frame cont) handler v = do if not b then applyLam clo [VPactValue pv] (EnforceBoolC info cont) handler else returnCEKValue cont handler v NotQC -> returnCEKValue cont handler (VBool (not b)) + VPactValue v' -> throwExecutionError info (ExpectedBoolValue v') _ -> - returnCEK cont handler (VError "Evaluation of conditional expression yielded non-boolean value" info) + -- Note: a non-boolean value in these functions is non recoverable + throwExecutionError info ExpectedPactValue applyContToValue currCont@(CapInvokeC env info cf cont) handler v = case cf of WithCapC body -> case v of VCapToken ct@(CapToken fqn _) -> do @@ -1304,7 +1321,8 @@ applyContToValue currCont@(CapInvokeC env info cf cont) handler v = case cf of guardForModuleCall info cont' handler env (_fqModule fqn) $ evalCap info cont handler env ct PopCapInvoke NormalCapEval body -- Todo: this is actually more like "expected cap token" - _ -> throwExecutionError info ExpectedPactValue + VPactValue v' -> throwExecutionError info $ ExpectedCapToken v' + _ -> throwExecutionError info $ ExpectedPactValue CreateUserGuardC fqn terms pvs -> do pv <- enforcePactValue info v case terms of @@ -1315,7 +1333,7 @@ applyContToValue currCont@(CapInvokeC env info cf cont) handler v = case cf of [] -> createUserGuard info cont handler fqn (reverse (pv:pvs)) ApplyMgrFunC mgdCap clo old new -> do -- Set the manager fun to update the current managed cap. - let cont' = CapInvokeC env info (UpdateMgrFunC mgdCap) cont + let cont' = EnforcePactValueC info $ CapInvokeC env info (UpdateMgrFunC mgdCap) cont applyLam (C clo) [VPactValue old, VPactValue new] cont' handler -- note: typechecking should be handled by the manager function here. UpdateMgrFunC mcap -> case v of @@ -1323,7 +1341,7 @@ applyContToValue currCont@(CapInvokeC env info cf cont) handler v = case cf of let mcap' = unsafeUpdateManagedParam v' mcap (esCaps . csManaged) %== S.insert mcap' returnCEKValue cont handler v - _ -> returnCEK cont handler (VError "Manager function for managed cap did not return a value" info) + _ -> throwExecutionError info ExpectedPactValue applyContToValue (BuiltinC env info frame cont) handler cv = do let pdb = _cePactDb env case cv of @@ -1362,12 +1380,14 @@ applyContToValue (BuiltinC env info frame cont) handler cv = do PBool b -> do let acc' = if b then rdata:acc else acc selectRead tv clo remaining acc' mf - _ -> returnCEK cont handler (VError "select query did not return a boolean " info) + _ -> throwExecutionError info $ ExpectedBoolValue v ReadC tv rowkey -> do liftDbFunction info (_pdbRead pdb (tvToDomain tv) rowkey) >>= \case Just (RowData rdata) -> returnCEKValue cont handler (VObject rdata) - Nothing -> returnCEK cont handler (VError "no such read object" info) + Nothing -> + returnCEKError info cont handler $ + NoSuchObjectInDb (_tvName tv) rowkey WithDefaultReadC tv rowkey (ObjectData defaultObj) clo -> do liftDbFunction info (_pdbRead pdb (tvToDomain tv) rowkey) >>= \case Just (RowData rdata) -> @@ -1385,7 +1405,8 @@ applyContToValue (BuiltinC env info frame cont) handler cv = do chargeGasArgs info (GWrite rvSize) _ <- liftGasM info $ _pdbWrite pdb wt (tvToDomain tv) rk rdata returnCEKValue cont handler (VString "Write succeeded") - else returnCEK cont handler (VError "object does not match schema" info) + else + throwExecutionError info (WriteValueDidNotMatchSchema (_tvSchema tv) (ObjectData rv)) PreFoldDbC tv queryClo appClo -> do let tblDomain = DUserTables (_tvName tv) -- Todo: keys gas @@ -1411,7 +1432,8 @@ applyContToValue (BuiltinC env info frame cont) handler cv = do PBool b -> do let accum' = if b then (rk, PObject om):accum else accum foldDBRead tv queryClo appClo remaining accum' - _ -> returnCEK cont handler (VError "fold-db error: query returned non-boolean value" info) + _ -> + throwExecutionError info (ExpectedBoolValue v) FoldDbMapC tv appClo remaining acc -> case remaining of (RowKey rk, pv):xs -> do let rdf = FoldDbMapC tv appClo xs (v:acc) @@ -1432,15 +1454,11 @@ applyContToValue (BuiltinC env info frame cont) handler cv = do CreateTableC (TableValue tn _ _) -> do liftGasM info (_pdbCreateUserTable pdb tn) returnCEKValue cont handler (VString "TableCreated") - EmitEventC ct@(CapToken fqn _) -> - lookupFqName (_ctName ct) >>= \case - Just (DCap d) -> do - enforceMeta (_dcapMeta d) - emitCapability info ct - returnCEKValue cont handler (VBool True) - Just _ -> - failInvariant info "CapToken does not point to defcap" - _ -> failInvariant info "No Capability found in emit-event" + EmitEventC ct@(CapToken fqn _) -> do + d <- getDefCap info fqn + enforceMeta (_dcapMeta d) + emitCapability info ct + returnCEKValue cont handler (VBool True) where enforceMeta Unmanaged = throwExecutionError info (InvalidEventCap fqn) enforceMeta _ = pure () @@ -1457,14 +1475,18 @@ applyContToValue (BuiltinC env info frame cont) handler cv = do chargeGasArgs info (GWrite nsSize) liftGasM info $ _pdbWrite pdb Write DNamespaces nsn ns returnCEKValue cont handler $ VString $ "Namespace defined: " <> (_namespaceName nsn) - else throwExecutionError info $ DefineNamespaceError "Namespace definition not permitted" + -- injecting the NativeName directly here as to not have to unnecessarily thread `b` around in the + -- cont + else throwExecutionError info $ NativeExecutionError (NativeName "define-namespace") $ "Namespace definition not permitted" _ -> - throwExecutionError info $ DefineNamespaceError "Namespace manager function returned an invalid value" - RunKeysetPredC -> case v of + throwExecutionError info $ NativeExecutionError (NativeName "define-namespace") $ "Namespace manager function returned an invalid value" + RunKeysetPredC (KeySet ksKeys ksPred) -> case v of PBool allow -> if allow then returnCEKValue cont handler (VBool True) - else returnCEK cont handler (VError "Keyset failure" info) - _ -> returnCEK cont handler (VError "Keyset failure" info) + else returnCEKError info cont handler $ + KeysetPredicateFailure ksPred ksKeys + _ -> + throwExecutionError info (ExpectedBoolValue v) where foldDBRead tv queryClo appClo remaining acc = case remaining of @@ -1474,7 +1496,7 @@ applyContToValue (BuiltinC env info frame cont) handler cv = do cont' = BuiltinC env info rdf cont applyLam queryClo [VString raw, VObject row] cont' handler Nothing -> - failInvariant info "foldDB read a key that is not in the database" + failInvariant info (InvariantNoSuchKeyInTable (_tvName tv) rk) [] -> case acc of (RowKey rk, pv):xs -> do let rdf = FoldDbMapC tv appClo xs [] @@ -1488,7 +1510,7 @@ applyContToValue (BuiltinC env info frame cont) handler cv = do cont' = BuiltinC env info bf cont applyLam clo [VObject r] cont' handler Nothing -> - failInvariant info "Select keys returned a key that did not exist" + failInvariant info (InvariantNoSuchKeyInTable (_tvName tv) k) [] -> case mf of Just fields -> let acc' = PObject . (`M.restrictKeys` S.fromList fields) . _objectData <$> reverse acc @@ -1496,23 +1518,24 @@ applyContToValue (BuiltinC env info frame cont) handler cv = do Nothing -> let acc' = PObject . _objectData <$> reverse acc in returnCEKValue cont handler (VList (V.fromList acc')) - _ -> returnCEK cont handler (VError "higher order apply did not return a pactvalue" info) -applyContToValue (CapBodyC env _info (CapBodyState cappop mcap mevent capbody) cont) handler _ = do + _ -> + throwExecutionError info ExpectedPactValue +applyContToValue (CapBodyC env info (CapBodyState cappop mcap mevent capbody) cont) handler _ = do -- Todo: I think this requires some administrative check? maybe (pure ()) emitEventUnsafe mevent case mcap of Nothing -> do - let cont' = CapPopC cappop cont + let cont' = CapPopC cappop info cont evalCEK cont' handler env capbody -- We're in a managed cap! We gotta do some quick stack manipulation. Just cap -> useEvalState (esCaps . csSlots) >>= \case (CapSlot _ tl:rest) -> do setEvalState (esCaps . csSlots) (CapSlot cap tl:rest) - let cont' = CapPopC cappop cont + let cont' = CapPopC cappop info cont evalCEK cont' handler env capbody - [] -> failInvariant def "In CapBodyC but with no caps in stack" + [] -> failInvariant info InvariantEmptyCapStackFailure -applyContToValue (CapPopC st cont) handler v = case st of +applyContToValue (CapPopC st info cont) handler v = case st of PopCurrCapEval oldSet -> do esCaps . csCapsBeingEvaluated .== oldSet returnCEKValue cont handler v @@ -1526,10 +1549,10 @@ applyContToValue (CapPopC st cont) handler v = case st of caps' = over (_head . csComposed) (++ csList) cs setEvalState (esCaps . csSlots) caps' returnCEKValue cont handler VUnit - [] -> failInvariant def "PopCapComposed present outside of cap eval" + [] -> failInvariant info InvariantEmptyCapStackFailure applyContToValue (ListC env info args vals cont) handler v = do - pv <- enforcePactValue def v + pv <- enforcePactValue info v case args of [] -> returnCEKValue cont handler (VList (V.fromList (reverse (pv:vals)))) @@ -1537,7 +1560,7 @@ applyContToValue (ListC env info args vals cont) handler v = do evalCEK (ListC env info es (pv:vals) cont) handler env e applyContToValue (ObjC env info currfield fs vs cont) handler v = do - v' <- enforcePactValue def v + v' <- enforcePactValue info v let fields = (currfield,v'):vs case fs of (f', term):fs' -> @@ -1547,28 +1570,30 @@ applyContToValue (ObjC env info currfield fs vs cont) handler v = do returnCEKValue cont handler (VObject (M.fromList (reverse fields))) applyContToValue (EnforceErrorC info _) handler v = case v of - VString err -> returnCEK Mt handler (VError err info) - -- TODO: remove - _ -> failInvariant info $ "enforce function did not return a string" <> T.pack (show v) + VString err -> + returnCEKError info Mt handler $ UserEnforceError err + VPactValue v' -> throwExecutionError info $ ExpectedStringValue v' + _ -> throwExecutionError info $ ExpectedPactValue -- Discard the value of running a user guard, no error occured, so applyContToValue (IgnoreValueC v cont) handler _v = returnCEKValue cont handler (VPactValue v) applyContToValue (StackPopC i mty cont) handler v = do - v' <- (\pv -> maybeTCType i pv mty) =<< enforcePactValue i v + v' <- enforcePactValue i v + maybeTCType i mty v' esStack %== safeTail esCheckRecursion %== getPrevRecCheck returnCEKValue cont handler (VPactValue v') where getPrevRecCheck (_ :| l) = case l of top : rest -> top :| rest - [] -> def :| [] + [] -> (RecursionCheck mempty) :| [] applyContToValue (DefPactStepC env info cont) handler v = useEvalState esDefPactExec >>= \case - Nothing -> failInvariant info "No PactExec found" + Nothing -> failInvariant info $ InvariantPactExecNotInEnv Nothing Just pe -> case env ^. ceDefPactStep of - Nothing -> failInvariant info "Expected a PactStep in the environment" + Nothing -> failInvariant info (InvariantPactStepNotInEnv Nothing) Just ps -> do let pdb = view cePactDb env @@ -1583,9 +1608,9 @@ applyContToValue (DefPactStepC env info cont) handler v = applyContToValue (NestedDefPactStepC env info cont parentDefPactExec) handler v = useEvalState esDefPactExec >>= \case - Nothing -> failInvariant info "No DefPactExec found" + Nothing -> failInvariant info $ InvariantPactExecNotInEnv Nothing Just pe -> case env ^. ceDefPactStep of - Nothing -> failInvariant info "Expected a DefPactStep in the environment" + Nothing -> failInvariant info (InvariantPactStepNotInEnv Nothing) Just ps -> do when (nestedPactsNotAdvanced pe ps) $ throwExecutionError info (NestedDefpactsNotAdvanced (_peDefPactId pe)) @@ -1595,11 +1620,12 @@ applyContToValue (NestedDefPactStepC env info cont parentDefPactExec) handler v applyContToValue (EnforcePactValueC info cont) handler v = case v of VPactValue{} -> returnCEKValue cont handler v - _ -> returnCEK cont handler (VError "function expected to return pact value" info) + _ -> throwExecutionError info ExpectedPactValue applyContToValue (EnforceBoolC info cont) handler v = case v of VBool{} -> returnCEKValue cont handler v - _ -> returnCEK cont handler (VError "function expected to return boolean" info) + VPactValue v' -> throwExecutionError info (ExpectedBoolValue v') + _ -> throwExecutionError info ExpectedPactValue applyContToValue (ModuleAdminC mn cont) handler v = do (esCaps . csModuleAdmin) %== S.insert mn @@ -1637,8 +1663,8 @@ applyLam vc@(C (Closure fqn ca arity term mty env cloi)) args cont handler ArgClosure cloargs -> do chargeGasArgs cloi (GAApplyLam (renderFullyQualName fqn) argLen) args' <- traverse (enforcePactValue cloi) args - tcArgs <- zipWithM (\arg (Arg _ ty _) -> VPactValue <$> maybeTCType cloi arg ty) args' (NE.toList cloargs) - let varEnv = RAList.fromList (reverse tcArgs) + zipWithM_ (\arg (Arg _ ty _) -> maybeTCType cloi ty arg) args' (NE.toList cloargs) + let varEnv = RAList.fromList (reverse args) evalWithStackFrame cloi cont handler (set ceLocal varEnv env) mty (StackFrame fqn args' SFDefun cloi) term NullaryClosure -> do let varEnv = mempty @@ -1656,7 +1682,8 @@ applyLam vc@(C (Closure fqn ca arity term mty env cloi)) args cont handler argLen = length args -- Here we enforce an argument to a user fn is a pact value apply' e (Arg _ ty _:tys) (x:xs) = do - x' <- (\pv -> maybeTCType cloi pv ty) =<< enforcePactValue cloi x + x' <- enforcePactValue cloi x + maybeTCType cloi ty x' apply' (RAList.cons (VPactValue x') e) tys xs apply' e (ty:tys) [] = do let env' = set ceLocal e env @@ -1687,7 +1714,8 @@ applyLam (LC (LamClosure ca arity term mty env cloi)) args cont handler argLen = length args -- Todo: runtime TC here apply' e (Arg _ ty _:tys) (x:xs) = do - x' <- (\pv -> maybeTCType cloi pv ty) =<< enforcePactValue cloi x + x' <- enforcePactValue cloi x + maybeTCType cloi ty x' apply' (RAList.cons (VPactValue x') e) tys xs apply' e [] [] = do evalCEK cont handler (set ceLocal e env) term @@ -1701,7 +1729,8 @@ applyLam (PC (PartialClosure li argtys _ term mty env cloi)) args cont handler = apply' (view ceLocal env) (NE.toList argtys) args where apply' e (Arg _ ty _:tys) (x:xs) = do - x' <- (\pv -> maybeTCType cloi pv ty) =<< enforcePactValue cloi x + x' <- enforcePactValue cloi x + maybeTCType cloi ty x' apply' (RAList.cons (VPactValue x') e) tys xs apply' e [] [] = do case li of @@ -1747,9 +1776,9 @@ applyLam (DPC (DefPactClosure fqn argtys arity env i)) args cont handler -- Todo: defpact has much higher overhead, we must charge a bit more gas for this chargeGasArgs i (GAApplyLam (renderQualName (fqnToQualName fqn)) (fromIntegral argLen)) args' <- traverse (enforcePactValue i) args - tcArgs <- zipWithM (\arg (Arg _ ty _) -> maybeTCType i arg ty) args' (NE.toList cloargs) - let pc = DefPactContinuation (fqnToQualName fqn) tcArgs - env' = set ceLocal (RAList.fromList (reverse (VPactValue <$> tcArgs))) env + zipWithM_ (\arg (Arg _ ty _) -> maybeTCType i ty arg) args' (NE.toList cloargs) + let pc = DefPactContinuation (fqnToQualName fqn) args' + env' = set ceLocal (RAList.fromList (reverse args)) env initPact i pc cont handler env' NullaryClosure -> do chargeGasArgs i (GAApplyLam (renderQualName (fqnToQualName fqn)) (fromIntegral argLen)) @@ -1764,8 +1793,8 @@ applyLam (CT (CapTokenClosure fqn argtys arity i)) args cont handler | arity == argLen = do chargeGasArgs i (GAApplyLam (renderQualName (fqnToQualName fqn)) (fromIntegral argLen)) args' <- traverse (enforcePactValue i) args - tcArgs <- zipWithM (\arg ty -> maybeTCType i arg ty) args' argtys - returnCEKValue cont handler (VPactValue (PCapToken (CapToken fqn tcArgs))) + zipWithM_ (\arg ty -> maybeTCType i ty arg) args' argtys + returnCEKValue cont handler (VPactValue (PCapToken (CapToken fqn args'))) | otherwise = throwExecutionError i ClosureAppliedToTooManyArgs where argLen = length args @@ -1782,17 +1811,7 @@ getSfName = \case Just sf -> renderFullyQualName (_sfName sf) Nothing -> "#lambda" -checkSchema :: M.Map Field PactValue -> Schema -> Bool -checkSchema o (Schema _ sc) = isJust $ do - let keys = M.keys o - when (keys /= M.keys sc) Nothing - traverse_ go (M.toList o) - where - go (k, v) = M.lookup k sc >>= (`checkPvType` v) -checkPartialSchema :: M.Map Field PactValue -> Schema -> Bool -checkPartialSchema o (Schema _ sc) = - M.isSubmapOfBy (\obj ty -> isJust (checkPvType ty obj)) o sc instance MonadEval b i m => CEKEval CEKSmallStep b i m where returnCEKValue cont handler v = pure (CEKReturn cont handler (EvalValue v)) @@ -1860,7 +1879,8 @@ enforceGuard info cont handler env g = case g of curDpid <- getDefPactId info if curDpid == dpid then returnCEKValue cont handler (VBool True) - else returnCEK cont handler (VError "Capability pact guard failed: invalid pact id" info) + else returnCEKError info cont handler $ + CapabilityPactGuardInvalidPactId curDpid dpid {-# SPECIALIZE enforceGuard :: () -> CoreCEKCont @@ -1877,19 +1897,19 @@ enforceCapGuard -> CEKErrorHandler step b i m -> CapabilityGuard QualifiedName PactValue -> m (CEKEvalResult step b i m) -enforceCapGuard info cont handler (CapabilityGuard qn args mpid) = case mpid of +enforceCapGuard info cont handler cg@(CapabilityGuard qn args mpid) = case mpid of Nothing -> enforceCap Just pid -> do currPid <- getDefPactId info if currPid == pid then enforceCap - else returnCEK cont handler (VError "Capability pact guard failed: invalid pact id" info) + else returnCEKError info cont handler $ + CapabilityPactGuardInvalidPactId currPid pid where enforceCap = do cond <- isCapInStack (CapToken qn args) if cond then returnCEKValue cont handler (VBool True) - else do - let errMsg = "Capability guard enforce failure cap not in scope: " <> renderQualName qn - returnCEK cont handler (VError errMsg info) + else returnCEKError info cont handler $ + CapabilityGuardNotAcquired cg {-# SPECIALIZE enforceCapGuard :: () -> CoreCEKCont @@ -1914,7 +1934,7 @@ runUserGuard info cont handler env (UserGuard qn args) = clo <- mkDefunClosure d (qualNameToFqn qn mh) env' -- Todo: sys only here applyLam (C clo) (VPactValue <$> args) (IgnoreValueC (PBool True) cont) handler - (d, _) -> throwExecutionError info (InvalidDefKind (defKind (_qnModName qn) d) "run-user-guard") + (d, _) -> throwExecutionError info (UserGuardMustBeADefun qn (defKind (_qnModName qn) d)) {-# SPECIALIZE runUserGuard :: () -> CoreCEKCont @@ -1935,8 +1955,8 @@ eval purity benv term = do ee <- readEnv let cekEnv = envFromPurity purity (CEKEnv mempty (_eePactDb ee) benv (_eeDefPactStep ee) False) evalNormalForm cekEnv term >>= \case - VError txt i -> - throwExecutionError i (EvalError txt) + VError stack err i -> + throwUserRecoverableError' i stack err EvalValue v -> do case v of VPactValue pv -> pure pv @@ -1960,8 +1980,8 @@ interpretGuard info bEnv g = do ee <- readEnv let cekEnv = CEKEnv mempty (_eePactDb ee) bEnv (_eeDefPactStep ee) False enforceGuard info Mt CEKNoHandler cekEnv g >>= evalUnsafe @step >>= \case - VError txt errInfo -> - throwExecutionError errInfo (EvalError txt) + VError stack err i -> + throwUserRecoverableError' i stack err EvalValue v -> do case v of VPactValue pv -> pure pv @@ -1986,8 +2006,8 @@ evalResumePact info bEnv mdpe = do let pdb = _eePactDb ee let env = CEKEnv mempty pdb bEnv (_eeDefPactStep ee) False resumePact info Mt CEKNoHandler env mdpe >>= evalUnsafe @step >>= \case - VError txt i -> - throwExecutionError i (EvalError txt) + VError stack err i -> + throwUserRecoverableError' i stack err EvalValue v -> do case v of VPactValue pv -> pure pv @@ -2034,21 +2054,18 @@ isKeysetInSigs -> CEKEnv step b i m -> KeySet -> m (CEKEvalResult step b i m) -isKeysetInSigs info cont handler env (KeySet kskeys ksPred) = do +isKeysetInSigs info cont handler env ks@(KeySet kskeys ksPred) = do matchedSigs <- M.filterWithKey matchKey <$> viewEvalEnv eeMsgSigs sigs <- checkSigCaps matchedSigs runPred (M.size sigs) where matchKey k _ = k `elem` kskeys atLeast t m = m >= t - elide pk = T.take 8 pk <> "..." count = S.size kskeys run p matched = if p count matched then returnCEKValue cont handler (VBool True) - else let - errMsg = "Keyset failure (" <> predicateToText ksPred <> "): " - <> renderCompactText (map (elide . renderPublicKeyText) $ S.toList kskeys) - in returnCEK cont handler (VError errMsg info) + else returnCEKError info cont handler $ + KeysetPredicateFailure ksPred kskeys runPred matched = case ksPred of KeysAll -> run atLeast matched @@ -2061,19 +2078,20 @@ isKeysetInSigs info cont handler env (KeySet kskeys ksPred) = do getModuleMemberWithHash info pdb qn >>= \case (Dfun d, mh) -> do clo <- mkDefunClosure d (qualNameToFqn qn mh) env - let cont' = BuiltinC env info RunKeysetPredC cont + let cont' = BuiltinC env info (RunKeysetPredC ks) cont applyLam (C clo) [VInteger (fromIntegral count), VInteger (fromIntegral matched)] cont' handler - _ -> failInvariant info "invalid def type for custom keyset predicate" + _ -> + throwExecutionError info (InvalidCustomKeysetPredicate "expected defun") TBN (BareName bn) -> do m <- viewEvalEnv eeNatives case M.lookup bn m of Just b -> do let builtins = view ceBuiltins env let nativeclo = builtins info b env - let cont' = BuiltinC env info RunKeysetPredC cont + let cont' = BuiltinC env info (RunKeysetPredC ks) cont applyLam (N nativeclo) [VInteger (fromIntegral count), VInteger (fromIntegral matched)] cont' handler Nothing -> - failInvariant info "could not find native definition for custom predicate" + throwExecutionError info (InvalidCustomKeysetPredicate "expected native") isKeysetNameInSigs :: (MonadEval b i m, CEKEval step b i m) diff --git a/pact/Pact/Core/IR/Eval/CEK/Types.hs b/pact/Pact/Core/IR/Eval/CEK/Types.hs index 1fb91cff3..87f34bb90 100644 --- a/pact/Pact/Core/IR/Eval/CEK/Types.hs +++ b/pact/Pact/Core/IR/Eval/CEK/Types.hs @@ -121,6 +121,7 @@ import Pact.Core.Environment import Pact.Core.DefPacts.Types import Pact.Core.Namespace import Pact.Core.Builtin +import Pact.Core.Errors import Pact.Core.IR.Eval.Runtime.Types import qualified Pact.Core.Pretty as P @@ -316,7 +317,7 @@ pattern VDefPactClosure clo = VClosure (DPC clo) -- | Result of an evaluation step, either a CEK value or an error. data EvalResult (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) (m :: K.Type -> K.Type) = EvalValue (CEKValue step b i m) - | VError Text i + | VError [StackFrame i] UserRecoverableError i deriving (Show, Generic) instance (NFData b, NFData i) => NFData (EvalResult step b i m) @@ -415,7 +416,7 @@ data BuiltinCont (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) (m :: K.Type -- ^ | DefineNamespaceC Namespace -- ^ namespace to write to the db - | RunKeysetPredC + | RunKeysetPredC KeySet -- ^ check the keyset predicate deriving (Show, Generic) @@ -480,7 +481,7 @@ data Cont (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) (m :: K.Type -> K.Ty -- - the capability "user body" to evaluate, generally carrying a series of expressions -- or a simple return value in the case of `compose-capability` -- - The rest of the continuation - | CapPopC CapPopState (Cont step b i m) + | CapPopC CapPopState i (Cont step b i m) -- ^ What to do after returning from a defcap: do we compose the returned cap, or do we simply pop it from the stack | DefPactStepC (CEKEnv step b i m) i (Cont step b i m) -- ^ Cont frame after a defpact, ensuring we save the defpact to the database and whatnot diff --git a/pact/Pact/Core/IR/Eval/CoreBuiltin.hs b/pact/Pact/Core/IR/Eval/CoreBuiltin.hs index 57d29eee3..207864735 100644 --- a/pact/Pact/Core/IR/Eval/CoreBuiltin.hs +++ b/pact/Pact/Core/IR/Eval/CoreBuiltin.hs @@ -710,13 +710,14 @@ coreAccess info b cont handler _env = \case [VLiteral (LInteger i), VList vec] -> case vec V.!? fromIntegral i of Just v -> returnCEKValue cont handler (VPactValue v) + -- Note: this error is not recoverable in prod _ -> throwExecutionError info (ArrayOutOfBoundsException (V.length vec) (fromIntegral i)) [VString field, VObject o] -> case M.lookup (Field field) o of Just v -> returnCEKValue cont handler (VPactValue v) Nothing -> - let msg = "Object does not have field: " <> field - in returnCEK cont handler (VError msg info) + -- Note: this error is not recoverable in prod + throwExecutionError info (ObjectIsMissingField (Field field) (ObjectData o)) args -> argsError info b args coreIsCharset :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m @@ -726,7 +727,8 @@ coreIsCharset info b cont handler _env = \case case i of 0 -> returnCEKValue cont handler $ VBool $ T.all Char.isAscii s 1 -> returnCEKValue cont handler $ VBool $ T.all Char.isLatin1 s - _ -> returnCEK cont handler (VError "Unsupported character set" info) + _ -> + throwNativeExecutionError info b "Unsupported character set" args -> argsError info b args coreYield :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m @@ -738,7 +740,7 @@ coreYield info b cont handler _env = \case go o mcid = do mpe <- useEvalState esDefPactExec case mpe of - Nothing -> throwExecutionError info YieldOutsiteDefPact + Nothing -> throwExecutionError info YieldOutsideDefPact Just pe -> case mcid of Nothing -> do esDefPactExec . _Just . peYield .== Just (Yield o Nothing Nothing) @@ -746,7 +748,7 @@ coreYield info b cont handler _env = \case Just cid -> do sourceChain <- viewEvalEnv (eePublicData . pdPublicMeta . pmChainId) p <- provenanceOf cid - when (_peStepHasRollback pe) $ failInvariant info "Cross-chain yield not allowed in step with rollback" + when (_peStepHasRollback pe) $ throwExecutionError info $ EvalError "Cross-chain yield not allowed in step with rollback" esDefPactExec . _Just . peYield .== Just (Yield o (Just p) (Just sourceChain)) returnCEKValue cont handler (VObject o) provenanceOf tid = @@ -756,7 +758,8 @@ corePactId :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m corePactId info b cont handler _env = \case [] -> useEvalState esDefPactExec >>= \case Just dpe -> returnCEKValue cont handler (VString (_defpactId (_peDefPactId dpe))) - Nothing -> returnCEK cont handler (VError "pact-id: not in pact execution" info) + Nothing -> + throwExecutionError info NotInDefPactExecution args -> argsError info b args enforceYield @@ -828,7 +831,8 @@ coreEnforceGuard info b cont handler env = \case [VString s] -> do chargeGasArgs info $ GStrOp $ StrOpParse $ T.length s case parseAnyKeysetName s of - Left {} -> returnCEK cont handler (VError "incorrect keyset name format" info) + Left {} -> + throwNativeExecutionError info b "incorrect keyset name format" Right ksn -> isKeysetNameInSigs info cont handler env ksn args -> argsError info b args @@ -837,11 +841,12 @@ keysetRefGuard info b cont handler env = \case [VString g] -> do chargeGasArgs info $ GStrOp $ StrOpParse $ T.length g case parseAnyKeysetName g of - Left {} -> returnCEK cont handler (VError "incorrect keyset name format" info) + Left {} -> throwNativeExecutionError info b "incorrect keyset name format" Right ksn -> do let pdb = view cePactDb env liftDbFunction info (readKeySet pdb ksn) >>= \case - Nothing -> returnCEK cont handler (VError ("no such keyset defined: " <> g) info) + Nothing -> + throwExecutionError info (NoSuchKeySet ksn) Just _ -> returnCEKValue cont handler (VGuard (GKeySetRef ksn)) args -> argsError info b args @@ -859,6 +864,16 @@ coreDec info b cont handler _env = \case [VInteger i] -> returnCEKValue cont handler $ VDecimal $ Decimal 0 i args -> argsError info b args +throwReadError + :: (CEKEval step b i m, MonadEval b i m) + => i + -> Cont step b i m + -> CEKErrorHandler step b i m + -> b + -> m (CEKEvalResult step b i m) +throwReadError info cont handler b = + returnCEKError info cont handler $ EnvReadFunctionFailure (builtinName b) + {- [Note: Parsed Integer] `read-integer` corresponds to prod's `ParsedInteger` newtype. That handles, in particular, the following codecs: @@ -907,10 +922,9 @@ coreReadInteger info b cont handler _env = \case chargeGasArgs info $ GStrOp $ StrOpConvToInt $ T.length raw case parseNumLiteral raw of Just (LInteger i) -> returnCEKValue cont handler (VInteger i) - _ -> returnCEK cont handler (VError "read-integer failure" info) - - _ -> returnCEK cont handler (VError "read-integer failure" info) - _ -> returnCEK cont handler (VError "read-integer failure" info) + _ -> throwReadError info cont handler b + _ -> throwReadError info cont handler b + _ -> throwReadError info cont handler b args -> argsError info b args coreReadMsg :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m @@ -921,8 +935,8 @@ coreReadMsg info b cont handler _env = \case chargeGasArgs info $ GObjOp $ ObjOpLookup s $ M.size envData case M.lookup (Field s) envData of Just pv -> returnCEKValue cont handler (VPactValue pv) - _ -> returnCEK cont handler (VError "read-msg failure" info) - _ -> returnCEK cont handler (VError "read-msg failure: data is not an object" info) + _ -> throwReadError info cont handler b + _ -> throwReadError info cont handler b [] -> do envData <- viewEvalEnv eeMsgBody returnCEKValue cont handler (VPactValue envData) @@ -959,11 +973,12 @@ coreReadDecimal info b cont handler _env = \case case parseNumLiteral raw of Just (LInteger i) -> returnCEKValue cont handler (VDecimal (Decimal 0 i)) Just (LDecimal l) -> returnCEKValue cont handler (VDecimal l) - _ -> returnCEK cont handler (VError "read-decimal failure" info) - _ -> returnCEK cont handler (VError "read-decimal failure" info) - _ -> returnCEK cont handler (VError "read-decimal failure" info) + _ -> throwReadError info cont handler b + _ -> throwReadError info cont handler b + _ -> throwReadError info cont handler b args -> argsError info b args + coreReadString :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m coreReadString info b cont handler _env = \case [VString s] -> do @@ -972,8 +987,8 @@ coreReadString info b cont handler _env = \case chargeGasArgs info $ GObjOp $ ObjOpLookup s $ M.size envData case M.lookup (Field s) envData of Just (PString p) -> returnCEKValue cont handler (VString p) - _ -> returnCEK cont handler (VError "read-string failure" info) - _ -> returnCEK cont handler (VError "read-string failure" info) + _ -> throwReadError info cont handler b + _ -> throwReadError info cont handler b args -> argsError info b args readKeyset' :: (MonadEval b i m) => i -> T.Text -> m (Maybe KeySet) @@ -1024,9 +1039,10 @@ coreReadKeyset info b cont handler _env = \case Just ks -> do shouldEnforce <- isExecutionFlagSet FlagEnforceKeyFormats if shouldEnforce && isLeft (enforceKeyFormats (const ()) ks) - then returnCEK cont handler (VError "Invalid keyset" info) + then + throwExecutionError info (InvalidKeysetFormat ks) else returnCEKValue cont handler (VGuard (GKeyset ks)) - Nothing -> returnCEK cont handler (VError "read-keyset failure" info) + Nothing -> throwReadError info cont handler b args -> argsError info b args @@ -1116,7 +1132,7 @@ dbKeys info b cont handler env = \case dbTxIds :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m dbTxIds info b cont handler env = \case [VTable tv, VInteger tid] -> do - checkNonLocalAllowed info + checkNonLocalAllowed info b let cont' = BuiltinC env info (TxIdsC tv tid) cont guardTable info cont' handler env tv GtTxIds args -> argsError info b args @@ -1125,7 +1141,7 @@ dbTxIds info b cont handler env = \case dbTxLog :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m dbTxLog info b cont handler env = \case [VTable tv, VInteger tid] -> do - checkNonLocalAllowed info + checkNonLocalAllowed info b let cont' = BuiltinC env info (TxLogC tv tid) cont guardTable info cont' handler env tv GtTxLog args -> argsError info b args @@ -1133,7 +1149,7 @@ dbTxLog info b cont handler env = \case dbKeyLog :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m dbKeyLog info b cont handler env = \case [VTable tv, VString key, VInteger tid] -> do - checkNonLocalAllowed info + checkNonLocalAllowed info b let cont' = BuiltinC env info (KeyLogC tv (RowKey key) tid) cont guardTable info cont' handler env tv GtKeyLog args -> argsError info b args @@ -1151,7 +1167,8 @@ defineKeySet' info cont handler env ksname newKs = do let pdb = view cePactDb env ignoreNamespaces <- not <$> isExecutionFlagSet FlagRequireKeysetNs case parseAnyKeysetName ksname of - Left {} -> returnCEK cont handler (VError "incorrect keyset name format" info) + Left {} -> + throwExecutionError info (InvalidKeysetNameFormat ksname) Right ksn -> do let writeKs = do newKsSize <- sizeOf SizeOfV0 newKs @@ -1164,7 +1181,8 @@ defineKeySet' info cont handler env ksname newKs = do isKeysetInSigs info cont' handler env oldKs Nothing | ignoreNamespaces -> writeKs Nothing | otherwise -> useEvalState (esLoaded . loNamespace) >>= \case - Nothing -> returnCEK cont handler (VError "Cannot define a keyset outside of a namespace" info) + Nothing -> + throwExecutionError info CannotDefineKeysetOutsideNamespace Just (Namespace ns uGuard _adminGuard) -> do when (Just ns /= _keysetNs ksn) $ throwExecutionError info (MismatchingKeysetNamespace ns) let cont' = BuiltinC env info (DefineKeysetC ksn newKs) cont @@ -1180,7 +1198,7 @@ defineKeySet info b cont handler env = \case readKeyset' info ksname >>= \case Just newKs -> defineKeySet' info cont handler env ksname newKs - Nothing -> returnCEK cont handler (VError "read-keyset failure" info) + Nothing -> returnCEKError info cont handler $ EnvReadFunctionFailure (builtinName b) args -> argsError info b args -------------------------------------------------- @@ -1216,16 +1234,12 @@ coreEmitEvent :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b coreEmitEvent info b cont handler env = \case [VCapToken ct@(CapToken fqn _)] -> do let cont' = BuiltinC env info (EmitEventC ct) cont - guardForModuleCall info cont' handler env (_fqModule fqn) $ + guardForModuleCall info cont' handler env (_fqModule fqn) $ do -- Todo: this code is repeated in the EmitEventFrame code - lookupFqName fqn >>= \case - Just (DCap d) -> do - enforceMeta (_dcapMeta d) - emitCapability info ct - returnCEKValue cont handler (VBool True) - Just _ -> - failInvariant info "CapToken does not point to defcap" - _ -> failInvariant info "No Capability found in emit-event" + d <- getDefCap info fqn + enforceMeta (_dcapMeta d) + emitCapability info ct + returnCEKValue cont handler (VBool True) where enforceMeta Unmanaged = throwExecutionError info (InvalidEventCap fqn) enforceMeta _ = pure () @@ -1256,7 +1270,7 @@ createModuleGuard info b cont handler _env = \case let cg = GModuleGuard (ModuleGuard mn n) returnCEKValue cont handler (VGuard cg) Nothing -> - returnCEK cont handler (VError "not-in-module" info) + throwNativeExecutionError info b "create-module-guard: must call within module" args -> argsError info b args createDefPactGuard :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m @@ -1271,7 +1285,7 @@ coreIntToStr :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i coreIntToStr info b cont handler _env = \case [VInteger base, VInteger v] | v < 0 -> - returnCEK cont handler (VError "int-to-str error: cannot show negative integer" info) + throwNativeExecutionError info b "int-to-str error: cannot show negative integer" | base >= 2 && base <= 16 -> do let strLen = 1 + Exts.I# (IntLog.integerLogBase# base $ abs v) chargeGasArgs info $ GConcat $ TextConcat $ GasTextLength $ fromIntegral strLen @@ -1283,8 +1297,10 @@ coreIntToStr info b cont handler _env = \case chargeGasArgs info $ GConcat $ TextConcat $ GasTextLength $ fromIntegral strLen let v' = toB64UrlUnpaddedText $ integerToBS v returnCEKValue cont handler (VString v') - | base == 64 -> returnCEK cont handler (VError "only positive values allowed for base64URL conversion" info) - | otherwise -> returnCEK cont handler (VError "invalid base for base64URL conversion" info) + | base == 64 -> + throwNativeExecutionError info b "only positive values allowed for base64URL conversion" + | otherwise -> + throwNativeExecutionError info b "invalid base for base64URL conversion" args -> argsError info b args coreStrToInt :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m @@ -1308,7 +1324,7 @@ coreStrToIntBase info b cont handler _env = \case chargeGasArgs info $ GStrOp $ StrOpParse $ T.length s checkLen info s doBase info cont handler base s - | otherwise -> returnCEK cont handler (VError "Base value must be >= 2 and <= 16, or 64" info) + | otherwise -> throwNativeExecutionError info b $ "Base value must be >= 2 and <= 16, or 64" args -> argsError info b args where -- Todo: DOS and gas analysis @@ -1340,7 +1356,8 @@ coreFormat info b cont handler _env = \case let parts = T.splitOn "{}" s plen = length parts if | plen == 1 -> returnCEKValue cont handler (VString s) - | plen - length es > 1 -> returnCEK cont handler $ VError "format: not enough arguments for template" info + | plen - length es > 1 -> + throwNativeExecutionError info b $ "not enough arguments for template" | otherwise -> do args <- mapM formatArgM $ V.toList es returnCEKValue cont handler $ VString $ T.concat $ alternate parts (take (plen - 1) args) @@ -1444,7 +1461,8 @@ coreWhere info b cont handler _env = \case Just v -> do let cont' = EnforceBoolC info cont applyLam app [VPactValue v] cont' handler - Nothing -> returnCEK cont handler (VError "no such field in object in where application" info) + Nothing -> + throwExecutionError info (ObjectIsMissingField (Field field) (ObjectData o)) args -> argsError info b args coreHash :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m @@ -1477,7 +1495,7 @@ parseTime info b cont handler _env = \case case PactTime.parseTime (T.unpack fmt) (T.unpack s) of Just t -> returnCEKValue cont handler $ VPactValue (PTime t) Nothing -> - returnCEK cont handler (VError "parse-time parse failure" info) + throwNativeExecutionError info b $ "parse-time parse failure" args -> argsError info b args formatTime :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m @@ -1494,7 +1512,7 @@ time info b cont handler _env = \case case PactTime.parseTime "%Y-%m-%dT%H:%M:%SZ" (T.unpack s) of Just t -> returnCEKValue cont handler $ VPactValue (PTime t) Nothing -> - returnCEK cont handler (VError "time default format parse failure" info) + throwNativeExecutionError info b $ "time default format parse failure" args -> argsError info b args addTime :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m @@ -1549,7 +1567,7 @@ describeModule info b cont handler env = \case [VString s] -> case parseModuleName s of Just mname -> do enforceTopLevelOnly info b - checkNonLocalAllowed info + checkNonLocalAllowed info b getModuleData info (view cePactDb env) mname >>= \case ModuleData m _ -> returnCEKValue cont handler $ VObject $ M.fromList $ fmap (over _1 Field) @@ -1561,7 +1579,8 @@ describeModule info b cont handler env = \case [ ("name", PString (renderModuleName (_ifName iface))) , ("hash", PString (moduleHashToText (_ifHash iface))) ] - Nothing -> returnCEK cont handler (VError "invalid module name" info) + Nothing -> + throwNativeExecutionError info b $ "invalid module name format" args -> argsError info b args dbDescribeTable :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m @@ -1585,9 +1604,9 @@ dbDescribeKeySet info b cont handler env = \case Just ks -> returnCEKValue cont handler (VGuard (GKeyset ks)) Nothing -> - returnCEK cont handler (VError ("keyset not found" <> s) info) + throwExecutionError info (NoSuchKeySet ksn) Left{} -> - returnCEK cont handler (VError "invalid keyset name" info) + throwNativeExecutionError info b "incorrect keyset name format" args -> argsError info b args coreCompose :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m @@ -1702,7 +1721,7 @@ coreNamespace info b cont handler env = \case let msg = "Namespace set to " <> n returnCEKValue cont handler (VString msg) Nothing -> - returnCEK cont handler $ VError ("Namespace " <> n <> " not defined") info + throwExecutionError info $ NamespaceNotFound (NamespaceName n) args -> argsError info b args @@ -1710,7 +1729,7 @@ coreDefineNamespace :: (CEKEval step b i m, MonadEval b i m) => NativeFunction s coreDefineNamespace info b cont handler env = \case [VString n, VGuard usrG, VGuard adminG] -> do enforceTopLevelOnly info b - unless (isValidNsFormat n) $ throwExecutionError info (DefineNamespaceError "invalid namespace format") + unless (isValidNsFormat n) $ throwNativeExecutionError info b "invalid namespace format" let pdb = view cePactDb env let nsn = NamespaceName n ns = Namespace nsn usrG adminG @@ -1735,7 +1754,7 @@ coreDefineNamespace info b cont handler env = \case clo <- mkDefunClosure d (qualNameToFqn fun mh) env let cont' = BuiltinC env info (DefineNamespaceC ns) cont applyLam (C clo) [VString n, VGuard adminG] cont' handler - _ -> failInvariant info "Fatal error: namespace manager function is not a defun" + _ -> throwNativeExecutionError info b $ "Fatal error: namespace manager function is not a defun" args -> argsError info b args where isValidNsFormat nsn = case T.uncons nsn of @@ -1765,7 +1784,7 @@ coreDescribeNamespace info b cont handler _env = \case , (Field "namespace-name", PString n)] returnCEKValue cont handler (VObject obj) Nothing -> - returnCEK cont handler (VError ("Namespace not defined " <> n) info) + throwExecutionError info $ NamespaceNotFound (NamespaceName n) args -> argsError info b args @@ -1921,16 +1940,16 @@ poseidonHash info b cont handler _env = \case #else zkPairingCheck :: (MonadEval b i m) => NativeFunction step b i m -zkPairingCheck info _b _cont _handler _env _args = failInvariant info "crypto disabled" +zkPairingCheck info _b _cont _handler _env _args = throwExecutionError info $ EvalError $ "crypto disabled" zkScalarMult :: (MonadEval b i m) => NativeFunction step b i m -zkScalarMult info _b _cont _handler _env _args = failInvariant info "crypto disabled" +zkScalarMult info _b _cont _handler _env _args = throwExecutionError info $ EvalError $ "crypto disabled" zkPointAddition :: (MonadEval b i m) => NativeFunction step b i m -zkPointAddition info _b _cont _handler _env _args = failInvariant info "crypto disabled" +zkPointAddition info _b _cont _handler _env _args = throwExecutionError info $ EvalError $ "crypto disabled" poseidonHash :: (MonadEval b i m) => NativeFunction step b i m -poseidonHash info _b _cont _handler _env _args = failInvariant info "crypto disabled" +poseidonHash info _b _cont _handler _env _args = throwExecutionError info $ EvalError $ "crypto disabled" #endif @@ -1958,12 +1977,12 @@ coreEnforceVerifier info b cont handler _env = \case Just verCaps -> do verifierInScope <- anyCapabilityBeingEvaluated verCaps if verifierInScope then returnCEKValue cont handler (VBool True) - else returnCEK cont handler (VError (verifError verName "not in scope") info) + else returnCEKError info cont handler $ verifError verName "not in scope" Nothing -> - returnCEK cont handler (VError (verifError verName "not in transaction") info) + returnCEKError info cont handler (verifError verName "not in transaction") args -> argsError info b args where - verifError verName msg = "Verifier failure " <> verName <> ":" <> msg + verifError verName msg = VerifierFailure (VerifierName verName) msg ----------------------------------- @@ -1979,8 +1998,6 @@ coreBuiltinEnv coreBuiltinEnv i b env = mkBuiltinFn i b env (coreBuiltinRuntime b) {-# INLINEABLE coreBuiltinEnv #-} --- gassedCompare :: MonadEval b i m => PactValue -> PactValue -> m Ordering --- gassedCompare (PLiteral l) (PLiteral r) = {-# SPECIALIZE coreBuiltinRuntime :: CoreBuiltin diff --git a/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs b/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs index 466911778..88a189355 100644 --- a/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs +++ b/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs @@ -28,7 +28,8 @@ module Pact.Core.IR.Eval.Direct.Evaluator , applyLamUnsafe , evalCap , installCap - , coreBuiltinRuntime) where + , coreBuiltinRuntime + , enforcePactValue) where import Control.Lens hiding (op, from, to, parts) import Control.Monad @@ -37,7 +38,7 @@ import Control.Monad.IO.Class import Data.Text(Text) import Data.List (find) import Data.Foldable (foldl') -import Data.Maybe(catMaybes, isJust) +import Data.Maybe(catMaybes) import Data.List.NonEmpty(NonEmpty(..)) import Data.Bits import Data.Either(isLeft, isRight) @@ -118,7 +119,7 @@ mkDefunClosure d fqn e = case _dfunTerm d of Nullary body i -> pure (Closure fqn NullaryClosure 0 body (_dfunRType d) e i) _ -> - failInvariant (_dfunInfo d) ("definition is not a closure: " <> T.pack (show d)) + failInvariant (_dfunInfo d) (InvariantMalformedDefun fqn) mkDefPactClosure @@ -191,7 +192,7 @@ evaluate env = \case NBound i -> do case RAList.lookup (_ceLocal env) i of Just v -> return v - Nothing -> failInvariant info ("unbound identifier" <> T.pack (show n)) + Nothing -> failInvariant info (InvariantInvalidBoundVariable (_nName n)) -- Top level names are not closures, so we wipe the env NTopLevel mname mh -> do let fqn = FullyQualifiedName mname (_nName n) mh @@ -206,7 +207,7 @@ evaluate env = \case -- this can cause semantic divergences, due to things like provided data. -- moreover defcosts are always evaluated in `SysOnly` mode. TermConst _term -> - failInvariant info "Defconst not fully evaluated" + failInvariant info (InvariantDefConstNotEvaluated fqn) EvaledConst v -> return (VPactValue v) Just (DPact d) -> do @@ -222,20 +223,19 @@ evaluate env = \case clo = CapTokenClosure fqn args (length args) info return (VClosure (CT clo)) Just d -> - throwExecutionError info (InvalidDefKind (defKind mname d) "in var position") + failInvariant info (InvariantInvalidDefKind (defKind mname d) "in var position") Nothing -> - throwExecutionError info (NameNotInScope (FullyQualifiedName mname (_nName n) mh)) + failInvariant info (InvariantUnboundFreeVariable (FullyQualifiedName mname (_nName n) mh)) NModRef m ifs -> case ifs of - [x] -> return (VModRef (ModRef m ifs (Just (S.singleton x)))) - [] -> throwExecutionError info (ModRefNotRefined (_nName n)) - _ -> return (VModRef (ModRef m ifs Nothing)) + [] -> throwExecutionError info (ModRefImplementsNoInterfaces m) + _ -> return (VModRef (ModRef m (S.fromList ifs))) NDynRef (DynamicRef dArg i) -> case RAList.lookup (view ceLocal env) i of Just (VModRef mr) -> do modRefHash <- _mHash <$> getModule info (view cePactDb env) (_mrModule mr) let nk = NTopLevel (_mrModule mr) modRefHash evaluate env (Var (Name dArg nk) info) - Just _ -> throwRecoverableError info "dynamic name pointed to non-modref" - Nothing -> failInvariant info ("unbound identifier" <> T.pack (show n)) + Just _ -> throwExecutionError info (DynNameIsNotModRef dArg) + Nothing -> failInvariant info (InvariantInvalidBoundVariable (_nName n)) Constant l _info -> do return (VLiteral l) App ufn uargs info -> do @@ -282,7 +282,7 @@ evaluate env = \case if b then return (VBool True) else do msg <- enforceString info =<< evaluate env str - throwRecoverableError info msg + throwUserRecoverableError info (UserEnforceError msg) CEnforceOne str conds -> go conds where @@ -293,7 +293,7 @@ evaluate env = \case else go xs go [] = do msg <- enforceString info =<< evaluate env str - throwRecoverableError info msg + throwUserRecoverableError info (UserEnforceError msg) CapabilityForm cf info -> case cf of WithCapability cap body -> do @@ -355,7 +355,8 @@ evalCap info env origToken@(CapToken fqn args) popType ecType contbody = do where go = do d <- getDefCap info fqn - when (length args /= length (_dcapArgs d)) $ failInvariant info "Dcap argument length mismatch" + when (length args /= length (_dcapArgs d)) $ failInvariant info $ + (InvariantArgLengthMismatch fqn (length args) (length (_dcapArgs d))) let newLocals = RAList.fromList $ fmap VPactValue (reverse args) capBody = _dcapTerm d -- Todo: clean up the staircase of doom. @@ -378,7 +379,7 @@ evalCap info env origToken@(CapToken fqn args) popType ecType contbody = do emittedEvent = fqctToPactEvent origToken <$ guard (ecType == NormalCapEval) installCap info env c' False >>= evalUserManagedCap newLocals capBody emittedEvent Nothing -> - throwExecutionError info (CapNotInstalled fqn) + throwExecutionError info (CapNotInstalled qualCapToken) Just managedCap -> do let emittedEvent = fqctToPactEvent origToken <$ guard (ecType == NormalCapEval) evalUserManagedCap newLocals capBody emittedEvent managedCap @@ -395,7 +396,7 @@ evalCap info env origToken@(CapToken fqn args) popType ecType contbody = do let c' = set ctName fqn c installCap info env c' False >>= evalAutomanagedCap emittedEvent newLocals capBody Nothing -> - throwExecutionError info (CapNotInstalled fqn) + throwExecutionError info (CapNotInstalled qualCapToken) Just managedCap -> evalAutomanagedCap emittedEvent newLocals capBody managedCap DefEvent -> do @@ -431,7 +432,7 @@ evalCap info env origToken@(CapToken fqn args) popType ecType contbody = do ManagedParam mpfqn oldV managedIx -> do dfun <- getDefun info mpfqn dfunClo <- mkDefunClosure dfun mpfqn env - newV <- maybe (failInvariant info "Managed param does not exist at index") pure (args ^? ix managedIx) + newV <- maybe (failInvariant info (InvariantInvalidManagedCapIndex managedIx fqn)) pure (args ^? ix managedIx) -- Set the mgr fun to evaluate after we apply the capability body -- NOTE: test-capability doesn't actually run the manager function, it just runs the cap pop then -- pops it. It would be great to do without this, but a lot of our regressions rely on this. @@ -453,10 +454,10 @@ evalCap info env origToken@(CapToken fqn args) popType ecType contbody = do let mcap' = unsafeUpdateManagedParam updatedV managedCap (esCaps . csManaged) %== S.insert mcap' evalWithCapBody info popType (Just qualCapToken) emitted env contbody - _ -> failInvariant info "Invalid managed cap type" + _ -> failInvariant info (InvariantInvalidManagedCapKind "expected user managed, received automanaged") evalAutomanagedCap emittedEvent env' capBody managedCap = case _mcManaged managedCap of AutoManaged b -> do - if b then throwRecoverableError info "Automanaged capability used more than once" + if b then throwUserRecoverableError info OneShotCapAlreadyUsed else do let newManaged = AutoManaged True oldCapsBeingEvaluated <- useEvalState (esCaps.csCapsBeingEvaluated) @@ -468,7 +469,7 @@ evalCap info env origToken@(CapToken fqn args) popType ecType contbody = do (esCaps . csCapsBeingEvaluated) .== oldCapsBeingEvaluated evalWithCapBody info popType Nothing emittedEvent env contbody - _ -> failInvariant info "Invalid managed cap type" + _ -> failInvariant info (InvariantInvalidManagedCapKind "expected automanaged, received user managed") evalWithCapBody :: (MonadEval b i m) @@ -490,7 +491,7 @@ evalWithCapBody info cappop mcap mevent env capbody = do setEvalState (esCaps . csSlots) (CapSlot cap tl:rest) v <- evaluate env capbody popCap info cappop v - [] -> failInvariant info "In CapBodyC but with no caps in stack" + [] -> failInvariant info InvariantEmptyCapStackFailure popCap :: (MonadEval b i m) @@ -507,7 +508,7 @@ popCap info cappop v = case cappop of caps' = over (_head . csComposed) (++ csList) cs setEvalState (esCaps . csSlots) caps' return v - [] -> failInvariant info "Invariant failure: composed cap with empty cap stack" + [] -> failInvariant info InvariantEmptyCapStackFailure @@ -525,9 +526,9 @@ nameToFQN info env (Name n nk) = case nk of Just (VModRef mr) -> do md <- getModule info (view cePactDb env) (_mrModule mr) pure (FullyQualifiedName (_mrModule mr) dArg (_mHash md)) - Just _ -> throwExecutionError info (DynNameIsNotModRef dArg) - Nothing -> failInvariant info ("unbound identifier " <> n) - _ -> failInvariant info ("invalid name in fq position " <> n) + Just _ -> throwExecutionError info (DynNameIsNotModRef n) + Nothing -> failInvariant info (InvariantInvalidBoundVariable n) + _ -> failInvariant info (InvariantInvalidBoundVariable n) guardTable :: (MonadEval b i m) @@ -570,10 +571,14 @@ createUserGuard info fqn args = lookupFqName fqn >>= \case Just (Dfun _) -> return (VGuard (GUserGuard (UserGuard (fqnToQualName fqn) args))) - Just _ -> - throwRecoverableError info "create-user-guard pointing to non-guard" + Just d -> + -- Note: this error is not recoverable in prod + -- :0:26:Error: User guard closure must be defun, found: defcap + -- at :0:7: (create-user-guard ((defcap m.g: ()))) + -- at :0:0: (try 1 (native `create-user-guard` Defines a custom guar...) + throwExecutionError info $ UserGuardMustBeADefun (fqnToQualName fqn) (defKind (_fqModule fqn) d) Nothing -> - failInvariant info "User guard pointing to no defn" + failInvariant info (InvariantUnboundFreeVariable fqn) enforceNotWithinDefcap :: (MonadEval b i m) @@ -587,33 +592,33 @@ enforceNotWithinDefcap info env form = enforceBool :: (MonadEval b i m) => i -> EvalValue b i m -> m Bool enforceBool info = \case VBool b -> pure b - _ -> failInvariant info "Expected bool" + VPactValue v' -> throwExecutionError info (ExpectedBoolValue v') + _ -> throwExecutionError info ExpectedPactValue enforceBool' :: (MonadEval b i m) => i -> EvalValue b i m -> m (EvalValue b i m) enforceBool' info = \case v@VBool{} -> pure v - _ -> failInvariant info "Expected bool" + VPactValue v' -> throwExecutionError info (ExpectedBoolValue v') + _ -> throwExecutionError info ExpectedPactValue enforceString :: (MonadEval b i m) => i -> EvalValue b i m -> m Text enforceString info = \case VString b -> pure b - _ -> failInvariant info "Expected bool" - -enforceStringPV :: (MonadEval b i m) => i -> PactValue -> m Text -enforceStringPV info = \case - PString b -> pure b - _ -> failInvariant info "Expected bool" + VPactValue v' -> throwExecutionError info $ ExpectedStringValue v' + _ -> throwExecutionError info $ ExpectedPactValue enforceCapToken :: (MonadEval b i m) => i -> EvalValue b i m -> m (CapToken FullyQualifiedName PactValue) enforceCapToken info = \case VCapToken b -> pure b - _ -> failInvariant info "Expected cap token" + VPactValue v' -> throwExecutionError info $ ExpectedCapToken v' + _ -> throwExecutionError info $ ExpectedPactValue enforceBoolValue :: (MonadEval b i m) => i -> EvalValue b i m -> m (EvalValue b i m) enforceBoolValue info = \case VBool b -> pure (VBool b) - _ -> failInvariant info "Expected bool" + VPactValue v' -> throwExecutionError info (ExpectedBoolValue v') + _ -> throwExecutionError info ExpectedPactValue enforceUserAppClosure :: (MonadEval b i m) => i -> EvalValue b i m -> m (CanApply b i m) enforceUserAppClosure info = \case @@ -624,7 +629,7 @@ enforceUserAppClosure info = \case DPC clo -> pure (DPC clo) CT clo -> pure (CT clo) _ -> throwExecutionError info CannotApplyPartialClosure - _ -> failInvariant info "Cannot apply non-function to arguments" + _ -> throwExecutionError info CannotApplyValueToNonClosure enforcePactValue :: (MonadEval b i m) => i -> EvalValue b i m -> m PactValue @@ -637,15 +642,15 @@ enforcePactValue' info = \case VPactValue pv -> pure (VPactValue pv) _ -> throwExecutionError info ExpectedPactValue -catchRecoverable :: forall b i m a. (MonadEval b i m) => m a -> (i -> RecoverableError -> m a) -> m a +catchRecoverable :: forall b i m a. (MonadEval b i m) => m a -> (i -> UserRecoverableError -> m a) -> m a catchRecoverable act catch = do eState <- evalStateToErrorState <$> getEvalState catchError act (handler eState) where handler :: ErrorState i -> PactError i -> m a - handler eState (PERecoverableError r i) = do + handler eState (PEUserRecoverableError err _ i) = do modifyEvalState (restoreFromErrorState eState) - catch i r + catch i err handler _ e = throwError e readOnlyEnv :: DirectEnv b i m -> DirectEnv b i m @@ -703,12 +708,12 @@ evalWithStackFrame info sf mty act = do v <- act esStack %== safeTail pv <- enforcePactValue info v - pv' <- maybeTCType info pv mty + maybeTCType info mty pv #ifdef WITH_FUNCALL_TRACING timeExit <- liftIO $ getTime ProcessCPUTime esTraceOutput %== (TraceFunctionExit timeExit sf info:) #endif - return (VPactValue pv') + return (VPactValue pv) {-# INLINE evalWithStackFrame #-} applyLamUnsafe @@ -728,9 +733,9 @@ applyLam vc@(C (Closure fqn ca arity term mty env cloi)) args ArgClosure cloargs -> do chargeGasArgs cloi (GAApplyLam (renderFullyQualName fqn) argLen) args' <- traverse (enforcePactValue cloi) args - tcArgs <- zipWithM (\arg (Arg _ ty _) -> VPactValue <$> maybeTCType cloi arg ty) args' (NE.toList cloargs) + zipWithM_ (\arg (Arg _ ty _) -> maybeTCType cloi ty arg) args' (NE.toList cloargs) let sf = StackFrame fqn args' SFDefun cloi - varEnv = RAList.fromList (reverse tcArgs) + varEnv = RAList.fromList (reverse args) evalWithStackFrame cloi sf mty (evaluate (set ceLocal varEnv env) term) NullaryClosure -> do evalWithStackFrame cloi (StackFrame fqn [] SFDefun cloi) mty $ evaluate (set ceLocal mempty env) term @@ -747,7 +752,8 @@ applyLam vc@(C (Closure fqn ca arity term mty env cloi)) args argLen = length args -- Here we enforce an argument to a user fn is a apply' e (Arg _ ty _:tys) (x:xs) = do - x' <- (\pv -> maybeTCType cloi pv ty) =<< enforcePactValue cloi x + x' <- enforcePactValue cloi x + maybeTCType cloi ty x' apply' (RAList.cons (VPactValue x') e) tys xs apply' e (ty:tys) [] = do let env' = set ceLocal e env @@ -776,7 +782,8 @@ applyLam (LC (LamClosure ca arity term mty env cloi)) args argLen = length args -- Todo: runtime TC here apply' e (Arg _ ty _:tys) (x:xs) = do - x' <- (\pv -> maybeTCType cloi pv ty) =<< enforcePactValue cloi x + x' <- enforcePactValue cloi x + maybeTCType cloi ty x' apply' (RAList.cons (VPactValue x') e) tys xs apply' e [] [] = do evaluate (set ceLocal e env) term @@ -788,7 +795,8 @@ applyLam (PC (PartialClosure li argtys _ term mty env cloi)) args = do apply' (view ceLocal env) (NE.toList argtys) args where apply' e (Arg _ ty _:tys) (x:xs) = do - x' <- (\pv -> maybeTCType cloi pv ty) =<< enforcePactValue cloi x + x' <- enforcePactValue cloi x + maybeTCType cloi ty x' apply' (RAList.cons (VPactValue x') e) tys xs apply' e [] [] = do case li of @@ -828,8 +836,8 @@ applyLam (CT (CapTokenClosure fqn argtys arity i)) args | arity == argLen = do chargeGasArgs i (GAApplyLam (renderQualName (fqnToQualName fqn)) (fromIntegral argLen)) args' <- traverse (enforcePactValue i) args - tcArgs <- zipWithM (\arg ty -> maybeTCType i arg ty) args' argtys - return (VPactValue (PCapToken (CapToken fqn tcArgs))) + zipWithM_ (\arg ty -> maybeTCType i ty arg) args' argtys + return (VPactValue (PCapToken (CapToken fqn args'))) | otherwise = throwExecutionError i ClosureAppliedToTooManyArgs where argLen = length args @@ -839,9 +847,9 @@ applyLam (DPC (DefPactClosure fqn argtys arity env i)) args -- Todo: defpact has much higher overhead, we must charge a bit more gas for this chargeGasArgs i (GAApplyLam (renderQualName (fqnToQualName fqn)) (fromIntegral argLen)) args' <- traverse (enforcePactValue i) args - tcArgs <- zipWithM (\arg (Arg _ ty _) -> maybeTCType i arg ty) args' (NE.toList cloargs) - let pc = DefPactContinuation (fqnToQualName fqn) tcArgs - env' = set ceLocal (RAList.fromList (reverse (VPactValue <$> tcArgs))) env + zipWithM_ (\arg (Arg _ ty _) -> maybeTCType i ty arg) args' (NE.toList cloargs) + let pc = DefPactContinuation (fqnToQualName fqn) args' + env' = set ceLocal (RAList.fromList (reverse args)) env initPact i pc env' NullaryClosure -> do chargeGasArgs i (GAApplyLam (renderQualName (fqnToQualName fqn)) (fromIntegral argLen)) @@ -886,7 +894,8 @@ enforceGuard info env g = case g of curDpid <- getDefPactId info if curDpid == dpid then return True - else throwRecoverableError info "Capability pact guard failed: invalid pact id" + else throwUserRecoverableError info $ + CapabilityPactGuardInvalidPactId curDpid dpid guardForModuleCall :: (MonadEval b i m) @@ -948,26 +957,26 @@ runUserGuard info env (UserGuard qn args) = clo <- mkDefunClosure d (qualNameToFqn qn mh) env' -- Todo: sys only here True <$ (applyLam (C clo) (VPactValue <$> args) >>= enforcePactValue info) - (d, _) -> throwExecutionError info (InvalidDefKind (defKind (_qnModName qn) d) "run-user-guard") + (d, _) -> throwExecutionError info (UserGuardMustBeADefun qn (defKind (_qnModName qn) d)) enforceCapGuard :: (MonadEval b i m) => i -> CapabilityGuard QualifiedName PactValue -> m Bool -enforceCapGuard info (CapabilityGuard qn args mpid) = case mpid of +enforceCapGuard info cg@(CapabilityGuard qn args mpid) = case mpid of Nothing -> enforceCap Just pid -> do currPid <- getDefPactId info if currPid == pid then enforceCap - else throwRecoverableError info "Capability pact guard failed: invalid pact id" + else throwUserRecoverableError info $ + CapabilityPactGuardInvalidPactId currPid pid where enforceCap = do cond <- isCapInStack (CapToken qn args) if cond then return True else do - let errMsg = "Capability guard enforce failure cap not in scope: " <> renderQualName qn - throwRecoverableError info errMsg + throwUserRecoverableError info $ CapabilityGuardNotAcquired cg -- Keyset Code isKeysetInSigs @@ -983,15 +992,11 @@ isKeysetInSigs info env (KeySet kskeys ksPred) = do where matchKey k _ = k `elem` kskeys atLeast t m = m >= t - elide pk = T.take 8 pk <> "..." count = S.size kskeys run p matched = if p count matched then pure True - else do - let - errMsg = "Keyset failure (" <> predicateToText ksPred <> "): " - <> Pretty.renderCompactText (map (elide . renderPublicKeyText) $ S.toList kskeys) - throwRecoverableError info errMsg + else + throwUserRecoverableError info $ KeysetPredicateFailure ksPred kskeys runPred matched = case ksPred of KeysAll -> run atLeast matched @@ -1005,9 +1010,9 @@ isKeysetInSigs info env (KeySet kskeys ksPred) = do (Dfun d, mh) -> do clo <- mkDefunClosure d (qualNameToFqn qn mh) env p <- enforceBool info =<< applyLam (C clo) [VInteger (fromIntegral count), VInteger (fromIntegral matched)] - unless p $ throwRecoverableError info "Keyset enforce failure" + unless p $ throwUserRecoverableError info $ KeysetPredicateFailure ksPred kskeys pure p - _ -> failInvariant info "invalid def type for custom keyset predicate" + _ -> throwExecutionError info (InvalidCustomKeysetPredicate "expected defun") TBN (BareName bn) -> do m <- viewEvalEnv eeNatives case M.lookup bn m of @@ -1015,10 +1020,10 @@ isKeysetInSigs info env (KeySet kskeys ksPred) = do let builtins = view ceBuiltins env let nativeclo = builtins info b env p <- enforceBool info =<< applyLam (N nativeclo) [VInteger (fromIntegral count), VInteger (fromIntegral matched)] - unless p $ throwRecoverableError info "keyset enforce failure" + unless p $ throwUserRecoverableError info $ KeysetPredicateFailure ksPred kskeys pure p Nothing -> - failInvariant info "could not find native definition for custom predicate" + throwExecutionError info (InvalidCustomKeysetPredicate "expected native") isKeysetNameInSigs :: (MonadEval b i m) @@ -1044,10 +1049,10 @@ requireCap -> FQCapToken -> m (EvalValue b i m) requireCap info (CapToken fqn args) = do - capInStack <- isCapInStack (CapToken (fqnToQualName fqn) args) + let qualCapToken = CapToken (fqnToQualName fqn) args + capInStack <- isCapInStack qualCapToken if capInStack then return (VBool True) - else throwRecoverableError info - ("require-capability: not granted: (" <> renderQualName (fqnToQualName fqn) <> ")") + else throwUserRecoverableError info (CapabilityNotGranted qualCapToken) isCapInStack :: (MonadEval b i m) @@ -1118,7 +1123,7 @@ installCap info _env (CapToken fqn args) autonomous = do ctFiltered = CapToken (fqnToQualName fqn) (filterIndex paramIx args) mcap = ManagedCap ctFiltered ct mcapType capAlreadyInstalled <- S.member mcap <$> useEvalState (esCaps . csManaged) - when capAlreadyInstalled $ throwExecutionError info (CapAlreadyInstalled fqn) + when capAlreadyInstalled $ throwExecutionError info (CapAlreadyInstalled ct) (esCaps . csManaged) %== S.insert mcap when autonomous $ (esCaps . csAutonomous) %== S.insert ct @@ -1127,7 +1132,7 @@ installCap info _env (CapToken fqn args) autonomous = do let mcapType = AutoManaged False mcap = ManagedCap ct ct mcapType capAlreadyInstalled <- S.member mcap <$> useEvalState (esCaps . csManaged) - when capAlreadyInstalled $ throwExecutionError info (CapAlreadyInstalled fqn) + when capAlreadyInstalled $ throwExecutionError info (CapAlreadyInstalled ct) (esCaps . csManaged) %== S.insert mcap when autonomous $ (esCaps . csAutonomous) %== S.insert ct @@ -1190,9 +1195,7 @@ applyPact i pc ps cenv nested = useEvalState esDefPactExec >>= \case -- `initPact` ensures that the step is 0, -- and there are guaranteed more than 0 steps due to how the parser is written. -- `resumePact` does a similar check before calling this function. - when (ps ^. psStep >= nSteps) $ failInvariant i "Step not found" - - step <- maybe (failInvariant i "Step not found") pure + step <- maybe (throwExecutionError i (InvalidDefPactStepSupplied ps nSteps)) pure $ _dpSteps defPact ^? ix (ps ^. psStep) let pe = DefPactExec @@ -1218,9 +1221,9 @@ applyPact i pc ps cenv nested = useEvalState esDefPactExec >>= \case -- After evaluation, check the result state useEvalState esDefPactExec >>= \case - Nothing -> failInvariant i "No PactExec found" + Nothing -> failInvariant i $ InvariantPactExecNotInEnv Nothing Just resultExec -> case cenv ^. ceDefPactStep of - Nothing -> failInvariant i "Expected a PactStep in the environment" + Nothing -> failInvariant i (InvariantPactStepNotInEnv Nothing) Just ps' -> do let pdb = view cePactDb cenv @@ -1232,7 +1235,7 @@ applyPact i pc ps cenv nested = useEvalState esDefPactExec >>= \case emitXChainEvents (_psResume ps') resultExec return result - _otherwise -> failInvariant i "defpact continuation does not point to defun" + (_, mh) -> failInvariant i (InvariantExpectedDefPact (qualNameToFqn (pc ^. pcName) mh)) {-# SPECIALIZE applyPact :: () -> DefPactContinuation QualifiedName PactValue @@ -1250,12 +1253,11 @@ applyNestedPact -> DirectEnv b i m -> m (EvalValue b i m) applyNestedPact i pc ps cenv = useEvalState esDefPactExec >>= \case - Nothing -> failInvariant i $ - "applyNestedPact: Nested DefPact attempted but no pactExec found" <> T.pack (show pc) + Nothing -> failInvariant i $ InvariantPactExecNotInEnv Nothing Just pe -> getModuleMemberWithHash i (_cePactDb cenv) (pc ^. pcName) >>= \case (DPact defPact, mh) -> do - step <- maybe (failInvariant i "Step not found") pure + step <- maybe (throwExecutionError i (InvalidDefPactStepSupplied ps (_peStepCount pe))) pure $ _dpSteps defPact ^? ix (ps ^. psStep) let @@ -1302,14 +1304,14 @@ applyNestedPact i pc ps cenv = useEvalState esDefPactExec >>= \case (True, Step{}) -> throwExecutionError i (DefPactStepHasNoRollback ps) useEvalState esDefPactExec >>= \case - Nothing -> failInvariant i "No DefPactExec found" + Nothing -> failInvariant i $ InvariantPactExecNotInEnv Nothing Just resultExec -> do when (nestedPactsNotAdvanced resultExec ps) $ throwExecutionError i (NestedDefpactsNotAdvanced (_peDefPactId resultExec)) let npe = pe & peNestedDefPactExec %~ M.insert (_psDefPactId ps) resultExec setEvalState esDefPactExec (Just npe) return result - _otherwise -> failInvariant i "applyNestedPact: Expected a DefPact bot got something else" + (_, mh) -> failInvariant i (InvariantExpectedDefPact (qualNameToFqn (pc ^. pcName) mh)) {-# SPECIALIZE applyNestedPact :: () -> DefPactContinuation QualifiedName PactValue @@ -1357,7 +1359,7 @@ resumePact i env crossChainContinuation = viewEvalEnv eeDefPactStep >>= \case throwExecutionError i (DefPactIdMismatch (_psDefPactId ps) (_peDefPactId pe)) when (_psStep ps < 0 || _psStep ps >= _peStepCount pe) $ - throwExecutionError i (InvalidDefPactStepSupplied ps pe) + throwExecutionError i (InvalidDefPactStepSupplied ps (_peStepCount pe)) if _psRollback ps then when (_psStep ps /= _peStep pe) $ @@ -1441,7 +1443,7 @@ emitEvent info pe = findCallingModule >>= \case if ctModule == mn then do esEvents %== (++ [pe]) else throwExecutionError info (EventDoesNotMatchModule mn) - Nothing -> failInvariant info "emit-event called outside of module code" + Nothing -> throwExecutionError info (EventDoesNotMatchModule (_peModule pe)) fqctToPactEvent :: CapToken FullyQualifiedName PactValue -> PactEvent PactValue fqctToPactEvent (CapToken fqn args) = PactEvent (_fqName fqn) args (_fqModule fqn) (_fqHash fqn) @@ -2089,8 +2091,7 @@ coreAccess info b _env = \case case M.lookup (Field field) o of Just v -> return (VPactValue v) Nothing -> - let msg = "Object does not have field: " <> field - in throwRecoverableError info msg + throwExecutionError info (ObjectIsMissingField (Field field) (ObjectData o)) args -> argsError info b args coreIsCharset :: (MonadEval b i m) => NativeFunction b i m @@ -2100,7 +2101,7 @@ coreIsCharset info b _env = \case case i of 0 -> return $ VBool $ T.all Char.isAscii s 1 -> return $ VBool $ T.all Char.isLatin1 s - _ -> throwRecoverableError info "Unsupported character set" + _ -> throwNativeExecutionError info b "Unsupported character set" args -> argsError info b args coreYield :: (MonadEval b i m) => NativeFunction b i m @@ -2112,7 +2113,7 @@ coreYield info b _env = \case go o mcid = do mpe <- useEvalState esDefPactExec case mpe of - Nothing -> throwExecutionError info YieldOutsiteDefPact + Nothing -> throwExecutionError info YieldOutsideDefPact Just pe -> case mcid of Nothing -> do esDefPactExec . _Just . peYield .== Just (Yield o Nothing Nothing) @@ -2120,7 +2121,7 @@ coreYield info b _env = \case Just cid -> do sourceChain <- viewEvalEnv (eePublicData . pdPublicMeta . pmChainId) p <- provenanceOf cid - when (_peStepHasRollback pe) $ failInvariant info "Cross-chain yield not allowed in step with rollback" + when (_peStepHasRollback pe) $ throwExecutionError info $ EvalError "Cross-chain yield not allowed in step with rollback" esDefPactExec . _Just . peYield .== Just (Yield o (Just p) (Just sourceChain)) return (VObject o) provenanceOf tid = @@ -2130,7 +2131,7 @@ corePactId :: (MonadEval b i m) => NativeFunction b i m corePactId info b _env = \case [] -> useEvalState esDefPactExec >>= \case Just dpe -> return (VString (_defpactId (_peDefPactId dpe))) - Nothing -> throwRecoverableError info "pact-id: not in pact execution" + Nothing -> throwExecutionError info NotInDefPactExecution args -> argsError info b args enforceYield @@ -2202,7 +2203,7 @@ coreEnforceGuard info b env = \case [VString s] -> do chargeGasArgs info $ GStrOp $ StrOpParse $ T.length s case parseAnyKeysetName s of - Left {} -> throwRecoverableError info "incorrect keyset name format" + Left {} -> throwNativeExecutionError info b "incorrect keyset name format" Right ksn -> VBool <$> isKeysetNameInSigs info env ksn args -> argsError info b args @@ -2212,11 +2213,11 @@ keysetRefGuard info b env = \case [VString g] -> do chargeGasArgs info $ GStrOp $ StrOpParse $ T.length g case parseAnyKeysetName g of - Left {} -> throwRecoverableError info "incorrect keyset name format" + Left {} -> throwNativeExecutionError info b "incorrect keyset name format" Right ksn -> do let pdb = view cePactDb env liftDbFunction info (readKeySet pdb ksn) >>= \case - Nothing -> throwRecoverableError info "no such keyset defined: " + Nothing -> throwExecutionError info (NoSuchKeySet ksn) Just _ -> return (VGuard (GKeySetRef ksn)) args -> argsError info b args @@ -2234,6 +2235,15 @@ coreDec info b _env = \case [VInteger i] -> return $ VDecimal $ Decimal 0 i args -> argsError info b args +-------------------------------------------------- +-- Env-read* functions +-------------------------------------------------- + +-- | Throw a recoverable error to be used in the read-* family of functions +throwReadError :: (MonadError (PactError info) m, MonadEvalState b info m, IsBuiltin b) => info -> b -> m a +throwReadError info b = + throwUserRecoverableError info $ EnvReadFunctionFailure (builtinName b) + {- [Note: Parsed Integer] `read-integer` corresponds to prod's `ParsedInteger` newtype. That handles, in particular, the following codecs: @@ -2282,12 +2292,12 @@ coreReadInteger info b _env = \case chargeGasArgs info $ GStrOp $ StrOpConvToInt $ T.length raw case parseNumLiteral raw of Just (LInteger i) -> return (VInteger i) - _ -> throwRecoverableError info "read-integer failure" - - _ -> throwRecoverableError info "read-integer failure" - _ -> throwRecoverableError info "read-integer failure" + _ -> throwReadError info b + _ -> throwReadError info b + _ -> throwReadError info b args -> argsError info b args + coreReadMsg :: (MonadEval b i m) => NativeFunction b i m coreReadMsg info b _env = \case [VString s] -> do @@ -2296,8 +2306,8 @@ coreReadMsg info b _env = \case chargeGasArgs info $ GObjOp $ ObjOpLookup s $ M.size envData case M.lookup (Field s) envData of Just pv -> return (VPactValue pv) - _ -> throwRecoverableError info "read-msg failure" - _ -> throwRecoverableError info "read-msg failure: data is not an object" + _ -> throwReadError info b + _ -> throwReadError info b [] -> do envData <- viewEvalEnv eeMsgBody return (VPactValue envData) @@ -2334,9 +2344,9 @@ coreReadDecimal info b _env = \case case parseNumLiteral raw of Just (LInteger i) -> return (VDecimal (Decimal 0 i)) Just (LDecimal l) -> return (VDecimal l) - _ -> throwRecoverableError info "read-decimal failure" - _ -> throwRecoverableError info "read-decimal failure" - _ -> throwRecoverableError info "read-decimal failure" + _ -> throwReadError info b + _ -> throwReadError info b + _ -> throwReadError info b args -> argsError info b args coreReadString :: (MonadEval b i m) => NativeFunction b i m @@ -2347,8 +2357,8 @@ coreReadString info b _env = \case chargeGasArgs info $ GObjOp $ ObjOpLookup s $ M.size envData case M.lookup (Field s) envData of Just (PString p) -> return (VString p) - _ -> throwRecoverableError info "read-string failure" - _ -> throwRecoverableError info "read-string failure" + _ -> throwReadError info b + _ -> throwReadError info b args -> argsError info b args readKeyset' :: (MonadEval b i m) => i -> T.Text -> m (Maybe KeySet) @@ -2399,9 +2409,9 @@ coreReadKeyset info b _env = \case Just ks -> do shouldEnforce <- isExecutionFlagSet FlagEnforceKeyFormats if shouldEnforce && isLeft (enforceKeyFormats (const ()) ks) - then throwRecoverableError info "Invalid keyset" + then throwExecutionError info (InvalidKeysetFormat ks) else return (VGuard (GKeyset ks)) - Nothing -> throwRecoverableError info "read-keyset failure" + Nothing -> throwReadError info b args -> argsError info b args @@ -2431,7 +2441,7 @@ dbSelect info b env = \case [VTable tv, VClosure clo] -> selectRead tv clo Nothing [VTable tv, VList li, VClosure clo] -> do - fields' <- traverse (fmap Field . enforceStringPV info) (V.toList li) + fields' <- traverse (fmap Field . asString info b) (V.toList li) selectRead tv clo (Just fields') args -> argsError info b args where @@ -2449,7 +2459,7 @@ dbSelect info b env = \case cond <- enforceBool info =<< applyLam clo [VObject r] if cond then pure $ Just r else pure Nothing - Nothing -> failInvariant info "Select keys returned a key that did not exist" + Nothing -> failInvariant info (InvariantNoSuchKeyInTable (_tvName tv) k) @@ -2471,7 +2481,7 @@ foldDb info b env = \case pure (Just v) else pure Nothing Nothing -> - failInvariant info "foldDB read a key that is not in the database" + failInvariant info (InvariantNoSuchKeyInTable (_tvName tv) rk) pdb = _cePactDb env args -> argsError info b args @@ -2487,7 +2497,7 @@ readUserTable info env tv rk = do liftDbFunction info (_pdbRead (_cePactDb env) (tvToDomain tv) rk) >>= \case Just rd -> return rd - Nothing -> throwRecoverableError info "no such read object" + Nothing -> throwUserRecoverableError info $ NoSuchObjectInDb (_tvName tv) rk dbRead :: (MonadEval b i m) => NativeFunction b i m dbRead info b env = \case @@ -2522,18 +2532,6 @@ dbWrite = write' Write dbInsert :: (MonadEval b i m) => NativeFunction b i m dbInsert = write' Insert -checkSchema :: M.Map Field PactValue -> Schema -> Bool -checkSchema o (Schema _ sc) = isJust $ do - let keys = M.keys o - when (keys /= M.keys sc) Nothing - traverse_ go (M.toList o) - where - go (k, v) = M.lookup k sc >>= (`checkPvType` v) - -checkPartialSchema :: M.Map Field PactValue -> Schema -> Bool -checkPartialSchema o (Schema _ sc) = - M.isSubmapOfBy (\obj ty -> isJust (checkPvType ty obj)) o sc - write' :: (MonadEval b i m) => WriteType -> NativeFunction b i m write' wt info b env = \case [VTable tv, VString key, VObject rv] -> do @@ -2546,7 +2544,7 @@ write' wt info b env = \case chargeGasArgs info (GWrite rvSize) _ <- liftGasM info $ _pdbWrite pdb wt (tvToDomain tv) (RowKey key) rdata return (VString "Write succeeded") - else throwRecoverableError info "object does not match schema" + else throwExecutionError info (WriteValueDidNotMatchSchema (_tvSchema tv) (ObjectData rv)) args -> argsError info b args dbUpdate :: (MonadEval b i m) => NativeFunction b i m @@ -2567,7 +2565,7 @@ dbKeys info b env = \case dbTxIds :: (MonadEval b i m) => NativeFunction b i m dbTxIds info b env = \case [VTable tv, VInteger tid] -> do - checkNonLocalAllowed info + checkNonLocalAllowed info b guardTable info env tv GtTxIds let pdb = _cePactDb env ks <- liftDbFunction info (_pdbTxIds pdb (_tvName tv) (TxId (fromIntegral tid))) @@ -2579,7 +2577,7 @@ dbTxIds info b env = \case dbTxLog :: (MonadEval b i m) => NativeFunction b i m dbTxLog info b env = \case [VTable tv, VInteger tid] -> do - checkNonLocalAllowed info + checkNonLocalAllowed info b guardTable info env tv GtTxLog let txId = TxId (fromInteger tid) pdb = _cePactDb env @@ -2597,7 +2595,7 @@ dbTxLog info b env = \case dbKeyLog :: (MonadEval b i m) => NativeFunction b i m dbKeyLog info b env = \case [VTable tv, VString key, VInteger tid] -> do - checkNonLocalAllowed info + checkNonLocalAllowed info b -- let cont' = BuiltinC env info (KeyLogC tv (RowKey key) tid) cont guardTable info env tv GtKeyLog let txId = TxId (fromInteger tid) @@ -2625,7 +2623,7 @@ defineKeySet' info env ksname newKs = do let pdb = view cePactDb env ignoreNamespaces <- not <$> isExecutionFlagSet FlagRequireKeysetNs case parseAnyKeysetName ksname of - Left {} -> throwRecoverableError info "incorrect keyset name format" + Left {} -> throwExecutionError info (InvalidKeysetNameFormat ksname) Right ksn -> do let writeKs = do newKsSize <- sizeOf SizeOfV0 newKs @@ -2638,7 +2636,7 @@ defineKeySet' info env ksname newKs = do writeKs Nothing | ignoreNamespaces -> writeKs Nothing | otherwise -> useEvalState (esLoaded . loNamespace) >>= \case - Nothing -> throwRecoverableError info "Cannot define a keyset outside of a namespace" + Nothing -> throwExecutionError info CannotDefineKeysetOutsideNamespace Just (Namespace ns uGuard _adminGuard) -> do when (Just ns /= _keysetNs ksn) $ throwExecutionError info (MismatchingKeysetNamespace ns) _ <- enforceGuard info env uGuard @@ -2654,7 +2652,7 @@ defineKeySet info b env = \case readKeyset' info ksname >>= \case Just newKs -> defineKeySet' info env ksname newKs - Nothing -> throwRecoverableError info "read-keyset failure" + Nothing -> throwUserRecoverableError info $ EnvReadFunctionFailure (builtinName b) args -> argsError info b args -------------------------------------------------- @@ -2672,13 +2670,9 @@ requireCapability info b _env = \case composeCapability :: (MonadEval b i m) => NativeFunction b i m composeCapability info b env = \case - [VCapToken ct] -> - useEvalState esStack >>= \case - sf:_ -> do - -- Todo: compose-capability called outside of capability needs a better error - when (_sfFnType sf /= SFDefcap) $ failInvariant info "compose-cap" - composeCap info env ct - _ -> failInvariant info "compose-cap at the top level" + [VCapToken ct] -> do + enforceStackTopIsDefcap info b + composeCap info env ct args -> argsError info b args installCapability :: (MonadEval b i m) => NativeFunction b i m @@ -2694,14 +2688,10 @@ coreEmitEvent info b env = \case [VCapToken ct@(CapToken fqn _)] -> do -- let cont' = BuiltinC env info (EmitEventC ct) cont guardForModuleCall info env (_fqModule fqn) $ return () - lookupFqName fqn >>= \case - Just (DCap d) -> do - enforceMeta (_dcapMeta d) - emitCapability info ct - return (VBool True) - Just _ -> - failInvariant info "CapToken does not point to defcap" - _ -> failInvariant info "No Capability found in emit-event" + d <- getDefCap info fqn + enforceMeta (_dcapMeta d) + emitCapability info ct + return (VBool True) where enforceMeta Unmanaged = throwExecutionError info (InvalidEventCap fqn) enforceMeta _ = pure () @@ -2732,7 +2722,7 @@ createModuleGuard info b _env = \case let cg = GModuleGuard (ModuleGuard mn n) return (VGuard cg) Nothing -> - throwRecoverableError info "not-in-module" + throwNativeExecutionError info b "create-module-guard: must call within module" args -> argsError info b args createDefPactGuard :: (MonadEval b i m) => NativeFunction b i m @@ -2747,7 +2737,7 @@ coreIntToStr :: (MonadEval b i m) => NativeFunction b i m coreIntToStr info b _env = \case [VInteger base, VInteger v] | v < 0 -> - throwRecoverableError info "int-to-str error: cannot show negative integer" + throwNativeExecutionError info b "int-to-str error: cannot show negative integer" | base >= 2 && base <= 16 -> do let strLen = 1 + Exts.I# (IntLog.integerLogBase# base $ abs v) chargeGasArgs info $ GConcat $ TextConcat $ GasTextLength $ fromIntegral strLen @@ -2759,8 +2749,8 @@ coreIntToStr info b _env = \case chargeGasArgs info $ GConcat $ TextConcat $ GasTextLength $ fromIntegral strLen let v' = toB64UrlUnpaddedText $ integerToBS v return (VString v') - | base == 64 -> throwRecoverableError info "only positive values allowed for base64URL conversion" - | otherwise -> throwRecoverableError info "invalid base for base64URL conversion" + | base == 64 -> throwNativeExecutionError info b "only positive values allowed for base64URL conversion" + | otherwise -> throwNativeExecutionError info b "invalid base for base64URL conversion" args -> argsError info b args coreStrToInt :: (MonadEval b i m) => NativeFunction b i m @@ -2784,7 +2774,7 @@ coreStrToIntBase info b _env = \case chargeGasArgs info $ GStrOp $ StrOpParse $ T.length s checkLen info s doBase info base s - | otherwise -> throwRecoverableError info "Base value must be >= 2 and <= 16, or 64" + | otherwise -> throwNativeExecutionError info b $ "Base value must be >= 2 and <= 16, or 64" args -> argsError info b args where -- Todo: DOS and gas analysis @@ -2817,7 +2807,7 @@ coreFormat info b _env = \case plen = length parts if | plen == 1 -> return (VString s) | plen - length es > 1 -> - throwRecoverableError info "format: not enough arguments for template" + throwNativeExecutionError info b $ "not enough arguments for template" | otherwise -> do args <- traverse formatArgM $ V.toList es return $ VString $ T.concat $ alternate parts (take (plen - 1) args) @@ -2919,7 +2909,8 @@ coreWhere info b _env = \case case M.lookup (Field field) o of Just v -> do applyLam app [VPactValue v] >>= enforceBool' info - Nothing -> throwRecoverableError info "no such field in object in where application" + Nothing -> + throwExecutionError info (ObjectIsMissingField (Field field) (ObjectData o)) args -> argsError info b args coreHash :: (MonadEval b i m) => NativeFunction b i m @@ -2952,7 +2943,7 @@ parseTime info b _env = \case case PactTime.parseTime (T.unpack fmt) (T.unpack s) of Just t -> return $ VPactValue (PTime t) Nothing -> - throwRecoverableError info "parse-time parse failure" + throwNativeExecutionError info b $ "parse-time parse failure" args -> argsError info b args formatTime :: (MonadEval b i m) => NativeFunction b i m @@ -2969,7 +2960,7 @@ time info b _env = \case case PactTime.parseTime "%Y-%m-%dT%H:%M:%SZ" (T.unpack s) of Just t -> return $ VPactValue (PTime t) Nothing -> - throwRecoverableError info "time default format parse failure" + throwNativeExecutionError info b $ "time default format parse failure" args -> argsError info b args addTime :: (MonadEval b i m) => NativeFunction b i m @@ -3024,7 +3015,7 @@ describeModule info b env = \case [VString s] -> case parseModuleName s of Just mname -> do enforceTopLevelOnly info b - checkNonLocalAllowed info + checkNonLocalAllowed info b getModuleData info (view cePactDb env) mname >>= \case ModuleData m _ -> return $ VObject $ M.fromList $ fmap (over _1 Field) @@ -3036,7 +3027,7 @@ describeModule info b env = \case [ ("name", PString (renderModuleName (_ifName iface))) , ("hash", PString (moduleHashToText (_ifHash iface))) ] - Nothing -> throwRecoverableError info "invalid module name" + Nothing -> throwNativeExecutionError info b $ "invalid module name format" args -> argsError info b args dbDescribeTable :: (MonadEval b i m) => NativeFunction b i m @@ -3060,9 +3051,9 @@ dbDescribeKeySet info b env = \case Just ks -> return (VGuard (GKeyset ks)) Nothing -> - throwRecoverableError info ("keyset not found" <> s) + throwExecutionError info (NoSuchKeySet ksn) Left{} -> - throwRecoverableError info "invalid keyset name" + throwNativeExecutionError info b "incorrect keyset name format" args -> argsError info b args coreCompose :: (MonadEval b i m) => NativeFunction b i m @@ -3178,7 +3169,7 @@ coreNamespace info b env = \case let msg = "Namespace set to " <> n return (VString msg) Nothing -> - throwRecoverableError info ("Namespace " <> n <> " not defined") + throwExecutionError info $ NamespaceNotFound (NamespaceName n) args -> argsError info b args @@ -3186,7 +3177,7 @@ coreDefineNamespace :: (MonadEval b i m) => NativeFunction b i m coreDefineNamespace info b env = \case [VString n, VGuard usrG, VGuard adminG] -> do enforceTopLevelOnly info b - unless (isValidNsFormat n) $ throwExecutionError info (DefineNamespaceError "invalid namespace format") + unless (isValidNsFormat n) $ throwNativeExecutionError info b "invalid namespace format" let nsn = NamespaceName n ns = Namespace nsn usrG adminG chargeGasArgs info $ GRead $ fromIntegral $ T.length n @@ -3210,12 +3201,12 @@ coreDefineNamespace info b env = \case clo <- mkDefunClosure d (qualNameToFqn fun mh) env allow <- enforceBool info =<< applyLam (C clo) [VString n, VGuard adminG] writeNs allow nsn ns - _ -> failInvariant info "Fatal error: namespace manager function is not a defun" + _ -> throwNativeExecutionError info b $ "Fatal error: namespace manager function is not a defun" args -> argsError info b args where pdb = _cePactDb env writeNs allow nsn ns = do - unless allow $ throwExecutionError info $ DefineNamespaceError "Namespace definition not permitted" + unless allow $ throwNativeExecutionError info b $ "Namespace definition not permitted" nsSize <- sizeOf SizeOfV0 ns chargeGasArgs info (GWrite nsSize) liftGasM info $ _pdbWrite pdb Write DNamespaces nsn ns @@ -3247,7 +3238,7 @@ coreDescribeNamespace info b _env = \case , (Field "namespace-name", PString n)] return (VObject obj) Nothing -> - throwRecoverableError info ("Namespace not defined " <> n) + throwExecutionError info $ NamespaceNotFound (NamespaceName n) args -> argsError info b args @@ -3440,12 +3431,12 @@ coreEnforceVerifier info b _env = \case Just verCaps -> do verifierInScope <- anyCapabilityBeingEvaluated verCaps if verifierInScope then return (VBool True) - else throwRecoverableError info $ verifError verName "not in scope" + else throwUserRecoverableError info $ verifError verName "not in scope" Nothing -> - throwRecoverableError info $ (verifError verName "not in transaction") + throwUserRecoverableError info $ (verifError verName "not in transaction") args -> argsError info b args where - verifError verName msg = "Verifier failure " <> verName <> ":" <> msg + verifError verName msg = VerifierFailure (VerifierName verName) msg diff --git a/pact/Pact/Core/IR/Eval/Direct/ReplBuiltin.hs b/pact/Pact/Core/IR/Eval/Direct/ReplBuiltin.hs index 9110135d1..262a568a2 100644 --- a/pact/Pact/Core/IR/Eval/Direct/ReplBuiltin.hs +++ b/pact/Pact/Core/IR/Eval/Direct/ReplBuiltin.hs @@ -71,17 +71,15 @@ coreExpect info b _env = \case es <- getEvalState tryError (applyLamUnsafe provided []) >>= \case Right (VPactValue v2) -> do - applyLamUnsafe expected [] >>= \case - VPactValue v1 -> do + applyLamUnsafe expected [] >>= enforcePactValue info >>= \case + v1 -> do if v1 /= v2 then do let v1s = prettyShowValue (VPactValue v1) v2s = prettyShowValue (VPactValue v2) return $ VLiteral $ LString $ "FAILURE: " <> msg <> " expected: " <> v1s <> ", received: " <> v2s else return (VLiteral (LString ("Expect: success " <> msg))) - _ -> - throwRecoverableError info "evaluation within expect did not return a pact value" Right _v -> - throwRecoverableError info "FAILURE: expect expression did not return a pact value for comparison" + throwUserRecoverableError info $ UserEnforceError "FAILURE: expect expression did not return a pact value for comparison" Left err -> do putEvalState es currSource <- use replCurrSource @@ -95,8 +93,8 @@ coreExpectThat info b _env = \case applyLamUnsafe vclo [v] >>= \case VLiteral (LBool c) -> if c then return (VLiteral (LString ("Expect-that: success " <> msg))) - else return (VLiteral (LString ("FAILURE: Expect-that: Did not satisfy condition: " <> msg))) - _ -> throwRecoverableError info "Expect-that: condition did not return a boolean" + else return (VLiteral (LString ("FAILURE: Expect-that: Did not satisfy condition: " <> msg))) + _ -> throwNativeExecutionError info b "Expect-that: condition did not return a boolean" args -> argsError info b args coreExpectFailure :: NativeFunction ReplCoreBuiltin SpanInfo (ReplM ReplCoreBuiltin) @@ -104,7 +102,7 @@ coreExpectFailure info b _env = \case [VString doc, VClosure vclo] -> do es <- getEvalState tryError (applyLamUnsafe vclo []) >>= \case - Left (PERecoverableError _ _) -> do + Left (PEUserRecoverableError _ _ _) -> do putEvalState es return $ VLiteral $ LString $ "Expect failure: Success: " <> doc Left _err -> do @@ -115,8 +113,9 @@ coreExpectFailure info b _env = \case [VString desc, VString toMatch, VClosure vclo] -> do es <- getEvalState tryError (applyLamUnsafe vclo []) >>= \case - Left (PERecoverableError (RecoverableError err) _) -> do + Left (PEUserRecoverableError userErr _ _) -> do putEvalState es + let err = renderCompactText userErr if toMatch `T.isInfixOf` err then return $ VLiteral $ LString $ "Expect failure: Success: " <> desc else return $ VLiteral $ LString $ @@ -179,7 +178,7 @@ pactState info b _env = \case ,(Field "yield", yield') ,(Field "step", PInteger (fromIntegral (_peStep pe)))] return (VObject (M.fromList ps)) - Nothing -> throwRecoverableError info "pact-state: no pact exec in context" + Nothing -> throwUserRecoverableError info $ UserEnforceError "pact-state: no pact exec in context" coreplEvalEnvStackFrame :: NativeFunction ReplCoreBuiltin SpanInfo (ReplM ReplCoreBuiltin) coreplEvalEnvStackFrame info b _env = \case @@ -208,7 +207,7 @@ envHash :: NativeFunction ReplCoreBuiltin SpanInfo (ReplM ReplCoreBuiltin) envHash info b _env = \case [VString s] -> do case decodeBase64UrlUnpadded (T.encodeUtf8 s) of - Left e -> throwRecoverableError info (T.pack e) + Left e -> throwUserRecoverableError info $ UserEnforceError (T.pack e) Right hs -> do (replEvalEnv . eeHash) .= Hash (toShort hs) return $ VString $ "Set tx hash to " <> s @@ -252,7 +251,7 @@ envChainData info b _env = \case PTime time | k == cdBlockTime -> go (set pdBlockTime (PactTime.toPosixTimestampMicros time) pd) rest _ -> - throwRecoverableError info ("envChainData: bad public metadata value for key: " <> _field k) + throwUserRecoverableError info $ UserEnforceError $ "envChainData: bad public metadata value for key: " <> _field k args -> argsError info b args envKeys :: NativeFunction ReplCoreBuiltin SpanInfo (ReplM ReplCoreBuiltin) @@ -270,7 +269,8 @@ envSigs info b _env = \case Just sigs -> do (replEvalEnv . eeMsgSigs) .= M.fromList (V.toList sigs) return $ VString "Setting transaction signatures/caps" - Nothing -> throwRecoverableError info ("env-sigs format is wrong") + Nothing -> throwUserRecoverableError info $ + UserEnforceError ("env-sigs: Expected object with 'key': string, 'caps': [capability]") where keyCapObj = \case PObject o -> do @@ -294,7 +294,7 @@ renderTx :: MonadEval b i m => i -> Text -> Maybe (TxId, Maybe Text) -> m (EvalV renderTx _info start (Just (TxId tid, mt)) = return $ VString $ start <> " " <> T.pack (show tid) <> maybe mempty (" " <>) mt renderTx info start Nothing = - throwRecoverableError info ("tx-function failure " <> start) + throwUserRecoverableError info $ UserEnforceError ("tx-function failure " <> start) begin' :: SpanInfo -> Maybe Text -> ReplM b (Maybe (TxId, Maybe Text)) begin' info mt = do @@ -354,18 +354,15 @@ sigKeyset info b _env = \case testCapability :: NativeFunction ReplCoreBuiltin SpanInfo (ReplM ReplCoreBuiltin) testCapability info b env = \case [VCapToken origToken] -> do - lookupFqName (_ctName origToken) >>= \case - Just (DCap d) -> do - let cBody = Constant LUnit info - -- cont' = SeqC env cBody cont - case _dcapMeta d of - Unmanaged -> do - evalCap info env origToken PopCapInvoke TestCapEval cBody - _ -> do - -- Installed caps emit and event - -- so we create a fake stack frame - installCap info env origToken False *> evalCap info env origToken PopCapInvoke TestCapEval cBody - _ -> throwRecoverableError info "no such capability" + d <- getDefCap info (_ctName origToken) + let cBody = Constant LUnit info + case _dcapMeta d of + Unmanaged -> do + evalCap info env origToken PopCapInvoke TestCapEval cBody + _ -> do + -- Installed caps emit and event + -- so we create a fake stack frame + installCap info env origToken False *> evalCap info env origToken PopCapInvoke TestCapEval cBody args -> argsError info b args envExecConfig :: NativeFunction ReplCoreBuiltin SpanInfo (ReplM ReplCoreBuiltin) @@ -389,14 +386,15 @@ envNamespacePolicy info b _env = \case [VBool allowRoot, VClosure (C clo)] -> do pdb <- viewEvalEnv eePactDb let qn = fqnToQualName (_cloFqName clo) - when (_cloArity clo /= 2) $ failInvariant info "Namespace manager function has invalid argument length" + when (_cloArity clo /= 2) $ + throwNativeExecutionError info b "Namespace manager function has invalid argument length" getModuleMember info pdb qn >>= \case Dfun _ -> do let nsp = SmartNamespacePolicy allowRoot qn replEvalEnv . eeNamespacePolicy .= nsp return (VString "Installed namespace policy") _ -> - throwRecoverableError info "invalid namespace manager function type" + throwUserRecoverableError info $ UserEnforceError "invalid namespace manager function type" args -> argsError info b args envGas :: NativeFunction ReplCoreBuiltin SpanInfo (ReplM ReplCoreBuiltin) @@ -527,7 +525,7 @@ envVerifiers info b _env = \case (replEvalEnv . eeMsgVerifiers) .= M.fromList (V.toList sigs) return $ VString "Setting transaction verifiers/caps" Nothing -> - throwRecoverableError info ("env-verifiers: Expected object with 'name': string, 'caps': [capability]") + throwNativeExecutionError info b ("Expected object with 'name': string, 'caps': [capability]") where verifCapObj = \case PObject o -> do diff --git a/pact/Pact/Core/IR/Eval/Runtime/Utils.hs b/pact/Pact/Core/IR/Eval/Runtime/Utils.hs index b52c8be76..cb92d8d2c 100644 --- a/pact/Pact/Core/IR/Eval/Runtime/Utils.hs +++ b/pact/Pact/Core/IR/Eval/Runtime/Utils.hs @@ -20,7 +20,6 @@ module Pact.Core.IR.Eval.Runtime.Utils , asString , asBool , throwExecutionError - , throwExecutionError' , findCallingModule , getCallingModule , calledByModule @@ -41,12 +40,15 @@ module Pact.Core.IR.Eval.Runtime.Utils , enforceBlessedHashes , enforceStackTopIsDefcap , anyCapabilityBeingEvaluated + , checkSchema + , checkPartialSchema ) where import Control.Lens -import Control.Monad(when) +import Control.Monad import Control.Monad.IO.Class import Data.IORef +import Data.Monoid import Data.Foldable(find, toList) import Data.Maybe(listToMaybe) import Data.Text(Text) @@ -57,7 +59,6 @@ import Pact.Core.Names import Pact.Core.PactValue import Pact.Core.Builtin import Pact.Core.IR.Term -import Pact.Core.ModRefs import Pact.Core.Type import Pact.Core.Errors import Pact.Core.IR.Eval.Runtime.Types @@ -78,30 +79,27 @@ lookupFqName fqn = getDefCap :: (MonadEval b i m) => i -> FullyQualifiedName -> m (EvalDefCap b i) getDefCap info fqn = lookupFqName fqn >>= \case Just (DCap d) -> pure d - Just _ -> failInvariant info "Expected DefCap" - _ -> failInvariant info "Expected DefCap; got nothing" + Just _ -> failInvariant info (InvariantExpectedDefCap fqn) + _ -> failInvariant info (InvariantUnboundFreeVariable fqn) getDefun :: (MonadEval b i m) => i -> FullyQualifiedName -> m (EvalDefun b i) getDefun info fqn = lookupFqName fqn >>= \case Just (Dfun d) -> pure d - _ -> failInvariant info "Expected Defun" + Just _ -> failInvariant info (InvariantExpectedDefun fqn) + _ -> failInvariant info (InvariantUnboundFreeVariable fqn) unsafeUpdateManagedParam :: v -> ManagedCap name v -> ManagedCap name v unsafeUpdateManagedParam newV (ManagedCap mc orig (ManagedParam fqn _oldV i)) = ManagedCap mc orig (ManagedParam fqn newV i) unsafeUpdateManagedParam _ a = a -typecheckArgument :: (MonadEval b i m) => i -> PactValue -> Type -> m PactValue -typecheckArgument info pv ty = case (pv, checkPvType ty pv) of - (PModRef mr, Just (TyModRef m)) - | _mrRefined mr == Nothing -> pure (PModRef (mr & mrRefined ?~ m)) - | otherwise -> pure (PModRef mr) - (_, Just _) -> pure pv - (_, Nothing) -> - throwExecutionError info (RunTimeTypecheckFailure (pvToArgTypeError pv) ty) +typecheckArgument :: (MonadEval b i m) => i -> PactValue -> Type -> m () +typecheckArgument info pv ty = + unless (checkPvType ty pv) $ throwExecutionError info (RunTimeTypecheckFailure (pvToArgTypeError pv) ty) + +maybeTCType :: (MonadEval b i m) => i -> Maybe Type -> PactValue -> m () +maybeTCType i mty pv = maybe (pure ()) (typecheckArgument i pv) mty -maybeTCType :: (MonadEval b i m) => i -> PactValue -> Maybe Type -> m PactValue -maybeTCType i pv = maybe (pure pv) (typecheckArgument i pv) pvToArgTypeError :: PactValue -> ArgTypeError pvToArgTypeError = \case @@ -132,20 +130,18 @@ calledByModule mn = do -- an error which we do not expect to see during regular pact -- execution. If this case is ever hit, we have a problem with -- some invalid state in interpretation -failInvariant :: MonadEval b i m => i -> Text -> m a +failInvariant :: MonadEval b i m => i -> InvariantError -> m a failInvariant i reason = throwExecutionError i (InvariantFailure reason) -- Todo: MaybeT cleans this up getCallingModule :: (MonadEval b i m) => i -> m (EvalModule b i) getCallingModule info = findCallingModule >>= \case - Just mn -> useEvalState (esLoaded . loModules . at mn) >>= \case - Just (ModuleData m _) -> pure m - Just (InterfaceData _m _) -> - failInvariant info "getCallingModule points to interface" - Nothing -> - failInvariant info "getCallingModule points to no loaded module" - Nothing -> failInvariant info "Error: No Module in stack" + Just mn -> do + pdb <- viewEvalEnv eePactDb + getModule info pdb mn + Nothing -> + throwExecutionError info (EvalError "no module call in stack") safeTail :: [a] -> [a] safeTail (_:xs) = xs @@ -162,12 +158,12 @@ restoreFromErrorState :: ErrorState i -> EvalState b i -> EvalState b i restoreFromErrorState (ErrorState caps stack recur) = set esCaps caps . set esStack stack . set esCheckRecursion recur -checkNonLocalAllowed :: (MonadEval b i m) => i -> m () -checkNonLocalAllowed info = do +checkNonLocalAllowed :: (MonadEval b i m) => i -> b -> m () +checkNonLocalAllowed info b = do disabledInTx <- isExecutionFlagSet FlagDisableHistoryInTransactionalMode mode <- viewEvalEnv eeMode - when (mode == Transactional && disabledInTx) $ failInvariant info - "Operation only permitted in local execution mode" + when (mode == Transactional && disabledInTx) $ throwExecutionError info $ + OperationIsLocalOnly (builtinName b) {-# SPECIALIZE asString :: () @@ -201,6 +197,14 @@ asBool _ _ (PLiteral (LBool b)) = pure b asBool info b pv = throwExecutionError info (NativeArgumentsError (builtinName b) [pvToArgTypeError pv]) +checkSchema :: M.Map Field PactValue -> Schema -> Bool +checkSchema o (Schema _ sc) = + M.size o == M.size sc && + getAll (M.foldMapWithKey (\k v -> All $ maybe False (`checkPvType` v) (M.lookup k sc)) o) + +checkPartialSchema :: M.Map Field PactValue -> Schema -> Bool +checkPartialSchema o (Schema _ sc) = + M.isSubmapOfBy (\obj ty -> checkPvType ty obj) o sc getDefPactId :: (MonadEval b i m) => i -> m DefPactId @@ -345,14 +349,13 @@ enforceStackTopIsDefcap -> b -> m () enforceStackTopIsDefcap info b = do - let (NativeName n) = builtinName b - let errMsg = "native execution failed, native must be called within a defcap body: " <> n + let errMsg = "native must be called within a defcap body" useEvalState esStack >>= \case sf:_ -> do when (_sfFnType sf /= SFDefcap) $ - throwExecutionError info (EvalError errMsg) + throwNativeExecutionError info b errMsg _ -> - throwExecutionError info (EvalError errMsg) + throwNativeExecutionError info b errMsg anyCapabilityBeingEvaluated diff --git a/pact/Pact/Core/IR/Term.hs b/pact/Pact/Core/IR/Term.hs index 27a5b6379..eb3fadc8d 100644 --- a/pact/Pact/Core/IR/Term.hs +++ b/pact/Pact/Core/IR/Term.hs @@ -401,8 +401,8 @@ instance Pretty ty => Pretty (DefCap name ty b i) where instance Pretty ty => Pretty (DefSchema ty info) where pretty (DefSchema n schema i) = - let argList = [pretty arg | (Field k, t) <- M.toList schema, let arg = Arg k (Just t) i] - in parens $ "defschema" <+> pretty n <> (if null argList then mempty else " " <> hsep argList) + let argList = [Arg k (Just t) i | (Field k, t) <- M.toList schema] + in pretty $ PrettyLispApp ("defschema " <> n) argList instance Pretty (TableSchema name) where pretty (DesugaredTable pn) = pretty pn diff --git a/pact/Pact/Core/Legacy/LegacyPactValue.hs b/pact/Pact/Core/Legacy/LegacyPactValue.hs index 4688c9713..4c39837e7 100644 --- a/pact/Pact/Core/Legacy/LegacyPactValue.hs +++ b/pact/Pact/Core/Legacy/LegacyPactValue.hs @@ -162,8 +162,7 @@ instance FromJSON (Legacy ModRef) where parseJSON = withObject "ModRef" $ \o -> fmap Legacy $ ModRef <$> (_unLegacy <$> o .: "refName") - <*> (fmap _unLegacy <$> o .: "refSpec") - <*> pure Nothing + <*> (S.fromList . fmap _unLegacy <$> o .: "refSpec") instance FromJSON (Legacy PactValue) where parseJSON v = fmap Legacy $ diff --git a/pact/Pact/Core/ModRefs.hs b/pact/Pact/Core/ModRefs.hs index 149967a9d..198fb71f2 100644 --- a/pact/Pact/Core/ModRefs.hs +++ b/pact/Pact/Core/ModRefs.hs @@ -5,37 +5,33 @@ module Pact.Core.ModRefs ( ModRef(..) , mrModule , mrImplemented - , mrRefined ) where import Control.Lens import Control.DeepSeq import Data.Set(Set) import GHC.Generics +import qualified Data.Set as S import Pact.Core.Names import Pact.Core.Pretty -import qualified Data.Set as S -- | Original module reference data ModRef = ModRef { _mrModule :: ModuleName -- ^ Original module - , _mrImplemented :: [ModuleName] + , _mrImplemented :: Set ModuleName -- ^ All implemented interfaces - , _mrRefined :: Maybe (Set ModuleName) --- ^ The "Selected" interface from a type refinement } deriving (Show, Generic) instance NFData ModRef instance Pretty ModRef where - pretty (ModRef _mn _imp mref) = case mref of - Just ref -> "module" <> braces (pretty (S.toList ref)) - Nothing -> "module" + pretty (ModRef _mn imps) = + "module" <> braces (pretty (S.toList imps)) instance Eq ModRef where m1 == m2 = _mrModule m1 == _mrModule m2 diff --git a/pact/Pact/Core/Names.hs b/pact/Pact/Core/Names.hs index 959b5b102..5c7566186 100644 --- a/pact/Pact/Core/Names.hs +++ b/pact/Pact/Core/Names.hs @@ -144,6 +144,10 @@ data DynamicName instance NFData DynamicName +instance Pretty DynamicName where + pretty (DynamicName dn call) = + pretty dn <> "::" <> pretty call + data ParsedTyName = TQN QualifiedName | TBN BareName @@ -311,6 +315,9 @@ makeLenses ''TypeName makeLenses ''NamedDeBruijn makeClassy ''NativeName +instance Pretty NativeName where + pretty (NativeName n) = pretty n + instance (Pretty b) => Pretty (OverloadedName b) where pretty (OverloadedName n nk) = case nk of OBound _ -> pretty n @@ -363,6 +370,9 @@ newtype RowKey makeLenses ''RowKey +instance Pretty RowKey where + pretty (RowKey rk) = pretty rk + -- | A Name reference which -- is always fully qualified after name resolution data FQNameRef name where diff --git a/pact/Pact/Core/PactValue.hs b/pact/Pact/Core/PactValue.hs index e8c5f63fe..9c3ad797d 100644 --- a/pact/Pact/Core/PactValue.hs +++ b/pact/Pact/Core/PactValue.hs @@ -26,11 +26,9 @@ module Pact.Core.PactValue ) where import Control.Lens -import Control.Monad(zipWithM) import Data.Vector(Vector) import Data.Map.Strict(Map) import Data.Text(Text) -import Data.Maybe(isJust) import Data.Decimal(Decimal) import Control.DeepSeq @@ -89,13 +87,10 @@ instance Pretty PactValue where PLiteral lit -> pretty lit PList p -> Pretty.list (V.toList (pretty <$> p)) PGuard g -> pretty g - PObject o -> - braces $ mconcat $ punctuate comma (objPair <$> M.toList o) - where - objPair (f, t) = dquotes (pretty f) <> ":" <+> pretty t + PObject o -> pretty (ObjectData o) PModRef md -> pretty md PCapToken (CapToken fqn args) -> - parens (pretty (fqnToQualName fqn)) <> if null args then mempty else hsep (pretty <$> args) + "CapToken" <> pretty (CapToken (fqnToQualName fqn) args) PTime t -> pretty (PactTime.formatTime "%Y-%m-%d %H:%M:%S%Q %Z" t) synthesizePvType :: PactValue -> Type @@ -103,53 +98,43 @@ synthesizePvType = \case PLiteral l -> typeOfLit l PList _ -> TyAnyList PGuard _ -> TyGuard - PModRef mr -> TyModRef (S.fromList (_mrImplemented mr)) + PModRef mr -> TyModRef (_mrImplemented mr) PObject _ -> TyAnyObject PCapToken {} -> TyCapToken PTime _ -> TyTime -- | Check that a `PactValue` has the provided `Type`, returning -- `Just ty` if so and `Nothing` otherwise. -checkPvType :: Type -> PactValue -> Maybe Type -checkPvType TyAny = const (Just TyAny) +checkPvType :: Type -> PactValue -> Bool +checkPvType TyAny = const True checkPvType ty = \case - PLiteral l - | typeOfLit l == ty -> Just ty - | otherwise -> Nothing - PGuard{} - | ty == TyGuard -> Just TyGuard - | otherwise -> Nothing + PLiteral l -> typeOfLit l == ty + PGuard{} -> ty == TyGuard PObject o -> case ty of -- Todo: gas - TyObject (Schema n sc) -> + TyObject (Schema _ sc) -> let tyList = M.toList sc oList = M.toList o in tcObj oList tyList where tcObj l1 l2 - | length l1 == length l2 = TyObject . Schema n . M.fromList <$> zipWithM mcheck l1 l2 - | otherwise = Nothing + | length l1 == length l2 = and $ zipWith mcheck l1 l2 + | otherwise = False mcheck (f1, pv) (f2, t) - | f1 == f2 = (f1,) <$> checkPvType t pv - | otherwise = Nothing - TyAnyObject -> Just TyAnyObject - _ -> Nothing + | f1 == f2 = checkPvType t pv + | otherwise = False + TyAnyObject -> True + _ -> False -- Todo: gas PList l -> case ty of - TyList t' | all (isJust . checkPvType t') l -> Just (TyList t') - TyAnyList -> Just TyAnyList - _ -> Nothing - PModRef (ModRef _orig ifs refinedSet) -> case ty of - TyModRef mns - | Just rf <- refinedSet, mns `S.isSubsetOf` rf -> Just (TyModRef mns) - | isJust refinedSet -> Nothing - | mns `S.isSubsetOf` (S.fromList ifs) && refinedSet == Nothing -> Just (TyModRef mns) - | otherwise -> Nothing - _ -> Nothing - PCapToken _ -> Nothing - PTime _ -> case ty of - TyTime -> Just TyTime - _ -> Nothing + TyList t' -> all (checkPvType t') l + TyAnyList -> True + _ -> False + PModRef (ModRef _orig ifs) -> case ty of + TyModRef mns -> mns `S.isSubsetOf` ifs + _ -> False + PCapToken _ -> False + PTime _ -> ty == TyTime @@ -163,3 +148,11 @@ envMap (Map Field term) (Map Field term') envMap f (ObjectData m) = fmap ObjectData (f m) + +instance Pretty term => Pretty (ObjectData term) where + pretty (ObjectData o) = + braces $ mconcat $ punctuate comma (objPair <$> M.toList o) + where + -- SEMANTIC NOTE: this specific formatting matters, since it's what we use + -- to pretty print and thus makes it into hashes + objPair (f, t) = dquotes (pretty f) <> ":" <+> pretty t diff --git a/pact/Pact/Core/Pretty.hs b/pact/Pact/Core/Pretty.hs index d3ee3d9da..6267ea712 100644 --- a/pact/Pact/Core/Pretty.hs +++ b/pact/Pact/Core/Pretty.hs @@ -15,7 +15,7 @@ module Pact.Core.Pretty , bracketsSep , parensSep , bracesSep --- , prettyList +, PrettyLispApp(..) ) where import Data.Text(Text) @@ -57,3 +57,13 @@ commaBrackets = encloseSep "[" "]" "," bracketsSep = brackets . sep parensSep = parens . sep bracesSep = braces . sep + +data PrettyLispApp n arg + = PrettyLispApp + { _plOperator :: n + , _plOperands :: [arg] + } deriving (Show) + +instance (Pretty n, Pretty arg) => Pretty (PrettyLispApp n arg) where + pretty (PrettyLispApp n args) = + parens (pretty n <> if null args then mempty else space <> hsep (pretty <$> args)) diff --git a/pact/Pact/Core/Repl/Compile.hs b/pact/Pact/Core/Repl/Compile.hs index d73be358d..7a3855677 100644 --- a/pact/Pact/Core/Repl/Compile.hs +++ b/pact/Pact/Core/Repl/Compile.hs @@ -10,13 +10,15 @@ module Pact.Core.Repl.Compile ( ReplCompileValue(..) - , interpretReplProgram + , interpretReplProgramBigStep , interpretReplProgramSmallStep , loadFile , interpretReplProgramDirect , interpretEvalBigStep , interpretEvalSmallStep , interpretEvalDirect + , interpretReplProgram + , ReplInterpreter ) where import Control.Lens @@ -85,26 +87,26 @@ loadFile loadFile loc rEnv display = do source <- SourceCode loc <$> liftIO (T.readFile loc) replCurrSource .= source - interpretReplProgram' rEnv source display + interpretReplProgram rEnv source display -interpretReplProgram +interpretReplProgramBigStep :: SourceCode -> (ReplCompileValue -> ReplM ReplCoreBuiltin ()) -> ReplM ReplCoreBuiltin [ReplCompileValue] -interpretReplProgram = interpretReplProgram' interpretEvalBigStep +interpretReplProgramBigStep = interpretReplProgram interpretEvalBigStep interpretReplProgramSmallStep :: SourceCode -> (ReplCompileValue -> ReplM ReplCoreBuiltin ()) -> ReplM ReplCoreBuiltin [ReplCompileValue] -interpretReplProgramSmallStep = interpretReplProgram' interpretEvalSmallStep +interpretReplProgramSmallStep = interpretReplProgram interpretEvalSmallStep interpretReplProgramDirect :: SourceCode -> (ReplCompileValue -> ReplM ReplCoreBuiltin ()) -> ReplM ReplCoreBuiltin [ReplCompileValue] -interpretReplProgramDirect = interpretReplProgram' interpretEvalDirect +interpretReplProgramDirect = interpretReplProgram interpretEvalDirect checkReplNativesEnabled :: TopLevel n t (ReplBuiltin b) SpanInfo -> ReplM ReplCoreBuiltin () checkReplNativesEnabled = \case @@ -147,12 +149,12 @@ interpretEvalDirect = PBool <$> Direct.interpretGuard info Direct.replBuiltinEnv g -interpretReplProgram' +interpretReplProgram :: ReplInterpreter -> SourceCode -> (ReplCompileValue -> ReplM ReplCoreBuiltin ()) -> ReplM ReplCoreBuiltin [ReplCompileValue] -interpretReplProgram' interpreter (SourceCode _ source) display = do +interpretReplProgram interpreter (SourceCode _ source) display = do lexx <- liftEither (Lisp.lexer source) debugIfFlagSet ReplDebugLexer lexx parsed <- liftEither $ Lisp.parseReplProgram lexx @@ -203,7 +205,7 @@ interpretReplProgram' interpreter (SourceCode _ source) display = do docs <- uses replUserDocs (M.lookup qn) displayValue (RUserDoc d docs) Nothing -> - failInvariant varI "repl invariant violated: resolved to a top level free variable without a binder" + throwExecutionError varI $ EvalError "repl invariant violated: resolved to a top level free variable without a binder" _ -> do v <- evalTopLevel interpreter ds deps displayValue (RCompileValue v) @@ -220,8 +222,8 @@ interpretReplProgram' interpreter (SourceCode _ source) display = do RTLDefConst dc -> case _dcTerm dc of TermConst term -> do pv <- eval interpreter PSysOnly term - pv' <- maybeTCType (_dcInfo dc) pv (_argType $ _dcSpec dc) - let dc' = set dcTerm (EvaledConst pv') dc + maybeTCType (_dcInfo dc) (_argType $ _dcSpec dc) pv + let dc' = set dcTerm (EvaledConst pv) dc let fqn = FullyQualifiedName replModuleName (_argName $ _dcSpec dc) replModuleHash loaded . loAllLoaded %= M.insert fqn (DConst dc') displayValue $ RLoadedDefConst $ _argName $ _dcSpec dc' diff --git a/pact/Pact/Core/Repl/Runtime/ReplBuiltin.hs b/pact/Pact/Core/Repl/Runtime/ReplBuiltin.hs index 9593ae3db..effda7714 100644 --- a/pact/Pact/Core/Repl/Runtime/ReplBuiltin.hs +++ b/pact/Pact/Core/Repl/Runtime/ReplBuiltin.hs @@ -80,12 +80,12 @@ coreExpect info b cont handler _env = \case v2s = prettyShowValue (VPactValue v2) returnCEKValue cont handler $ VLiteral $ LString $ "FAILURE: " <> msg <> " expected: " <> v1s <> ", received: " <> v2s else returnCEKValue cont handler (VLiteral (LString ("Expect: success " <> msg))) - _ -> returnCEK cont handler (VError "evaluation within expect did not return a pact value" info) - Right (VError errMsg _) -> do + _ -> returnCEKError info cont handler $ UserEnforceError "evaluation within expect did not return a pact value" + Right (VError _ errMsg _) -> do putEvalState es - returnCEKValue cont handler $ VString $ "FAILURE: " <> msg <> " evaluation of actual failed with error message: " <> errMsg + returnCEKValue cont handler $ VString $ "FAILURE: " <> msg <> " evaluation of actual failed with error message: " <> renderCompactText errMsg Right _v -> - returnCEK cont handler $ VError "FAILURE: expect expression did not return a pact value for comparison" info + returnCEKError info cont handler $ UserEnforceError "FAILURE: expect expression did not return a pact value for comparison" Left err -> do putEvalState es currSource <- use replCurrSource @@ -100,8 +100,8 @@ coreExpectThat info b cont handler _env = \case EvalValue (VLiteral (LBool c)) -> if c then returnCEKValue cont handler (VLiteral (LString ("Expect-that: success " <> msg))) else returnCEKValue cont handler (VLiteral (LString ("FAILURE: Expect-that: Did not satisfy condition: " <> msg))) - EvalValue _ -> returnCEK cont handler (VError "Expect-that: condition did not return a boolean" info) - VError ve i -> returnCEK cont handler (VError ve i) + EvalValue _ -> throwNativeExecutionError info b "Expect-that: condition did not return a boolean" + ve@VError{} -> returnCEK cont handler ve args -> argsError info b args coreExpectFailure :: ReplCEKEval step => NativeFunction step ReplCoreBuiltin SpanInfo (ReplM ReplCoreBuiltin) @@ -109,7 +109,7 @@ coreExpectFailure info b cont handler _env = \case [VString doc, VClosure vclo] -> do es <- getEvalState tryError (applyLamUnsafe vclo [] Mt CEKNoHandler) >>= \case - Right (VError _ _) -> do + Right (VError _ _ _) -> do putEvalState es returnCEKValue cont handler $ VLiteral $ LString $ "Expect failure: Success: " <> doc Left _err -> do @@ -120,8 +120,9 @@ coreExpectFailure info b cont handler _env = \case [VString desc, VString toMatch, VClosure vclo] -> do es <- getEvalState tryError (applyLamUnsafe vclo [] Mt CEKNoHandler) >>= \case - Right (VError err _) -> do + Right (VError _ errMsg _) -> do putEvalState es + let err = renderCompactText errMsg if toMatch `T.isInfixOf` err then returnCEKValue cont handler $ VLiteral $ LString $ "Expect failure: Success: " <> desc else returnCEKValue cont handler $ VLiteral $ LString $ @@ -185,7 +186,7 @@ pactState info b cont handler _env = \case ,(Field "yield", yield') ,(Field "step", PInteger (fromIntegral (_peStep pe)))] returnCEKValue cont handler (VObject (M.fromList ps)) - Nothing -> returnCEK cont handler (VError "pact-state: no pact exec in context" info) + Nothing -> returnCEKError info cont handler $ UserEnforceError "pact-state: no pact exec in context" coreplEvalEnvStackFrame :: ReplCEKEval step => NativeFunction step ReplCoreBuiltin SpanInfo (ReplM ReplCoreBuiltin) coreplEvalEnvStackFrame info b cont handler _env = \case @@ -214,7 +215,7 @@ envHash :: ReplCEKEval step => NativeFunction step ReplCoreBuiltin SpanInfo (Rep envHash info b cont handler _env = \case [VString s] -> do case decodeBase64UrlUnpadded (T.encodeUtf8 s) of - Left e -> returnCEK cont handler (VError (T.pack e) info) + Left e -> returnCEKError info cont handler $ UserEnforceError (T.pack e) Right hs -> do (replEvalEnv . eeHash) .= Hash (toShort hs) returnCEKValue cont handler $ VString $ "Set tx hash to " <> s @@ -257,7 +258,7 @@ envChainData info b cont handler _env = \case go (set pdPrevBlockHash s pd) rest PTime time | k == cdBlockTime -> go (set pdBlockTime (PactTime.toPosixTimestampMicros time) pd) rest - _ -> returnCEK cont handler (VError ("envChainData: bad public metadata value for key: " <> _field k) info) + _ -> returnCEKError info cont handler $ UserEnforceError $ "envChainData: bad public metadata value for key: " <> _field k args -> argsError info b args envKeys :: ReplCEKEval step => NativeFunction step ReplCoreBuiltin SpanInfo (ReplM ReplCoreBuiltin) @@ -275,7 +276,7 @@ envSigs info b cont handler _env = \case Just sigs -> do (replEvalEnv . eeMsgSigs) .= M.fromList (V.toList sigs) returnCEKValue cont handler $ VString "Setting transaction signatures/caps" - Nothing -> returnCEK cont handler (VError ("env-sigs: Expected object with 'key': string, 'caps': [capability]") info) + Nothing -> returnCEKError info cont handler $ UserEnforceError ("env-sigs: Expected object with 'key': string, 'caps': [capability]") where keyCapObj = \case PObject o -> do @@ -296,7 +297,8 @@ envVerifiers info b cont handler _env = \case Just sigs -> do (replEvalEnv . eeMsgVerifiers) .= M.fromList (V.toList sigs) returnCEKValue cont handler $ VString "Setting transaction verifiers/caps" - Nothing -> returnCEK cont handler (VError ("env-verifiers: Expected object with 'name': string, 'caps': [capability]") info) + Nothing -> + throwNativeExecutionError info b ("Expected object with 'name': string, 'caps': [capability]") where verifCapObj = \case PObject o -> do @@ -319,7 +321,7 @@ beginTx info b cont handler _env = \case renderTx :: i -> Text -> Maybe (TxId, Maybe Text) -> EvalResult step b i m renderTx _info start (Just (TxId tid, mt)) = EvalValue $ VString $ start <> " " <> T.pack (show tid) <> maybe mempty (" " <>) mt -renderTx info start Nothing = VError ("tx-function failure " <> start) info +renderTx info start Nothing = VError [] (UserEnforceError ("tx-function failure " <> start)) info begin' :: SpanInfo -> Maybe Text -> ReplM b (Maybe (TxId, Maybe Text)) begin' info mt = do @@ -379,18 +381,16 @@ sigKeyset info b cont handler _env = \case testCapability :: ReplCEKEval step => NativeFunction step ReplCoreBuiltin SpanInfo (ReplM ReplCoreBuiltin) testCapability info b cont handler env = \case [VCapToken origToken] -> do - lookupFqName (_ctName origToken) >>= \case - Just (DCap d) -> do - let cBody = Constant LUnit info - cont' = SeqC env cBody cont - case _dcapMeta d of - Unmanaged -> - evalCap info cont' handler env origToken PopCapInvoke TestCapEval cBody - _ -> do - -- Installed caps emit and event - -- so we create a fake stack frame - installCap info env origToken False *> evalCap info cont' handler env origToken PopCapInvoke TestCapEval cBody - _ -> returnCEK cont handler (VError "no such capability" info) + d <- getDefCap info (_ctName origToken) + let cBody = Constant LUnit info + cont' = SeqC env cBody cont + case _dcapMeta d of + Unmanaged -> + evalCap info cont' handler env origToken PopCapInvoke TestCapEval cBody + _ -> do + -- Installed caps emit and event + -- so we create a fake stack frame + installCap info env origToken False *> evalCap info cont' handler env origToken PopCapInvoke TestCapEval cBody args -> argsError info b args envExecConfig :: ReplCEKEval step => NativeFunction step ReplCoreBuiltin SpanInfo (ReplM ReplCoreBuiltin) @@ -415,13 +415,13 @@ envNamespacePolicy info b cont handler _env = \case [VBool allowRoot, VClosure (C clo)] -> do pdb <- viewEvalEnv eePactDb let qn = fqnToQualName (_cloFqName clo) - when (_cloArity clo /= 2) $ failInvariant info "Namespace manager function has invalid argument length" + when (_cloArity clo /= 2) $ throwNativeExecutionError info b "Namespace manager function has invalid argument length" getModuleMember info pdb qn >>= \case Dfun _ -> do let nsp = SmartNamespacePolicy allowRoot qn replEvalEnv . eeNamespacePolicy .= nsp returnCEKValue cont handler (VString "Installed namespace policy") - _ -> returnCEK cont handler (VError "invalid namespace manager function type" info) + _ -> returnCEKError info cont handler $ UserEnforceError "invalid namespace manager function type" args -> argsError info b args envGas :: ReplCEKEval step => NativeFunction step ReplCoreBuiltin SpanInfo (ReplM ReplCoreBuiltin) diff --git a/pact/Pact/Core/Serialise/CBOR_V1.hs b/pact/Pact/Core/Serialise/CBOR_V1.hs index 3f2151365..2664de788 100644 --- a/pact/Pact/Core/Serialise/CBOR_V1.hs +++ b/pact/Pact/Core/Serialise/CBOR_V1.hs @@ -183,10 +183,9 @@ gasSerializeRowData (RowData fields) = do traverse_ (chargeGasMString . renderText) keys gasModRef :: ModRef -> GasM (PactError i) b () - gasModRef (ModRef name implemented refined) = do + gasModRef (ModRef name implemented) = do chargeGasMString (renderText name) traverse_ (chargeGasMString . renderText) implemented - (traverse_ . traverse_) (chargeGasMString . renderText) refined chargeGasMString :: Text.Text -> GasM (PactError i) b () chargeGasMString str = do @@ -945,7 +944,7 @@ instance Serialise CoreBuiltin where _ -> fail "unexpected decoding" -instance Serialise ReplBuiltins where +instance Serialise ReplOnlyBuiltin where encode = encodeWord . fromIntegral . fromEnum decode = do vInd <- toEnum . fromIntegral <$> decodeWord @@ -1004,8 +1003,8 @@ instance Serialise DefPactGuard where decode = DefPactGuard <$> decode <*> decode instance Serialise ModRef where - encode (ModRef mn imp ref) = encode mn <> encode imp <> encode ref - decode = ModRef <$> decode <*> decode <*> decode + encode (ModRef mn imp) = encode mn <> encode imp + decode = ModRef <$> decode <*> decode instance Serialise (CapToken FullyQualifiedName PactValue) where encode (CapToken n a) = encode n <> encode a diff --git a/pact/Pact/Core/Serialise/LegacyPact.hs b/pact/Pact/Core/Serialise/LegacyPact.hs index 6ace96965..20fea3da6 100644 --- a/pact/Pact/Core/Serialise/LegacyPact.hs +++ b/pact/Pact/Core/Serialise/LegacyPact.hs @@ -430,8 +430,8 @@ fromLegacyPactValue = \case pure (PGuard $ GCapabilityGuard (CapabilityGuard qn args (fromLegacyPactId <$> i))) Legacy.PModRef (Legacy.ModRef mn mmn) -> let mn' = fromLegacyModuleName mn - imp = fmap fromLegacyModuleName (fromMaybe [] mmn) - in pure (PModRef $ ModRef mn' imp Nothing) + imp = S.fromList $ fmap fromLegacyModuleName (fromMaybe [] mmn) + in pure (PModRef $ ModRef mn' imp) fromLegacyPersistDirect @@ -708,8 +708,8 @@ fromLegacyTerm mh = \case Legacy.TModRef (Legacy.ModRef mn mmn) -> let mn' = fromLegacyModuleName mn - imp = fmap fromLegacyModuleName (fromMaybe [] mmn) - in pure (InlineValue (PModRef (ModRef mn' imp Nothing)) ()) + imp = S.fromList $ fmap fromLegacyModuleName (fromMaybe [] mmn) + in pure (InlineValue (PModRef (ModRef mn' imp)) ()) _ -> throwError "fromLegacyTerm: invariant" diff --git a/pact/Pact/Core/SizeOf.hs b/pact/Pact/Core/SizeOf.hs index de7e3df34..5c1214740 100644 --- a/pact/Pact/Core/SizeOf.hs +++ b/pact/Pact/Core/SizeOf.hs @@ -27,7 +27,7 @@ module Pact.Core.SizeOf , wordSize , SizeOfVersion(..) - -- * SizeOf + -- * SizeOf , countBytes ) where @@ -386,7 +386,7 @@ instance SizeOf SpanInfo -- builtins instance SizeOf CoreBuiltin -instance SizeOf ReplBuiltins +instance SizeOf ReplOnlyBuiltin instance SizeOf b => SizeOf (ReplBuiltin b) diff --git a/pact/Pact/Core/StableEncoding.hs b/pact/Pact/Core/StableEncoding.hs index 8295aed0c..b9828b2c8 100644 --- a/pact/Pact/Core/StableEncoding.hs +++ b/pact/Pact/Core/StableEncoding.hs @@ -17,7 +17,7 @@ import Data.Ratio ((%), denominator) import Data.ByteString (ByteString) import qualified Data.Text as T import qualified Pact.JSON.Encode as J -import qualified Data.Set as Set +import qualified Data.Set as S import Pact.Core.PactValue import Pact.Core.Literal @@ -131,7 +131,7 @@ instance J.Encode (StableEncoding KeySetName) where instance J.Encode (StableEncoding KeySet) where build (StableEncoding (KeySet keys predFun)) =J.object [ "pred" J..= StableEncoding predFun - , "keys" J..= J.Array (Set.map StableEncoding keys) -- TODO: is this valid? + , "keys" J..= J.Array (S.map StableEncoding keys) -- TODO: is this valid? ] {-# INLINABLE build #-} @@ -169,8 +169,8 @@ instance J.Encode (StableEncoding ModuleName) where -- | Stable encoding of `ModRef` instance J.Encode (StableEncoding ModRef) where - build (StableEncoding (ModRef mn imp _ref)) = J.object - [ "refSpec" J..= Just (J.Array (StableEncoding <$> imp)) + build (StableEncoding (ModRef mn imp)) = J.object + [ "refSpec" J..= Just (J.Array (StableEncoding <$> S.toList imp)) , "refName" J..= StableEncoding mn ] {-# INLINABLE build #-} diff --git a/pact/Pact/Core/StackFrame.hs b/pact/Pact/Core/StackFrame.hs index 82565a2a7..1461c1c45 100644 --- a/pact/Pact/Core/StackFrame.hs +++ b/pact/Pact/Core/StackFrame.hs @@ -47,4 +47,4 @@ instance NFData i => NFData (StackFrame i) instance Pretty (StackFrame i) where pretty (StackFrame sfn args _ _) = - parens (pretty sfn <> if null args then mempty else space <> hsep (pretty <$> args)) + pretty $ PrettyLispApp sfn args diff --git a/pact/Pact/Core/Type.hs b/pact/Pact/Core/Type.hs index 65d7408ba..2f21ed54c 100644 --- a/pact/Pact/Core/Type.hs +++ b/pact/Pact/Core/Type.hs @@ -227,6 +227,16 @@ data DefKind instance NFData DefKind +instance Pretty DefKind where + pretty = \case + DKDefun -> "defun" + DKDefConst -> "defconst" + DKDefCap -> "defcap" + DKDefPact -> "defpact" + DKDefSchema _ -> "defscema" + DKDefTable -> "deftable" + + -- instance Pretty n => Pretty (Pred n) where -- pretty (Pred tc ty) = pretty tc <> Pretty.angles (pretty ty)