run-read-only native

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

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")))

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

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

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 ------------------------ |
   --   <Try c body, E, K, H>         <body, E, Mt, CEKHandler(E,c,K,_errState,H)>
   --   _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

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

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 #-}
 

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)