diff --git a/pact-lsp/Pact/Core/LanguageServer/Utils.hs b/pact-lsp/Pact/Core/LanguageServer/Utils.hs index fcfa92c6..55107837 100644 --- a/pact-lsp/Pact/Core/LanguageServer/Utils.hs +++ b/pact-lsp/Pact/Core/LanguageServer/Utils.hs @@ -34,6 +34,7 @@ termAt p term CWithCapability a b -> termAt p a <|> termAt p b CTry a b -> termAt p a <|> termAt p b CCreateUserGuard a -> termAt p a + CRunReadOnly a -> termAt p a <|> Just t t@(ListLit tms _) -> getAlt (foldMap (Alt . termAt p) tms) <|> Just t t@(Nullary tm _) -> termAt p tm <|> Just t diff --git a/pact-tests/pact-tests/read-only.repl b/pact-tests/pact-tests/read-only.repl new file mode 100644 index 00000000..a984b2af --- /dev/null +++ b/pact-tests/pact-tests/read-only.repl @@ -0,0 +1,26 @@ +(module read-only-test g + (defcap g () true) + + (defschema sc a:integer b:string) + (deftable tbl:{sc}) + + (defcap ENFORCE_ME (a:integer) true) + + (defun write-entry (k:string a:integer b:string) + (write tbl k {"a":a, "b":b}) + ) + + (defun read-entry (k:string) + (read tbl k) + ) + + (defun write-then-read (k:string a:integer b:string) + (write-entry k a b) + (read-entry k) + )) + +(create-table tbl) + +(expect "Writes and reads work" {"a":1, "b":"v"} (write-then-read "k" 1 "v") ) +(expect-failure "Writes do not work in read-only mode" (run-read-only (write-then-read "k" 1 "v"))) +(expect "Only reads work in read-only mode" {"a":1, "b":"v"} (run-read-only (read-entry "k"))) diff --git a/pact/Pact/Core/Builtin.hs b/pact/Pact/Core/Builtin.hs index cd0f0f2e..9f348265 100644 --- a/pact/Pact/Core/Builtin.hs +++ b/pact/Pact/Core/Builtin.hs @@ -52,6 +52,7 @@ data BuiltinForm o | CWithCapability o o | CCreateUserGuard o | CEnforceOne o o + | CRunReadOnly o | CTry o o deriving (Show, Eq, Functor, Foldable, Traversable, Generic) @@ -75,6 +76,8 @@ instance Pretty o => Pretty (BuiltinForm o) where parens ("create-user-guard" <+> pretty o) CTry o o' -> parens ("try" <+> pretty o <+> pretty o') + CRunReadOnly o -> + parens ("run-read-only" <+> pretty o) -- | Our list of base-builtins to pact. data CoreBuiltin diff --git a/pact/Pact/Core/IR/Desugar.hs b/pact/Pact/Core/IR/Desugar.hs index 400c102a..7e4651d7 100644 --- a/pact/Pact/Core/IR/Desugar.hs +++ b/pact/Pact/Core/IR/Desugar.hs @@ -260,6 +260,7 @@ data SpecialForm | SFTry | SFMap | SFCond + | SFRunReadOnly | SFCreateUserGuard deriving (Eq, Show, Enum, Bounded) @@ -274,6 +275,7 @@ toSpecialForm = \case "enforce-one" -> Just SFEnforceOne "try" -> Just SFTry "map" -> Just SFMap + "run-read-only" -> Just SFRunReadOnly "do" -> Just SFDo "cond" -> Just SFCond "create-user-guard" -> Just SFCreateUserGuard @@ -363,6 +365,9 @@ desugarSpecial (bn@(BareName t), varInfo) dsArgs appInfo = case toSpecialForm t [e] -> BuiltinForm <$> (CCreateUserGuard <$> desugarLispTerm e) <*> pure appInfo _ -> throwDesugarError (InvalidSyntax "create-user-guard must take one argument, which must be an application") appInfo SFMap -> desugar1ArgHOF MapV args + SFRunReadOnly -> case args of + [e] -> BuiltinForm <$> (CRunReadOnly <$> desugarLispTerm e) <*> pure appInfo + _ -> throwDesugarError (InvalidSyntax "run-read-only must take one argument") appInfo SFCond -> case reverse args of defCase:xs -> do defCase' <- desugarLispTerm defCase diff --git a/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs b/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs index ff130b3e..0dbd9a99 100644 --- a/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs +++ b/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs @@ -249,6 +249,9 @@ evaluateTerm cont handler env (BuiltinForm c info) = case c of evalCEK cont' handler env x _ -> throwExecutionError info $ NativeExecutionError (NativeName "create-user-guard") $ "create-user-guard: expected function application of a top-level function" + CRunReadOnly term -> do + let env' = readOnlyEnv env + evalCEK cont handler env' term -- | ------ From --------------- | ------ To ------------------------ | -- -- _errState - callstack,granted caps,events,gas @@ -314,7 +317,7 @@ mkDefPactClosure -> FullyQualifiedName -> DefPact Name Type b i -> CEKEnv e b i - ->CEKValue e b i + -> CEKValue e b i mkDefPactClosure info fqn dpact env = case _dpArgs dpact of [] -> let dpc = DefPactClosure fqn NullaryClosure 0 env info diff --git a/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs b/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs index 305234dd..171694e4 100644 --- a/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs +++ b/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs @@ -45,7 +45,6 @@ module Pact.Core.IR.Eval.Direct.Evaluator import Control.Lens hiding (op, from, to, parts) import Control.Monad import Control.Monad.Except -import Control.Monad.Reader import Control.Monad.State.Strict import Data.Text(Text) import Data.Foldable @@ -278,6 +277,9 @@ evaluate env = \case else do msg <- enforceString info =<< evaluate env str throwUserRecoverableError info (UserEnforceError msg) + CRunReadOnly e -> do + let env' = readOnlyEnv env + evaluate env' e CWithCapability cap body -> do enforceNotWithinDefcap info env "with-capability" rawCap <- enforceCapToken info =<< evaluate env cap diff --git a/pact/Pact/Core/Serialise/CBOR_V1.hs b/pact/Pact/Core/Serialise/CBOR_V1.hs index b729e353..c9948341 100644 --- a/pact/Pact/Core/Serialise/CBOR_V1.hs +++ b/pact/Pact/Core/Serialise/CBOR_V1.hs @@ -372,6 +372,8 @@ instance (Serialise (SerialiseV1 b), Serialise (SerialiseV1 i)) encodeListLen 3 <> encodeWord 6 <> encodeS t1 <> encodeS t2 CCreateUserGuard t1 -> encodeListLen 2 <> encodeWord 7 <> encodeS t1 + CRunReadOnly t1 -> + encodeListLen 2 <> encodeWord 8 <> encodeS t1 {-# INLINE encode #-} decode = do @@ -385,6 +387,7 @@ instance (Serialise (SerialiseV1 b), Serialise (SerialiseV1 i)) 5 -> CWithCapability <$> decodeS <*> decodeS 6 -> CTry <$> decodeS <*> decodeS 7 -> CCreateUserGuard <$> decodeS + 8 -> CRunReadOnly <$> decodeS _ -> fail "unexpected decoding" {-# INLINE decode #-} diff --git a/test-utils/Pact/Core/Gen.hs b/test-utils/Pact/Core/Gen.hs index 8049e05a..c067ed05 100644 --- a/test-utils/Pact/Core/Gen.hs +++ b/test-utils/Pact/Core/Gen.hs @@ -258,6 +258,7 @@ builtinFormGen b i = Gen.choice , CWithCapability <$> termGen b i <*> termGen b i , CTry <$> termGen b i <*> termGen b i , CCreateUserGuard <$> termGen b i + , CRunReadOnly <$> termGen b i ] termGen :: Gen b -> Gen i -> Gen (Term Name Type b i)