From 6e0515279f88f741452be00c060b179178a510fc Mon Sep 17 00:00:00 2001 From: Stuart Popejoy Date: Sat, 29 Apr 2023 18:32:58 -0400 Subject: [PATCH 1/5] Fix TC allowing bad schemas in bind, with-read, with-capability --- examples/cp/orders.pact | 18 ++++-------------- src/Pact/Typechecker.hs | 3 ++- tests/pact/tc.repl | 23 +++++++++++++++++++++++ 3 files changed, 29 insertions(+), 15 deletions(-) diff --git a/examples/cp/orders.pact b/examples/cp/orders.pact index 00bac1540..67dbf0786 100644 --- a/examples/cp/orders.pact +++ b/examples/cp/orders.pact @@ -50,20 +50,10 @@ (defun with-order-status:object{order} (order-id status) "Check that order status is correct, returning details" - (with-read orders order-id { - "cusip" := cusip, - "status" := ostatus, - "qty" := qty, - "price" := price, - "seller" := seller, - "buyer" := buyer - } - (enforce (= ostatus status) (format "order must be {}" [status])) - {"cusip": cusip, - "qty": qty, - "price": price, - "buyer": buyer, - "seller": seller }) + (let ((o (read orders order-id))) + (enforce (= (at 'status o) status) + (format "order must be {}" [status])) + o) ) (defun with-order:object{order} (order-id) diff --git a/src/Pact/Typechecker.hs b/src/Pact/Typechecker.hs index 842ca9aa1..a982244d2 100644 --- a/src/Pact/Typechecker.hs +++ b/src/Pact/Typechecker.hs @@ -584,8 +584,9 @@ assocAstTy (Node ai _) ty = do -- The fact that one of these implies storage and the other -- is "just a type" is problematic, creating much cruft in here. assocTy :: TcId -> TypeVar UserType -> Type UserType -> TC () -assocTy ai av ty = do +assocTy ai av ty' = do aty <- resolveTy =<< lookupTypes "assocTy" ai av + ty <- resolveTy ty' debug $ "assocTy: " ++ showPretty (av,aty) ++ " <=> " ++ showPretty ty unifyTypes' ai aty ty $ \r -> case r of Left _same -> do diff --git a/tests/pact/tc.repl b/tests/pact/tc.repl index 3c3381241..a903bea8b 100644 --- a/tests/pact/tc.repl +++ b/tests/pact/tc.repl @@ -205,6 +205,29 @@ (update persons "foo" partial) partial)) + (defun fails-bind-bad-object:object{person} () + (let ((o:object{person} + { 'name: 's + , 'age: 1 + , 'dob: (parse-time "%F" "1996-12-31") + } )) + (bind o { 'name:= name, 'age:= age } + { 'foo: name + , 'bar: age }))) + + (defun fails-with-read-partial-schema:object{person} () + (with-read persons 'dave + { 'name:= name + , 'age:= age } + { 'name: name + , 'age: age })) + + (defcap CAP () true) + + (defun fails-with-capability-bad-object:object{person} () + (with-capability (CAP) + { 'foo: 1 })) + (defschema schema-a a:integer) (defschema schema-b b:integer) From 1592121408097ac0ae9616f3bf7127d0ce48d098 Mon Sep 17 00:00:00 2001 From: Stuart Popejoy Date: Mon, 1 May 2023 15:03:43 -0400 Subject: [PATCH 2/5] add with-default-read case --- tests/pact/tc.repl | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/tests/pact/tc.repl b/tests/pact/tc.repl index a903bea8b..abacad35e 100644 --- a/tests/pact/tc.repl +++ b/tests/pact/tc.repl @@ -222,6 +222,16 @@ { 'name: name , 'age: age })) + + (defun fails-with-default-read-partial-schema:object{person} () + (with-default-read persons 'dave + { 'name:= name + , 'age:= age } + { 'name: "dave" + , 'age: 23 } + { 'name: name + , 'age: age })) + (defcap CAP () true) (defun fails-with-capability-bad-object:object{person} () From 0fcd8c06ec847bea5d870325f6de3d2933d71a94 Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Thu, 27 Apr 2023 13:38:31 -0700 Subject: [PATCH 3/5] [FORK] Add runtime type check for function return types --- examples/cp/orders.pact | 2 +- src/Pact/Eval.hs | 9 ++++++++- tests/pact/tc.repl | 24 ++++++++++++++++++++++++ 3 files changed, 33 insertions(+), 2 deletions(-) diff --git a/examples/cp/orders.pact b/examples/cp/orders.pact index 67dbf0786..0979aeda8 100644 --- a/examples/cp/orders.pact +++ b/examples/cp/orders.pact @@ -48,7 +48,7 @@ ) - (defun with-order-status:object{order} (order-id status) + (defun with-order-status (order-id status) "Check that order status is correct, returning details" (let ((o (read orders order-id))) (enforce (= (at 'status o) status) diff --git a/src/Pact/Eval.hs b/src/Pact/Eval.hs index 8be0027a0..e06b0ba18 100644 --- a/src/Pact/Eval.hs +++ b/src/Pact/Eval.hs @@ -1173,7 +1173,14 @@ functionApp fnName funTy mod_ as fnBody docs ai = do let body = instantiate (resolveArg ai args') fnBody fname = asString fnName fa = FunApp ai fname mod_ Defun (funTypes fty) docs - guardRecursion fname mod_ $ appCall fa ai args' $ fmap (gas,) $ reduceBody body + + returnVal <- guardRecursion fname mod_ $ appCall fa ai args' $ fmap (gas,) $ reduceBody body + + unlessExecutionFlagSet FlagDisablePact47 $ + typecheckTerm ai (_ftReturn fty) returnVal + + return returnVal + -- | Evaluate a dynamic ref to either a fully-reduced value from a 'TConst' -- or a module member 'Def' for applying. diff --git a/tests/pact/tc.repl b/tests/pact/tc.repl index abacad35e..7fba7a71b 100644 --- a/tests/pact/tc.repl +++ b/tests/pact/tc.repl @@ -368,3 +368,27 @@ "rtc object lists" 1 (rtc-object-list (let ((a {'a:1}) (b {'a: 2})) [a b]))) + +;; A module with incorrect annotations for a function's return type. +;; Runtime typechecking for function return types was added in +;; pact-4.7. +(module tc-test-function-return-types g + (defcap g () true) + (defun f:string () (+ 1 2)) +) + +(expect-failure + "evaluating a function whose type signature conflits with its body should fail" + (tc-test-function-return-types.f) + ) + +(expect-failure + "composing an ill-typed function with another function should not evaluate" + (tc-test-function-return-types.g (tc-test-function-return-types.f 1)) + ) + +(env-exec-config ["DisablePact47"]) +(expect + "evaluatingn ill-typed function should succeed with pact-4.7 features disabled" + 3 + (tc-test-function-return-types.f)) From b2661a2460b066c6d1e1e082806b8756321fb17d Mon Sep 17 00:00:00 2001 From: Gregory Hale Date: Wed, 10 May 2023 07:34:50 -0700 Subject: [PATCH 4/5] spelling error --- tests/pact/tc.repl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/pact/tc.repl b/tests/pact/tc.repl index 7fba7a71b..1b6483eab 100644 --- a/tests/pact/tc.repl +++ b/tests/pact/tc.repl @@ -389,6 +389,6 @@ (env-exec-config ["DisablePact47"]) (expect - "evaluatingn ill-typed function should succeed with pact-4.7 features disabled" + "evaluating ill-typed function should succeed with pact-4.7 features disabled" 3 (tc-test-function-return-types.f)) From 9538e7c68feb51336c98a4cc9c0863cfe131d1a4 Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Wed, 10 May 2023 07:37:50 -0700 Subject: [PATCH 5/5] Update tests/pact/tc.repl Co-authored-by: Stuart Popejoy <8353613+sirlensalot@users.noreply.github.com>