whitelist v1

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*&nbsp;`<a>` *&rarr;*&nbsp;`<a>`
+
+
+beepidy boop
+
+
 ### expect {#expect}
 
 *doc*&nbsp;`string` *expected*&nbsp;`<a>` *actual*&nbsp;`<a>` *&rarr;*&nbsp;`string`

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

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

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

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

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.

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