From a0aa304c01130ef81003d508d427bfdfe01511a0 Mon Sep 17 00:00:00 2001 From: jmcardon Date: Wed, 24 Apr 2024 17:33:55 -0400 Subject: [PATCH] whitelist v1 --- docs/en/pact-functions.md | 10 +++++++- src/Pact/Interpreter.hs | 1 + src/Pact/Repl.hs | 1 + src/Pact/Repl/Lib.hs | 23 ++++++++++++++++- src/Pact/Runtime/Capabilities.hs | 42 ++++++++++++++++++++++++++++---- src/Pact/Types/Purity.hs | 1 + src/Pact/Types/Runtime.hs | 6 ++++- 7 files changed, 76 insertions(+), 8 deletions(-) diff --git a/docs/en/pact-functions.md b/docs/en/pact-functions.md index 14533f779..bfbbe5f26 100644 --- a/docs/en/pact-functions.md +++ b/docs/en/pact-functions.md @@ -1971,7 +1971,7 @@ Retreive any accumulated events and optionally clear event state. Object returne *→* `[string]` -Queries, or with arguments, sets execution config flags. Valid flags: ["AllowReadInLocal","DisableHistoryInTransactionalMode","DisableInlineMemCheck","DisableModuleInstall","DisableNewTrans","DisablePact40","DisablePact410","DisablePact411","DisablePact42","DisablePact43","DisablePact431","DisablePact44","DisablePact45","DisablePact46","DisablePact47","DisablePact48","DisablePact49","DisablePactEvents","DisableRuntimeReturnTypeChecking","EnforceKeyFormats","OldReadOnlyBehavior","PreserveModuleIfacesBug","PreserveModuleNameBug","PreserveNsModuleInstallBug","PreserveShowDefs"] +Queries, or with arguments, sets execution config flags. Valid flags: ["AllowReadInLocal","DisableHistoryInTransactionalMode","DisableInlineMemCheck","DisableModuleInstall","DisableNewTrans","DisablePact40","DisablePact410","DisablePact411","DisablePact412","DisablePact42","DisablePact43","DisablePact431","DisablePact44","DisablePact45","DisablePact46","DisablePact47","DisablePact48","DisablePact49","DisablePactEvents","DisableRuntimeReturnTypeChecking","EnforceKeyFormats","OldReadOnlyBehavior","PreserveModuleIfacesBug","PreserveModuleNameBug","PreserveNsModuleInstallBug","PreserveShowDefs"] ```lisp pact> (env-exec-config ['DisableHistoryInTransactionalMode]) (env-exec-config) ["DisableHistoryInTransactionalMode"] @@ -2116,6 +2116,14 @@ Set transaction verifier names and capabilities. VERIFIERS is a list of objects ``` +### env-whitelist {#env-whitelist} + +*blah* `` *→* `` + + +beepidy boop + + ### expect {#expect} *doc* `string` *expected* `` *actual* `` *→* `string` diff --git a/src/Pact/Interpreter.hs b/src/Pact/Interpreter.hs index 885a8ddfa..9c7d787d0 100644 --- a/src/Pact/Interpreter.hs +++ b/src/Pact/Interpreter.hs @@ -212,6 +212,7 @@ setupEvalEnv dbEnv ent mode msgData refStore gasEnv np spv pd ec = do , _eeAdvice = def , _eeInRepl = False , _eeWarnings = warnRef + , _eeCapWhitelist = mempty } where mkMsgSigs ss = M.fromList $ map toPair ss diff --git a/src/Pact/Repl.hs b/src/Pact/Repl.hs index bc9f2ed18..30fdaffa2 100644 --- a/src/Pact/Repl.hs +++ b/src/Pact/Repl.hs @@ -155,6 +155,7 @@ initEvalEnv ls = do , _eeAdvice = def , _eeInRepl = True , _eeWarnings = warnRef + , _eeCapWhitelist = mempty } where spvs mv = set spvSupport (spv mv) noSPVSupport diff --git a/src/Pact/Repl/Lib.hs b/src/Pact/Repl/Lib.hs index 8567f4883..17ac31a21 100644 --- a/src/Pact/Repl/Lib.hs +++ b/src/Pact/Repl/Lib.hs @@ -25,7 +25,7 @@ import Control.Arrow ((&&&)) import Control.Concurrent.MVar import Control.Lens import Control.Exception.Safe -import Control.Monad (foldM, forM, when) +import Control.Monad (foldM, forM, when, (>=>)) import Control.Monad.Reader import Control.Monad.State.Strict (get,put) @@ -268,6 +268,7 @@ replDefs = ("Repl", (funType tTyString [("on-chain", tTyBool)]) [LitExample "(env-simulate-onchain true)"] "Set a flag to simulate on-chain behavior that differs from the repl, in particular for observing things like errors and stack traces." + ,defZRNative "env-whitelist" envWhitelist (funType a [("blah", a)]) [] "beepidy boop" ]) where json = mkTyVar "a" [tTyInteger,tTyString,tTyTime,tTyDecimal,tTyBool, @@ -365,6 +366,26 @@ setsigs' _ [TList ts _ _] = do return $ tStr "Setting transaction signatures/caps" setsigs' i as = argsError' i as +envWhitelist :: RNativeFun LibState +envWhitelist i [TList v _ _] = do + l <- traverse enforcePactValue v + case traverse getFields l of + Just s -> do + setenv eeCapWhitelist $ M.fromList $ V.toList s + return $ tStr "Setting transaction cap whitelist" + Nothing -> evalError' i "invalid whitelist format" + where + getFields (PObject (ObjectMap o)) = do + qn <- M.lookup "callsite" o >>= preview (_PLiteral . _LString) >>= parseQual + capNames <- M.lookup "caps" o >>= preview _PList >>= traverse (preview (_PLiteral . _LString) >=> parseQual) + h <- M.lookup "pinnedHash" o >>= preview (_PLiteral . _LString) >>= either (const Nothing) Just . fromText' + let capSet = S.fromList (V.toList capNames) + mh = ModuleHash h + pure (qn, (capSet, mh)) + getFields _ = Nothing + parseQual = either (const Nothing) Just . parseQualifiedName def +envWhitelist i as = argsError i as + envVerifiers :: ZNativeFun LibState envVerifiers _ [TList ts _ _] = do vers <- forM ts $ \t -> case t of diff --git a/src/Pact/Runtime/Capabilities.hs b/src/Pact/Runtime/Capabilities.hs index 7a887f0bc..f56b891e2 100644 --- a/src/Pact/Runtime/Capabilities.hs +++ b/src/Pact/Runtime/Capabilities.hs @@ -34,10 +34,12 @@ module Pact.Runtime.Capabilities import Control.Monad import Control.Lens hiding (DefName) +import Control.Monad.Trans.Maybe import Data.Default import Data.Foldable import Data.List import Data.Text (Text) +import Data.Maybe(fromMaybe) import qualified Data.Map.Strict as M import qualified Data.Set as S @@ -47,6 +49,8 @@ import Pact.Types.Pretty import Pact.Types.Runtime import Pact.Runtime.Utils +import Debug.Trace + -- | Tie the knot with Pact.Eval by having caller supply `apply` etc type ApplyMgrFun e = Def Ref -> PactValue -> PactValue -> Eval e PactValue -- | More knot tying to on-demand install a managed cap @@ -276,16 +280,44 @@ checkSigCaps -> Eval e (M.Map PublicKeyText (S.Set UserCapability)) checkSigCaps sigs = go where - go = do + go = ifExecutionFlagSet FlagDisablePact412 legacyCheck pact412Check + legacyCheck = getAllStackCaps >>= checkSigs + pact412Check = do capsBeingEvaluated <- use evalUserCapabilitiesBeingEvaluated let eligibleCaps | null capsBeingEvaluated = getAllStackCaps | otherwise = return capsBeingEvaluated - granted <- eligibleCaps + eligibleCaps >>= checkSigs + -- Handle cap whitelisting + checkWhiteListed = fmap (fromMaybe mempty) $ runMaybeT $ do + whitelist <- view eeCapWhitelist + qn <- MaybeT findFirstUserCall + (allowSet, wmh) <- hoistMaybe $ M.lookup qn whitelist + mh <- MaybeT $ lookupModuleHash def (_qnQual qn) + guard (mh == wmh) + pure allowSet + + checkSigs granted = do autos <- use $ evalCapabilities . capAutonomous - return $ M.filter (match (S.null autos) granted) sigs + wl <- checkWhiteListed + return $ M.filter (match (S.null autos) granted wl) sigs - match allowEmpty granted sigCaps = + match allowEmpty granted whitelist sigCaps = (S.null sigCaps && allowEmpty) || - not (S.null (S.intersection granted sigCaps)) + not (S.null (S.intersection granted sigCaps)) || + (not (S.null whitelist) && all (\c -> S.member (_scName c) whitelist) sigCaps) + +findFirstUserCall :: Eval e (Maybe QualifiedName) +findFirstUserCall = use evalCallStack >>= go + where + go (sf : rest) = case sf of + StackFrame _sfn _loc (Just (fa, _)) + | Just mn <- _faModule fa -> pure $ Just (QualifiedName mn (_faName fa) def) + _ -> go rest + go [] = pure Nothing + +lookupModuleHash :: Info -> ModuleName -> Eval e (Maybe ModuleHash) +lookupModuleHash i mn = lookupModule i mn >>= \case + Just (ModuleData (MDModule mdl) _ _) -> pure $ Just $ _mHash mdl + _ -> pure Nothing diff --git a/src/Pact/Types/Purity.hs b/src/Pact/Types/Purity.hs index bd6c206a7..0af8ed40d 100644 --- a/src/Pact/Types/Purity.hs +++ b/src/Pact/Types/Purity.hs @@ -101,6 +101,7 @@ mkPureEnv holder purity readRowImpl env@EvalEnv{..} = do _eeAdvice _eeInRepl _eeWarnings + _eeCapWhitelist -- | Operationally creates the sysread-only environment. -- Phantom type and typeclass assigned in "runXXX" functions. diff --git a/src/Pact/Types/Runtime.hs b/src/Pact/Types/Runtime.hs index dbfdca106..b38d7eacd 100644 --- a/src/Pact/Types/Runtime.hs +++ b/src/Pact/Types/Runtime.hs @@ -32,7 +32,7 @@ module Pact.Types.Runtime RefStore(..),rsNatives, EvalEnv(..),eeRefStore,eeMsgSigs,eeMsgVerifiers,eeMsgBody,eeMode,eeEntity,eePactStep,eePactDbVar,eeInRepl, eePactDb,eePurity,eeHash,eeGas, eeGasEnv,eeNamespacePolicy,eeSPVSupport,eePublicData,eeExecutionConfig, - eeAdvice, eeWarnings, + eeAdvice, eeWarnings, eeCapWhitelist, toPactId, Purity(..), RefState(..),rsLoaded,rsLoadedModules,rsNamespace,rsQualifiedDeps, @@ -205,6 +205,8 @@ data ExecutionFlag | FlagDisablePact410 -- | Disable Pact 4.11 Features | FlagDisablePact411 + -- | Disable Pact 4.12 Features + | FlagDisablePact412 deriving (Eq,Ord,Show,Enum,Bounded) -- | Flag string representation @@ -294,6 +296,8 @@ data EvalEnv e = EvalEnv { , _eeInRepl :: !Bool -- | Warnings ref , _eeWarnings :: !(IORef (Set PactWarning)) + -- | Patch-related caps + , _eeCapWhitelist :: M.Map QualifiedName (Set QualifiedName, ModuleHash) } makeLenses ''EvalEnv