diff --git a/pact-tests/pact-tests/caps.repl b/pact-tests/pact-tests/caps.repl index e1178259..49c01183 100644 --- a/pact-tests/pact-tests/caps.repl +++ b/pact-tests/pact-tests/caps.repl @@ -46,6 +46,18 @@ (defun enforce-msg-keyset (key:string) (enforce-keyset (read-keyset key))) + (defun create-read-only-db-user-guard () + @doc "Creates a user guard which tries to read from the DB, which is not allowed. This will fail when the guard is enforced." + ; this insert succeeds: + (insert ints 'y {'i: 0}) + (create-user-guard (read-only-user-guard-fun 'y))) + + (defun read-only-user-guard-fun (x:string) + (let ((row (read ints x))) + (enforce (= 0 (at 'i row)) "int wasn't zero") + )) + + (defun create-bad-db-user-guard () @doc "Creates a user guard which tries to read from the DB, which is not allowed. This will fail when the guard is enforced." ; this insert succeeds: @@ -54,7 +66,9 @@ (defun bad-user-guard-fun (x:string) (let ((row (read ints x))) - (enforce (= 0 (at 'i row)) "int wasn't zero"))) + (enforce (= 0 (at 'i row)) "int wasn't zero") + (write ints x {"i":(+ (at "i" row) 1)}) + )) (defpact test-pact-guards (id:string) (step (step1 id)) @@ -196,7 +210,14 @@ (enforce-guard (keyset-ref-guard "k2"))) (let ((bad-db-user-guard (create-bad-db-user-guard))) - (expect-failure "reading db from within user guard" (enforce-guard bad-db-user-guard))) + (expect-failure "writing to db from within user guard" (enforce-guard bad-db-user-guard))) + +(let ((read-only-user-guard (create-read-only-db-user-guard))) + (expect "User guard works successfully in read-only mode" true (enforce-guard read-only-user-guard))) + +; The previous test wrote to 'y, so we can just reuse that +(let ((read-only-user-guard (create-user-guard (read-only-user-guard-fun "y")))) + (expect "Read-only works successfully in enforce" true (enforce (enforce-guard read-only-user-guard) "enforce works"))) (env-hash (hash "pact-guards-a-id")) ;; equivalent of pact-id (test-pact-guards "a") @@ -993,7 +1014,7 @@ ) (defun emit-a(a:integer) (emit-event (A_EVENT a a)))) - + (use B) (call-a) diff --git a/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs b/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs index ff130b3e..a30c0811 100644 --- a/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs +++ b/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs @@ -225,7 +225,7 @@ evaluateTerm cont handler env (BuiltinForm c info) = case c of -- chargeGasArgs info (GAConstant constantWorkNodeGas) evalCEK (CondC env info (IfC e1 e2) cont) handler env cond CEnforce cond str -> do - let env' = sysOnlyEnv env + let env' = readOnlyEnv env -- chargeGasArgs info (GAConstant constantWorkNodeGas) evalCEK (CondC env' info (EnforceC str) cont) handler env' cond -- | ------ From --------------- | ------ To ------------------------ | @@ -1558,7 +1558,7 @@ runUserGuard info cont handler env (UserGuard qn args) = getModuleMemberWithHash info qn >>= \case (Dfun d, mh) -> do when (length (_dfunArgs d) /= length args) $ throwExecutionError info CannotApplyPartialClosure - let env' = sysOnlyEnv env + let env' = readOnlyEnv env clo <- mkDefunClosure d (qualNameToFqn qn mh) env' -- Todo: sys only here applyLam (C clo) (VPactValue <$> args) (IgnoreValueC (PBool True) cont) handler diff --git a/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs b/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs index 305234dd..b7e336e1 100644 --- a/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs +++ b/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs @@ -271,7 +271,7 @@ evaluate env = \case if b then evaluate env ifExpr else evaluate env elseExpr CEnforce cond str -> do - let env' = sysOnlyEnv env + let env' = readOnlyEnv env b <- enforceBool info =<< evaluate env' cond -- chargeGasArgs info (GAConstant constantWorkNodeGas) if b then return (VBool True) @@ -882,7 +882,7 @@ runUserGuard info env (UserGuard qn args) = getModuleMemberWithHash info qn >>= \case (Dfun d, mh) -> do when (length (_dfunArgs d) /= length args) $ throwExecutionError info CannotApplyPartialClosure - let env' = sysOnlyEnv env + let env' = readOnlyEnv env clo <- mkDefunClosure d (qualNameToFqn qn mh) env' -- Todo: sys only here True <$ (applyLam (C clo) (VPactValue <$> args) >>= enforcePactValue info)