Skip to content

[Experimental] Non-reentrancy special form #362

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Draft
wants to merge 1 commit into
base: master
Choose a base branch
from
Draft
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions pact-lsp/Pact/Core/LanguageServer/Utils.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
50 changes: 31 additions & 19 deletions pact-repl/Pact/Core/IR/Eval/Direct/Evaluator.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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")
Expand All @@ -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
_ ->
Expand All @@ -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
Expand All @@ -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
_ ->
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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.
Expand All @@ -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
Expand Down Expand Up @@ -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]
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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{}) ->
Expand Down
6 changes: 4 additions & 2 deletions pact-repl/Pact/Core/IR/Eval/Direct/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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


Expand Down Expand Up @@ -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)
Expand Down
6 changes: 6 additions & 0 deletions pact-repl/Pact/Core/Typed/Infer.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down
54 changes: 54 additions & 0 deletions pact-tests/pact-tests/reentrancy.repl
Original file line number Diff line number Diff line change
@@ -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))
3 changes: 3 additions & 0 deletions pact/Pact/Core/Builtin.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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
Expand Down
15 changes: 14 additions & 1 deletion pact/Pact/Core/IR/Desugar.hs
Original file line number Diff line number Diff line change
Expand Up @@ -262,6 +262,7 @@ data SpecialForm
| SFMap
| SFCond
| SFCreateUserGuard
| SFNonReentrant
deriving (Eq, Show, Enum, Bounded)

toSpecialForm :: Text -> Maybe SpecialForm
Expand All @@ -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"
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down
Loading