diff --git a/examples/accounts/accounts.pact b/examples/accounts/accounts.pact index 351ee18d7..20d73d5a0 100644 --- a/examples/accounts/accounts.pact +++ b/examples/accounts/accounts.pact @@ -107,7 +107,7 @@ (defpact payment (payer payer-entity payee payee-entity amount date) "Debit PAYER at PAYER-ENTITY then credit PAYEE at PAYEE-ENTITY for AMOUNT on DATE" - (step-with-rollback payer-entity + (step-with-rollback (with-capability (TRANSFER) (debit payer amount date { "payee": payee @@ -118,7 +118,7 @@ (credit payer amount date { "ref": (pact-id), "note": "rollback" }))) - (step payee-entity + (step (with-capability (TRANSFER) (credit payee amount date { "payer": payer diff --git a/pact-repl/Pact/Core/IR/Eval/Direct/Evaluator.hs b/pact-repl/Pact/Core/IR/Eval/Direct/Evaluator.hs index d0b618fec..a7f4f8101 100644 --- a/pact-repl/Pact/Core/IR/Eval/Direct/Evaluator.hs +++ b/pact-repl/Pact/Core/IR/Eval/Direct/Evaluator.hs @@ -1130,12 +1130,18 @@ applyPact i pc ps cenv nested = use esDefPactExec >>= \case let sf = StackFrame (qualNameToFqn (pc ^. pcName) mh) (pc ^. pcArgs) SFDefPact i result <- case (ps ^. psRollback, step) of - (False, _) -> - evalWithStackFrame i sf Nothing $ evaluate cenv (ordinaryDefPactStepExec step) + (False, _) -> case ordinaryDefPactStepExec step of + Just stepExpr -> + evalWithStackFrame i sf Nothing $ evaluate cenv stepExpr + Nothing -> + throwExecutionError i (EntityNotAllowedInDefPact (_pcName pc)) (True, StepWithRollback _ rollbackExpr) -> evalWithStackFrame i sf Nothing $ evaluate cenv rollbackExpr (True, Step{}) -> throwExecutionError i (DefPactStepHasNoRollback ps) + (True, LegacyStepWithEntity{}) -> throwExecutionError i (DefPactStepHasNoRollback ps) + (True, LegacyStepWithRBEntity{}) -> + throwExecutionError i (EntityNotAllowedInDefPact (_pcName pc)) -- After evaluation, check the result state use esDefPactExec >>= \case @@ -1210,11 +1216,17 @@ applyNestedPact i pc ps cenv = use esDefPactExec >>= \case let contFqn = qualNameToFqn (pc ^. pcName) mh sf = StackFrame contFqn (pc ^. pcArgs) SFDefPact i result <- case (ps ^. psRollback, step) of - (False, _) -> - evalWithStackFrame i sf Nothing $ evaluate cenv' (ordinaryDefPactStepExec step) + (False, _) -> case ordinaryDefPactStepExec step of + Just stepExpr -> + evalWithStackFrame i sf Nothing $ evaluate cenv' stepExpr + Nothing -> + throwExecutionError i (EntityNotAllowedInDefPact (_pcName pc)) (True, StepWithRollback _ rollbackExpr) -> evalWithStackFrame i sf Nothing $ evaluate cenv' rollbackExpr (True, Step{}) -> throwExecutionError i (DefPactStepHasNoRollback ps) + (True, LegacyStepWithEntity{}) -> throwExecutionError i (DefPactStepHasNoRollback ps) + (True, LegacyStepWithRBEntity{}) -> + throwExecutionError i (EntityNotAllowedInDefPact (_pcName pc)) use esDefPactExec >>= \case Nothing -> failInvariant i $ InvariantPactExecNotInEnv Nothing diff --git a/pact-tests/Pact/Core/Test/LexerParserTests.hs b/pact-tests/Pact/Core/Test/LexerParserTests.hs index e25061275..63af022e0 100644 --- a/pact-tests/Pact/Core/Test/LexerParserTests.hs +++ b/pact-tests/Pact/Core/Test/LexerParserTests.hs @@ -246,10 +246,10 @@ defpactGen = Gen.choice [regularStepGen, stepWithRbGen] regularStepGen = -- Todo: models - Step <$> exprGen <*> pure Nothing + Step <$> pure Nothing <*> exprGen <*> pure Nothing stepWithRbGen = -- todo: models - StepWithRollback <$> exprGen <*> exprGen <*> pure Nothing + StepWithRollback <$> pure Nothing <*> exprGen <*> exprGen <*> pure Nothing defschemaGen :: Gen (DefSchema ()) defschemaGen = diff --git a/pact-tests/Pact/Core/Test/StaticErrorTests.hs b/pact-tests/Pact/Core/Test/StaticErrorTests.hs index 2c1e876ff..9d8b9db35 100644 --- a/pact-tests/Pact/Core/Test/StaticErrorTests.hs +++ b/pact-tests/Pact/Core/Test/StaticErrorTests.hs @@ -1098,6 +1098,20 @@ executionTests = ) (install-capability (c "meh")) |]) + , ("entity_not_allowed", isExecutionError _EntityNotAllowedInDefPact, [text| + (module m g (defcap g () true) + (defpact tester () + (step 1 2) + ) + ) + |]) + , ("entity_not_allowed_rb", isExecutionError _EntityNotAllowedInDefPact, [text| + (module m g (defcap g () true) + (defpact tester () + (step-with-rollback 1 2 3) + ) + ) + |]) ] builtinTests :: [(String, PactErrorI -> Bool, Text)] diff --git a/pact-tests/constructor-tag-goldens/EvalError.golden b/pact-tests/constructor-tag-goldens/EvalError.golden index 848adddba..487588d30 100644 --- a/pact-tests/constructor-tag-goldens/EvalError.golden +++ b/pact-tests/constructor-tag-goldens/EvalError.golden @@ -74,4 +74,5 @@ {"conName":"ModuleAdminNotAcquired","conIndex":"49"} {"conName":"UnknownException","conIndex":"4a"} {"conName":"InvalidNumArgs","conIndex":"4b"} +{"conName":"EntityNotAllowedInDefPact","conIndex":"4c"} diff --git a/pact/Pact/Core/Errors.hs b/pact/Pact/Core/Errors.hs index bb38c8f72..25842393e 100644 --- a/pact/Pact/Core/Errors.hs +++ b/pact/Pact/Core/Errors.hs @@ -185,6 +185,7 @@ module Pact.Core.Errors , _HyperlaneDecodeErrorInternal , _HyperlaneDecodeErrorBinary , _HyperlaneDecodeErrorParseRecipient + , _EntityNotAllowedInDefPact , _InvalidNumArgs , toPrettyLegacyError , BoundedText @@ -727,6 +728,9 @@ data EvalError | UnknownException Text -- ^ An unknown exception was thrown and converted to text. Intentionally and crucially lazy. | InvalidNumArgs ErrorClosureType Int Int + -- ^ Invalid number of arguments for a function + | EntityNotAllowedInDefPact QualifiedName + -- ^ Entity field not allowed in defpact deriving (Eq, Show, Generic) data ErrorClosureType @@ -941,6 +945,8 @@ instance Pretty EvalError where <+> pretty errCloType <+> "supplied; expected" <+> parens (pretty expected) + EntityNotAllowedInDefPact qn -> + "Pact 5 does not support entity expressions in defpact" <+> pretty qn <> ". Please ensure your defpact steps have the correct number of expressions" -- | Errors meant to be raised -- internally by a PactDb implementation @@ -1597,6 +1603,10 @@ evalErrorToBoundedText = mkBoundedText . \case ErrClosureLambda -> "lambda" ErrClosureUserFun fqn -> thsep ["user function", tFqn fqn] ErrClosureNativeFun b -> thsep ["native function", _natName b] + EntityNotAllowedInDefPact qn -> + thsep [ "Pact 5 does not support entity expressions in defpact" + , renderQualName qn <> "." + , " Please ensure your defpact steps have the correct number of expressions"] -- | NOTE: Do _not_ change this function post mainnet release just to improve an error. diff --git a/pact/Pact/Core/IR/Desugar.hs b/pact/Pact/Core/IR/Desugar.hs index 85ba67137..30df332d3 100644 --- a/pact/Pact/Core/IR/Desugar.hs +++ b/pact/Pact/Core/IR/Desugar.hs @@ -485,12 +485,16 @@ desugarDefPact mn (Lisp.DefPact spec@(Lisp.MArg dpname _ _) margs (step :| steps let args' = toArg <$> margs spec' = toArg spec steps' <- forM (step :| steps) \case - Lisp.Step s _ -> + Lisp.Step mentity s _ -> do + when (isJust mentity) $ + lift $ throwExecutionError i (EntityNotAllowedInDefPact (QualifiedName dpname mn)) Step <$> desugarLispTerm s - Lisp.StepWithRollback s rb _ -> + Lisp.StepWithRollback mentity s rb _ -> do + when (isJust mentity) $ + lift $ throwExecutionError i (EntityNotAllowedInDefPact (QualifiedName dpname mn)) StepWithRollback - <$> desugarLispTerm s - <*> desugarLispTerm rb + <$> desugarLispTerm s + <*> desugarLispTerm rb -- In DefPacts, last step is not allowed to rollback. when (hasRollback $ NE.last steps') $ @@ -807,6 +811,7 @@ defPactStepSCC mn cd = \case Step step -> termSCC mn cd step StepWithRollback step rollback -> S.unions $ [termSCC mn cd step, termSCC mn cd rollback] + _ -> mempty -- | Get the set of dependencies from a defun signature defn -- Note: names will show up in: @@ -1119,6 +1124,10 @@ renamePactStep = \case Step <$> renameTerm step StepWithRollback step rollback -> StepWithRollback <$> renameTerm step <*> renameTerm rollback + LegacyStepWithEntity e1 e2 -> + LegacyStepWithEntity <$> renameTerm e1 <*> renameTerm e2 + LegacyStepWithRBEntity e1 e2 e3 -> + LegacyStepWithRBEntity <$> renameTerm e1 <*> renameTerm e2 <*> renameTerm e3 renameDefPact :: (DesugarBuiltin b) diff --git a/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs b/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs index a95c3c7b4..ea8d6a27e 100644 --- a/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs +++ b/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs @@ -388,11 +388,17 @@ applyPact i pc ps cont handler cenv nested = use esDefPactExec >>= \case contFqn = qualNameToFqn (pc ^. pcName) mh sf = StackFrame contFqn (pc ^. pcArgs) SFDefPact i case (ps ^. psRollback, step) of - (False, _) -> - evalWithStackFrame i cont' handler cenv Nothing sf (ordinaryDefPactStepExec step) + (False, _) -> case ordinaryDefPactStepExec step of + Just stepExpr -> + evalWithStackFrame i cont' handler cenv Nothing sf stepExpr + Nothing -> + throwExecutionError i (EntityNotAllowedInDefPact (_pcName pc)) (True, StepWithRollback _ rollbackExpr) -> evalWithStackFrame i cont' handler cenv Nothing sf rollbackExpr (True, Step{}) -> throwExecutionError i (DefPactStepHasNoRollback ps) + (True, LegacyStepWithEntity{}) -> throwExecutionError i (DefPactStepHasNoRollback ps) + (True, LegacyStepWithRBEntity{}) -> + throwExecutionError i (EntityNotAllowedInDefPact (_pcName pc)) (_, mh) -> failInvariant i (InvariantExpectedDefPact (qualNameToFqn (pc ^. pcName) mh)) emitXChainEvents @@ -474,11 +480,17 @@ applyNestedPact i pc ps cont handler cenv = use esDefPactExec >>= \case sf = StackFrame contFqn (pc ^. pcArgs) SFDefPact i case (ps ^. psRollback, step) of - (False, _) -> - evalWithStackFrame i cont' handler cenv' Nothing sf (ordinaryDefPactStepExec step) + (False, _) -> case ordinaryDefPactStepExec step of + Just stepExpr -> + evalWithStackFrame i cont' handler cenv' Nothing sf stepExpr + Nothing -> + throwExecutionError i (EntityNotAllowedInDefPact (_pcName pc)) (True, StepWithRollback _ rollbackExpr) -> evalWithStackFrame i cont' handler cenv' Nothing sf rollbackExpr (True, Step{}) -> throwExecutionError i (DefPactStepHasNoRollback ps) + (True, LegacyStepWithEntity{}) -> throwExecutionError i (DefPactStepHasNoRollback ps) + (True, LegacyStepWithRBEntity{}) -> + throwExecutionError i (EntityNotAllowedInDefPact (_pcName pc)) (_, mh) -> failInvariant i (InvariantExpectedDefPact (qualNameToFqn (pc ^. pcName) mh)) diff --git a/pact/Pact/Core/IR/Term.hs b/pact/Pact/Core/IR/Term.hs index 05f5e9f7c..b1edba1bf 100644 --- a/pact/Pact/Core/IR/Term.hs +++ b/pact/Pact/Core/IR/Term.hs @@ -222,6 +222,8 @@ data Step name ty builtin info | StepWithRollback (Term name ty builtin info) (Term name ty builtin info) + | LegacyStepWithEntity (Term name ty builtin info) (Term name ty builtin info) + | LegacyStepWithRBEntity (Term name ty builtin info) (Term name ty builtin info) (Term name ty builtin info) deriving (Show, Functor, Eq, Generic) -- | (defpact : (arglist*) ) @@ -265,10 +267,13 @@ data DefSchema ty info hasRollback :: Step n t b i -> Bool hasRollback Step{} = False hasRollback StepWithRollback{} = True +hasRollback LegacyStepWithEntity{} = False +hasRollback LegacyStepWithRBEntity{} = True -ordinaryDefPactStepExec :: Step name ty builtin info -> Term name ty builtin info -ordinaryDefPactStepExec (Step expr) = expr -ordinaryDefPactStepExec (StepWithRollback expr _) = expr +ordinaryDefPactStepExec :: Step name ty builtin info -> Maybe (Term name ty builtin info) +ordinaryDefPactStepExec (Step expr) = Just expr +ordinaryDefPactStepExec (StepWithRollback expr _) = Just expr +ordinaryDefPactStepExec _ = Nothing -- | The type of our desugared table schemas -- TODO: This GADT is unnecessarily complicated and only really necessary @@ -567,6 +572,9 @@ instance (Pretty name, Pretty builtin, Pretty ty) => Pretty (Step name ty builti pretty = \case Step t -> parens ("step" <+> pretty t) StepWithRollback t1 t2 -> parens ("step-with-rollback" <+> pretty t1 <+> pretty t2) + LegacyStepWithEntity t1 t2 -> parens ("step" <+> pretty t1 <+> pretty t2) + LegacyStepWithRBEntity t1 t2 t3 -> + parens ("step-with-rollback" <+> pretty t1 <+> pretty t2 <+> pretty t3) instance (Pretty name, Pretty ty, Pretty b) => Pretty (DefConst name ty b i) where @@ -759,6 +767,10 @@ traverseDefPactStep f = \case Step t -> Step <$> f t StepWithRollback a1 a2 -> StepWithRollback <$> f a1 <*> f a2 + LegacyStepWithEntity e1 e2 -> + LegacyStepWithEntity <$> f e1 <*> f e2 + LegacyStepWithRBEntity e1 e2 e3 -> + LegacyStepWithRBEntity <$> f e1 <*> f e2 <*> f e3 traverseDefPactTerm :: Traversal (DefPact name ty builtin info) diff --git a/pact/Pact/Core/Serialise/CBOR_V1.hs b/pact/Pact/Core/Serialise/CBOR_V1.hs index ea699d4da..778180699 100644 --- a/pact/Pact/Core/Serialise/CBOR_V1.hs +++ b/pact/Pact/Core/Serialise/CBOR_V1.hs @@ -560,6 +560,10 @@ instance encodeListLen 2 <> encodeWord 0 <> encodeS t StepWithRollback t rb -> encodeListLen 3 <> encodeWord 1 <> encodeS t <> encodeS rb + LegacyStepWithEntity t e -> + encodeListLen 3 <> encodeWord 2 <> encodeS t <> encodeS e + LegacyStepWithRBEntity t e rb -> + encodeListLen 4 <> encodeWord 3 <> encodeS t <> encodeS e <> encodeS rb {-# INLINE encode #-} decode = do @@ -567,6 +571,8 @@ instance decodeWord >>= fmap SerialiseV1 . \case 0 -> Step <$> decodeS 1 -> StepWithRollback <$> decodeS <*> decodeS + 2 -> LegacyStepWithEntity <$> decodeS <*> decodeS + 3 -> LegacyStepWithRBEntity <$> decodeS <*> decodeS <*> decodeS _ -> fail "unexpected decoding" {-# INLINE decode #-} diff --git a/pact/Pact/Core/Serialise/LegacyPact.hs b/pact/Pact/Core/Serialise/LegacyPact.hs index 7ad558f5b..fc8a054bb 100644 --- a/pact/Pact/Core/Serialise/LegacyPact.hs +++ b/pact/Pact/Core/Serialise/LegacyPact.hs @@ -436,12 +436,15 @@ fromLegacyStep :: ModuleHash -> Legacy.Step (Legacy.Term (Either CorePreNormalizedTerm LegacyRef)) -> TranslateM (Step (Name, DeBruijn) Type CoreBuiltin ()) -fromLegacyStep mh (Legacy.Step _ t mrb) = do +fromLegacyStep mh (Legacy.Step entity t mrb) = do + entity' <- traverse (fromLegacyTerm mh) entity t' <- fromLegacyTerm mh t - case mrb of - Nothing -> pure (Step t') - Just rb -> - StepWithRollback t' <$> fromLegacyTerm mh rb + mrb' <- traverse (fromLegacyTerm mh) mrb + case (entity', mrb') of + (Nothing, Nothing) -> pure (Step t') + (Nothing, Just rb) -> pure (StepWithRollback t' rb) + (Just e, Nothing) -> pure (LegacyStepWithEntity e t') + (Just e, Just rb) -> pure (LegacyStepWithRBEntity e t' rb) debruijnize :: DeBruijn diff --git a/pact/Pact/Core/Syntax/ParseTree.hs b/pact/Pact/Core/Syntax/ParseTree.hs index 8417325b2..c9a300e41 100644 --- a/pact/Pact/Core/Syntax/ParseTree.hs +++ b/pact/Pact/Core/Syntax/ParseTree.hs @@ -285,17 +285,17 @@ instance Pretty (DefTable i) where <> maybe mempty (\d -> line <> pretty (uncurry (flip PactDoc) d)) docs data PactStep i - = Step (Expr i) (Maybe [PropertyExpr i]) - | StepWithRollback (Expr i) (Expr i) (Maybe [PropertyExpr i]) + = Step (Maybe (Expr i)) (Expr i) (Maybe [PropertyExpr i]) + | StepWithRollback (Maybe (Expr i)) (Expr i) (Expr i) (Maybe [PropertyExpr i]) deriving (Eq, Show, Functor, Generic, NFData) instance Pretty (PactStep i) where pretty = \case - Step e1 anns -> + Step _ e1 anns -> parens $ "step" <+> pretty e1 <> nest 2 (maybe mempty (\a -> line <> pretty (PactModel a)) anns) - StepWithRollback e1 e2 anns -> + StepWithRollback _ e1 e2 anns -> parens $ "step-with-rollback" <+> pretty e1 <+> pretty e2 <> nest 2 (maybe mempty (\a -> line <> pretty (PactModel a)) anns) diff --git a/pact/Pact/Core/Syntax/Parser.y b/pact/Pact/Core/Syntax/Parser.y index 368eeb884..5b6701b44 100644 --- a/pact/Pact/Core/Syntax/Parser.y +++ b/pact/Pact/Core/Syntax/Parser.y @@ -224,15 +224,15 @@ Steps :: { [PactStep SpanInfo] } | Step { [$1] } Step :: { PactStep SpanInfo } - : '(' step Expr MModel ')' { Step $3 $4 } + : '(' step Expr MModel ')' { Step Nothing $3 $4 } -- Note: this production which ignores its input -- is due to the legacy form of: -- (step ENTITY EXPR) - | '(' step Expr Expr MModel ')' { Step $4 $5 } - | '(' steprb Expr Expr MModel ')' { StepWithRollback $3 $4 $5 } + | '(' step Expr Expr MModel ')' { Step (Just $3) $4 $5 } + | '(' steprb Expr Expr MModel ')' { StepWithRollback Nothing $3 $4 $5 } -- (step-with-rollback ENTITY EXPR ROLLBACK-EXPR) -- hence we ignore entity - | '(' steprb Expr Expr Expr MModel ')' { StepWithRollback $4 $5 $6 } + | '(' steprb Expr Expr Expr MModel ')' { StepWithRollback (Just $3) $4 $5 $6 } MDCapMeta :: { Maybe DCapMeta } : Managed { Just $1 }