[Experimental] Non-reentrancy special form

pact-lsp/Pact/Core/LanguageServer/Utils.hs

@@ -35,6 +35,7 @@ termAt p term
           CEnforce a b -> termAt p a <|> termAt p b
           CWithCapability a b -> termAt p a <|> termAt p b
           CTry a b -> termAt p a <|> termAt p b
+          CNonReentrant a -> termAt p a
           CCreateUserGuard a -> termAt p a
         <|> Just t
       t@(ListLit tms _) -> getAlt (foldMap (Alt . termAt p) tms) <|> Just t

pact-repl/Pact/Core/IR/Eval/Direct/Evaluator.hs

@@ -125,7 +125,7 @@ eval
   -> EvalM e b i PactValue
 eval purity benv term = do
   ee <- viewEvalEnv id
-  let directEnv = envFromPurity purity (DirectEnv mempty (_eePactDb ee) benv (_eeDefPactStep ee) False)
+  let directEnv = envFromPurity purity (DirectEnv mempty (_eePactDb ee) benv (_eeDefPactStep ee) mempty False)
   evaluate directEnv term >>= \case
     VPactValue pv -> pure pv
     _ -> throwExecutionError (view termInfo term) (EvalError "Evaluation did not reduce to a value")
@@ -144,7 +144,7 @@ evalWithinCap info purity benv (CapToken qualName vs) term = do
   ee <- viewEvalEnv id
   (_, mh) <- getDefCapQN info qualName
   let ct = CapToken (qualNameToFqn qualName mh) vs
-  let cekEnv = envFromPurity purity (DirectEnv mempty (_eePactDb ee) benv (_eeDefPactStep ee) False)
+  let cekEnv = envFromPurity purity (DirectEnv mempty (_eePactDb ee) benv (_eeDefPactStep ee) mempty False)
   evalCap (view termInfo term) cekEnv ct PopCapInvoke NormalCapEval term >>= \case
     VPactValue pv -> pure pv
     _ ->
@@ -159,7 +159,7 @@ interpretGuard
   -> EvalM e b i PactValue
 interpretGuard info bEnv g = do
   ee <- viewEvalEnv id
-  let eEnv = DirectEnv mempty (_eePactDb ee) bEnv (_eeDefPactStep ee) False
+  let eEnv = DirectEnv mempty (_eePactDb ee) bEnv (_eeDefPactStep ee) mempty False
   PBool <$> enforceGuard info eEnv g
 
 evalResumePact
@@ -171,7 +171,7 @@ evalResumePact
 evalResumePact info bEnv mdpe = do
   ee <- viewEvalEnv id
   let pdb = _eePactDb ee
-  let env = DirectEnv mempty pdb bEnv (_eeDefPactStep ee) False
+  let env = DirectEnv mempty pdb bEnv (_eeDefPactStep ee) mempty False
   resumePact info env mdpe >>= \case
     VPactValue pv -> pure pv
     _ ->
@@ -252,8 +252,7 @@ evaluate env = \case
     case e1val of
       VPactValue pv -> maybeTCType i (_argType arg) pv
       _ -> pure ()
-    let newEnv = RAList.cons e1val (_ceLocal env)
-    let env' = env {_ceLocal = newEnv }
+    let env' = env {_ceLocal = RAList.cons e1val (_ceLocal env) }
     evaluate env' e2
   Lam args body info -> do
       let clo = VLamClosure (LamClosure (ArgClosure args) (NE.length args) body Nothing env info)
@@ -299,6 +298,12 @@ evaluate env = \case
       chargeTryNodeWork info
       let env' = readOnlyEnv env
       catchRecoverable (evaluate env' tryExpr) (\_ _ -> evaluate env catchExpr)
+    CNonReentrant term -> findCallingModule >>= \case
+      -- todo: give this own error its own ADT entry
+      Nothing -> throwExecutionError info (EvalError "can only call non-reentrant in module code")
+      Just mn -> do
+        let env' = env & ceNonReentrant %~ S.insert mn
+        evaluate env' term
     CEnforceOne str (ListLit conds _) ->
       go conds
       where
@@ -408,7 +413,7 @@ evalCap info env origToken@(CapToken fqn args) popType ecType contbody = do
         let inCapEnv = set ceInCap True $ set ceLocal newLocals env
         (esCaps . csSlots) %= (CapSlot qualCapToken []:)
         (esCaps . csCapsBeingEvaluated) %= S.insert qualCapToken
-        _ <- evalWithStackFrame info capStackFrame Nothing (evaluate inCapEnv capBody)
+        _ <- evalWithStackFrame info capStackFrame Nothing inCapEnv (evaluate inCapEnv capBody)
         (esCaps . csCapsBeingEvaluated) .= oldCapsBeingEvaluated
         evalWithCapBody info popType Nothing event env contbody
       -- Not automanaged _nor_ user managed.
@@ -418,7 +423,7 @@ evalCap info env origToken@(CapToken fqn args) popType ecType contbody = do
         (esCaps . csSlots) %= (CapSlot qualCapToken []:)
         (esCaps . csCapsBeingEvaluated) %= S.insert qualCapToken
         -- we ignore the capbody here
-        _ <- evalWithStackFrame info capStackFrame Nothing $ evaluate inCapEnv capBody
+        _ <- evalWithStackFrame info capStackFrame Nothing inCapEnv $ evaluate inCapEnv capBody
         (esCaps . csCapsBeingEvaluated) .= oldCapsBeingEvaluated
         case ecType of
           NormalCapEval -> do
@@ -450,7 +455,7 @@ evalCap info env origToken@(CapToken fqn args) popType ecType contbody = do
       -- this is done in `CapBodyC` and this is the only way to do this.
       (esCaps . csSlots) %= (CapSlot inCapBodyToken []:)
       (esCaps . csCapsBeingEvaluated) %= S.insert inCapBodyToken
-      _ <- evalWithStackFrame info capStackFrame Nothing (evaluate inCapEnv capBody)
+      _ <- evalWithStackFrame info capStackFrame Nothing inCapEnv (evaluate inCapEnv capBody)
       (esCaps . csCapsBeingEvaluated) .= oldCapsBeingEvaluated
       when (ecType == NormalCapEval) $ do
         updatedV <- enforcePactValue info =<< applyLam info (C dfunClo) [VPactValue oldV, VPactValue newV]
@@ -468,7 +473,7 @@ evalCap info env origToken@(CapToken fqn args) popType ecType contbody = do
         esCaps . csSlots %= (CapSlot qualCapToken []:)
         (esCaps . csCapsBeingEvaluated) %= S.insert qualCapToken
         let inCapEnv = set ceLocal env' $ set ceInCap True $ env
-        _ <- evalWithStackFrame info capStackFrame Nothing (evaluate inCapEnv capBody)
+        _ <- evalWithStackFrame info capStackFrame Nothing inCapEnv (evaluate inCapEnv capBody)
         (esCaps . csCapsBeingEvaluated) .= oldCapsBeingEvaluated
 
         evalWithCapBody info popType Nothing emittedEvent env contbody
@@ -647,13 +652,18 @@ sysOnlyEnv e
     DUserTables _ -> dbOpDisallowed
     _ -> _pdbRead pdb dom k
 
-evalWithStackFrame :: i -> StackFrame i -> Maybe Type -> EvalM e b i (EvalValue e b i) -> EvalM e b i (EvalValue e b i)
-evalWithStackFrame info sf mty act = do
+evalWithStackFrame :: i -> StackFrame i -> Maybe Type -> DirectEnv e b i -> EvalM e b i (EvalValue e b i) -> EvalM e b i (EvalValue e b i)
+evalWithStackFrame info sf mty env act = do
+  let callingModule = _fqModule $ _sfName sf
+  when (S.member callingModule (_ceNonReentrant env)) $
+    throwUserRecoverableError info $ UserEnforceError $
+      "reentrancy not allowed on module: " <> renderModuleName callingModule
   esStack %= (sf:)
 #ifdef WITH_FUNCALL_TRACING
   timeEnter <- liftIO $ getTime ProcessCPUTime
   esTraceOutput %= (TraceFunctionEnter timeEnter sf info:)
 #endif
+
   v <- act
   esStack %= safeTail
   pv <- enforcePactValue info v
@@ -710,9 +720,10 @@ applyLam cloi vc@(C (Closure fqn ca arity term mty env _)) args
       zipWithM_ (\arg (Arg _ ty _) -> maybeTCType cloi ty arg) args' (NE.toList cloargs)
       let sf = StackFrame fqn args' SFDefun cloi
           varEnv = RAList.fromList (reverse args)
-      evalWithStackFrame cloi sf mty (evaluate (set ceLocal varEnv env) term)
+          newEnv = set ceLocal varEnv env
+      evalWithStackFrame cloi sf mty newEnv (evaluate newEnv term)
     NullaryClosure -> do
-      evalWithStackFrame cloi (StackFrame fqn [] SFDefun cloi) mty $ evaluate (set ceLocal mempty env) term
+      evalWithStackFrame cloi (StackFrame fqn [] SFDefun cloi) mty env $ evaluate (set ceLocal mempty env) term
   | argLen > arity = throwExecutionError cloi ClosureAppliedToTooManyArgs
   | otherwise = case ca of
     NullaryClosure -> throwExecutionError cloi ClosureAppliedToTooManyArgs
@@ -775,7 +786,8 @@ applyLam cloi (PC (PartialClosure li argtys nargs _ term mty env _)) args = do
   apply' _ e [] [] = do
     case li of
       Just sf -> do
-        evalWithStackFrame cloi sf mty $ evaluate (set ceLocal e env) term
+        let newEnv = set ceLocal e env
+        evalWithStackFrame cloi sf mty newEnv $ evaluate newEnv term
       Nothing -> do
         evaluate (set ceLocal e env) term >>= enforcePactValue' cloi
   apply' n e (ty:tys) [] = do
@@ -1135,11 +1147,11 @@ applyPact i pc ps cenv nested = use esDefPactExec >>= \case
       result <- case (ps ^. psRollback, step) of
         (False, _) -> case ordinaryDefPactStepExec step of
           Just stepExpr ->
-            evalWithStackFrame i sf Nothing $ evaluate cenv stepExpr
+            evalWithStackFrame i sf Nothing cenv $ evaluate cenv stepExpr
           Nothing ->
             throwExecutionError i (EntityNotAllowedInDefPact (_pcName pc))
         (True, StepWithRollback _ rollbackExpr) ->
-          evalWithStackFrame i sf Nothing $ evaluate cenv rollbackExpr
+          evalWithStackFrame i sf Nothing cenv $ evaluate cenv rollbackExpr
         (True, Step{}) ->
           throwExecutionError i (DefPactStepHasNoRollback ps)
         (True, LegacyStepWithEntity{}) -> throwExecutionError i (DefPactStepHasNoRollback ps)
@@ -1221,11 +1233,11 @@ applyNestedPact i pc ps cenv = use esDefPactExec >>= \case
       result <- case (ps ^. psRollback, step) of
         (False, _) -> case ordinaryDefPactStepExec step of
           Just stepExpr ->
-            evalWithStackFrame i sf Nothing $ evaluate cenv' stepExpr
+            evalWithStackFrame i sf Nothing cenv' $ evaluate cenv' stepExpr
           Nothing ->
             throwExecutionError i (EntityNotAllowedInDefPact (_pcName pc))
         (True, StepWithRollback _ rollbackExpr) ->
-          evalWithStackFrame i sf Nothing $ evaluate cenv' rollbackExpr
+          evalWithStackFrame i sf Nothing cenv' $ evaluate cenv' rollbackExpr
         (True, Step{}) -> throwExecutionError i (DefPactStepHasNoRollback ps)
         (True, LegacyStepWithEntity{}) -> throwExecutionError i (DefPactStepHasNoRollback ps)
         (True, LegacyStepWithRBEntity{}) ->

pact-repl/Pact/Core/IR/Eval/Direct/Types.hs

@@ -27,7 +27,7 @@ module Pact.Core.IR.Eval.Direct.Types
  , DirectEnv(..)
  , ceLocal, ceDefPactStep
  , ceBuiltins, cePactDb
- , ceInCap
+ , ceInCap, ceNonReentrant
  , pattern VLiteral
  , pattern VString
  , pattern VInteger
@@ -66,6 +66,7 @@ import Data.RAList(RAList)
 import Data.Map.Strict(Map)
 import Data.Vector(Vector)
 import Pact.Time(UTCTime)
+import Data.Set(Set)
 import qualified Data.Kind as K
 
 
@@ -222,14 +223,15 @@ data DirectEnv e b i
   , _cePactDb :: PactDb b i
   , _ceBuiltins :: BuiltinEnv e b i
   , _ceDefPactStep :: Maybe DefPactStep
+  , _ceNonReentrant :: Set ModuleName
   , _ceInCap :: Bool }
   deriving (Generic)
 
 instance (NFData b, NFData i) => NFData (DirectEnv e b i)
 
 
 instance (Show i, Show b) => Show (DirectEnv e b i) where
-  show (DirectEnv e _ _ _ _) = show e
+  show (DirectEnv e _ _ _ _ _) = show e
 
 type NativeFunction (e :: RuntimeMode) (b :: K.Type) (i :: K.Type)
   = i -> b -> DirectEnv e b i -> [EvalValue e b i] -> EvalM e b i (EvalValue e b i)

pact-repl/Pact/Core/Typed/Infer.hs

@@ -2263,6 +2263,9 @@ checkTermType checkty = \case
         (_, ct', pe1) <- checkTermType (Located i TyCapToken) ct
         (_, body', pe2) <- checkTermType checkty body
         pure (Located i (_locElem checkty), CWithCapability ct' body', pe1 ++ pe2)
+      CNonReentrant term -> do
+        (outTy, outTerm, outPreds) <- checkTermType checkty term
+        pure (outTy, CNonReentrant outTerm, outPreds)
       CCreateUserGuard c -> case c of
         IR.App{} -> do
           unify checkty (Located i TyGuard)
@@ -2417,6 +2420,9 @@ inferTerm = \case
         (_, ct', pe1) <- checkTermType (Located i TyCapToken) ct
         (rty, body', pe2) <- inferTerm body
         pure (rty, CWithCapability ct' body', pe1 ++ pe2)
+      CNonReentrant term -> do
+        (outTy, outTerm, outPreds) <- inferTerm term
+        pure (outTy, CNonReentrant outTerm, outPreds)
       CCreateUserGuard c -> case c of
         IR.App{} -> do
           (t, c', pe1) <- inferTerm c

pact-tests/pact-tests/reentrancy.repl

@@ -0,0 +1,54 @@
+(interface foo-callable
+
+  (defun foo:integer (a:integer))
+
+  (defun bar:integer (b:integer))
+  )
+
+(module is-not-reentrant g
+
+  (defcap g () true)
+
+  (defcap SENSITIVE () true)
+
+  (defun definitely-not-reentrant (m:module{foo-callable})
+    (with-capability (SENSITIVE)
+      ; NAME IS TENTATIVE
+      (non-reentrant (m::foo 1))
+      (called-internal)
+      )
+  )
+
+  (defun called-internal ()
+    (require-capability (SENSITIVE))
+    123
+  ))
+
+(module malicious g
+  (defcap g () true)
+
+  (implements foo-callable)
+
+  (defun foo:integer (a:integer)
+    (is-not-reentrant.called-internal)
+  )
+
+  (defun bar:integer (b:integer)
+    (is-not-reentrant.called-internal)
+  ))
+
+(module non-malicious g
+    (defcap g () true)
+
+    (implements foo-callable)
+
+    (defun foo:integer (a:integer)
+      (+ a 1)
+    )
+
+    (defun bar:integer (b:integer)
+      (+ b 2)
+    ))
+
+(expect "non-malicious module still returns properly" 123 (is-not-reentrant.definitely-not-reentrant non-malicious))
+(expect-failure "malicious module execution fails due to reentrancy" "reentrancy not allowed on module: is-not-reentrant" (is-not-reentrant.definitely-not-reentrant malicious))

pact/Pact/Core/Builtin.hs

@@ -56,6 +56,7 @@ data BuiltinForm o
   | CCreateUserGuard o
   | CEnforceOne o o
   | CTry o o
+  | CNonReentrant o
   deriving (Show, Eq, Functor, Foldable, Traversable, Generic)
 
 instance NFData o => NFData (BuiltinForm o)
@@ -78,6 +79,8 @@ instance Pretty o => Pretty (BuiltinForm o) where
       parens ("create-user-guard" <+> pretty o)
     CTry o o' ->
       parens ("try" <+> pretty o <+> pretty o')
+    CNonReentrant o ->
+      parens ("non-reentrant" <+> pretty o)
 
 -- | Our list of base-builtins to pact.
 data CoreBuiltin

pact/Pact/Core/IR/Desugar.hs

@@ -262,6 +262,7 @@ data SpecialForm
   | SFMap
   | SFCond
   | SFCreateUserGuard
+  | SFNonReentrant
   deriving (Eq, Show, Enum, Bounded)
 
 toSpecialForm :: Text -> Maybe SpecialForm
@@ -278,8 +279,17 @@ toSpecialForm = \case
   "do" -> Just SFDo
   "cond" -> Just SFCond
   "create-user-guard" -> Just SFCreateUserGuard
+  "non-reentrant" -> Just SFNonReentrant
   _ -> Nothing
 
+forkedToSpecialForm :: (Monad (t (EvalM e b i)), MonadTrans t) => Text -> t (EvalM e b i) (Maybe SpecialForm)
+forkedToSpecialForm f = do
+  flags <- lift (viewEvalEnv eeFlags)
+  case toSpecialForm f of
+    Just SFNonReentrant | S.member FlagDisablePact52 flags -> pure Nothing
+    v -> pure v
+{-# INLINE forkedToSpecialForm #-}
+
 conditionalLam2Arg :: (Term ParsedName ty1 builtin1 info  -> Term ParsedName ty2 builtin2 info  -> BuiltinForm (Term name Lisp.Type builtin3 info)) -> info -> Term name Lisp.Type builtin3 info
 conditionalLam2Arg c info = let
   arg1Name = "#condArg1"
@@ -300,7 +310,7 @@ desugarSpecial
   -> [Lisp.Expr i]
   -> i
   -> RenamerM e b i (Term ParsedName Lisp.Type b i)
-desugarSpecial (bn@(BareName t), varInfo) dsArgs appInfo = case toSpecialForm t of
+desugarSpecial (bn@(BareName t), varInfo) dsArgs appInfo = forkedToSpecialForm t >>= \case
     Just sf -> goSpecial dsArgs sf
     Nothing -> desugarFn (Lisp.Var (BN bn) varInfo) dsArgs
   where
@@ -364,6 +374,9 @@ desugarSpecial (bn@(BareName t), varInfo) dsArgs appInfo = case toSpecialForm t
       [[email protected]{}] -> 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
+    SFNonReentrant -> case args of
+      [x] -> BuiltinForm <$> (CNonReentrant <$> desugarLispTerm x) <*> pure appInfo
+      _ -> throwDesugarError (InvalidSyntax "non-reentrant must take two arguments") appInfo
     SFCond -> case reverse args of
       defCase:xs -> do
         defCase' <- desugarLispTerm defCase