add whitelist

docs/en/pact-functions.md

@@ -2146,14 +2146,6 @@ 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`

pact.cabal

@@ -253,6 +253,7 @@ library
     , statistics >=0.13.3
     , text >=2
     , time
+    , transformers >= 0.5.2.0 && < 0.7
     , trifecta >=2.1.1.1
     , unordered-containers >=0.2.19
     , utf8-string >=1.0.1.1
@@ -327,7 +328,6 @@ library
       , sbv >=9.0
       , semigroupoids >=5.0
       , servant-server
-      , transformers >= 0.5.2.0 && < 0.7
       , wai-cors
       , warp
     if !os(windows)

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,7 +268,6 @@ 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,
@@ -366,25 +365,6 @@ 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

src/Pact/Runtime/Capabilities.hs

@@ -42,14 +42,14 @@ import Data.Text (Text)
 import Data.Maybe(fromMaybe)
 import qualified Data.Map.Strict as M
 import qualified Data.Set as S
+import qualified Data.Text as T
 
 import Pact.Types.Capability
 import Pact.Types.PactValue
 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
@@ -290,7 +290,7 @@ checkSigCaps sigs = go
           | otherwise = return capsBeingEvaluated
       eligibleCaps >>= checkSigs
     -- Handle cap whitelisting
-    checkWhiteListed = fmap (fromMaybe mempty) $ runMaybeT $ do
+    checkWhiteListed = fmap (fromMaybe $ \_ _ -> False) $ runMaybeT $ do
       whitelist <- view eeCapWhitelist
       qn <- MaybeT findFirstUserCall
       (allowSet, wmh) <- hoistMaybe $ M.lookup qn whitelist
@@ -303,10 +303,10 @@ checkSigCaps sigs = go
       wl <- checkWhiteListed
       return $ M.filter (match (S.null autos) granted wl) sigs
 
-    match allowEmpty granted capsDonatingSigs sigCaps  =
+    match allowEmpty granted handleWL sigCaps  =
       (S.null sigCaps && allowEmpty) ||
       not (S.null (S.intersection granted sigCaps)) ||
-      (not (S.null (S.intersection capsDonatingSigs (S.map _scName sigCaps))))
+      handleWL granted sigCaps
 
 findFirstUserCall :: Eval e (Maybe QualifiedName)
 findFirstUserCall = use evalCallStack >>= go

src/Pact/Types/Runtime.hs

@@ -254,6 +254,8 @@ instance J.Encode ExecutionConfig where
 mkExecutionConfig :: [ExecutionFlag] -> ExecutionConfig
 mkExecutionConfig = ExecutionConfig . S.fromList
 
+type CapWhitelist = Set SigCapability -> Set SigCapability -> Bool
+
 -- | Interpreter reader environment, parameterized over back-end MVar state type.
 data EvalEnv e = EvalEnv {
       -- | Environment references.
@@ -297,7 +299,7 @@ data EvalEnv e = EvalEnv {
       -- | Warnings ref
     , _eeWarnings :: !(IORef (Set PactWarning))
       -- | Patch-related caps
-    , _eeCapWhitelist :: M.Map QualifiedName (Set QualifiedName, ModuleHash)
+    , _eeCapWhitelist :: M.Map QualifiedName (CapWhitelist, ModuleHash)
     }
 makeLenses ''EvalEnv