Magic caps for authorization natives

src/Pact/Eval.hs

@@ -223,21 +223,38 @@ topLevelCall i name gasArgs action = call (StackFrame name i Nothing) $
 -- | Acquire module admin with enforce.
 acquireModuleAdmin :: Info -> ModuleName -> Governance (Def Ref) -> Eval e CapEvalResult
 acquireModuleAdmin i modName modGov =
-  acquireModuleAdminCapability modName $ enforceModuleAdmin i modGov
+  acquireModuleAdminCapability modName $ enforceModuleAdmin i modName modGov
 
 
-enforceModuleAdmin :: Info -> Governance (Def Ref) -> Eval e ()
-enforceModuleAdmin i modGov =
+enforceModuleAdmin :: Info -> ModuleName -> Governance (Def Ref) -> Eval e ()
+enforceModuleAdmin i mn modGov =
     case _gGovernance modGov of
-      Left ks -> enforceKeySetName i ks
+      Left ks -> withModuleKeysetMagicCap i mn $ enforceKeySetName i ks
       Right d@Def{..} -> case _dDefType of
         Defcap -> do
           af <- prepareUserAppArgs d [] _dInfo
-          computeUserAppGas d _dInfo
-          void $ evalUserAppBody d af _dInfo reduceBody
+          ifExecutionFlagSet FlagDisablePact49 (runCapBody d af _dInfo) $ do
+            -- Properly acquire gov cap to allow scoping.
+            -- Note that nerfed manager functions mean that a gov cap with
+            -- @managed will fail, which is a good thing as management of a gov
+            -- cap is meaningless. However we should probably enforce this in
+            -- module load.
+            let cap = SigCapability (QualifiedName _dModule (asString _dDefName) i) []
+            void $ evalUserCapability i nerfedFuns CapCallStack cap d $
+                runCapBody d af i
         _ -> evalError i "enforceModuleAdmin: module governance must be defcap"
-
-
+  where
+    runCapBody d af di = do
+      computeUserAppGas d di
+      void $ evalUserAppBody d af di reduceBody
+    nerfedFuns =
+      (\_ _ _ -> evalError i "Illegal managed function application in governance defcap"
+      ,\_ _ -> evalError i "Illegal managed function install in governance defcap"
+      )
+
+withModuleKeysetMagicCap :: HasInfo i => i -> ModuleName -> Eval e a -> Eval e a
+withModuleKeysetMagicCap i mn =
+  withMagicCapability i "MODULE_KEYSET" [PLiteral (LString (asString mn))]
 
 -- | Evaluate current namespace and prepend namespace to the
 -- module name. This should be done before any lookups, as
@@ -309,7 +326,8 @@ eval' (TModule _tm@(MDModule m) bod i) =
             " overlaps with interface  " <> pretty _interfaceName
     case _gGovernance $ _mGovernance mangledM of
       -- enforce new module keyset on install
-      Left ks -> enforceKeySetName i ks
+      Left ks -> withModuleKeysetMagicCap i (_mName mangledM) $
+                 enforceKeySetName i ks
       -- governance is granted on install without testing the cap.
       -- rationale is governance might be some vote or something
       -- that doesn't exist yet. Of course, if governance is
@@ -374,8 +392,9 @@ enforceNamespaceInstall i Nothing =
   unlessExecutionFlagSet FlagDisablePact44 $
     enforceRootNamespacePolicy i
 enforceNamespaceInstall i (Just ns) =
-  unlessExecutionFlagSet FlagDisablePact44 $ do
-    enforceGuard i $ _nsUser ns
+  unlessExecutionFlagSet FlagDisablePact44 $
+    withNamespaceMagicCapability i (_nsName ns) $
+      enforceGuard i $ _nsUser ns
 
 
 checkAllowModule :: Info -> Eval e ()

src/Pact/Native.hs

@@ -93,6 +93,7 @@ import Pact.Native.SPV
 import Pact.Native.Time
 import Pact.Native.Pairing(zkDefs)
 import Pact.Parse
+import Pact.Runtime.Capabilities
 import Pact.Runtime.Utils(lookupFreeVar)
 import Pact.Types.Hash
 import Pact.Types.Names
@@ -483,14 +484,17 @@ defineNamespaceDef = setTopLevelOnly $ defGasRNative "define-namespace" defineNa
           -- if namespace is defined, enforce old guard
           nsPactValue <- toNamespacePactValue info ns
           computeGas (Right fi) (GPostRead (ReadNamespace nsPactValue))
-          enforceGuard fi oldg
+          withMagicNsCap fi name $ enforceGuard fi oldg
           computeGas' fi (GPreWrite (WriteNamespace newNsPactValue) szVer) $
             writeNamespace info name newNsPactValue
         Nothing -> do
-          enforcePolicy info name newNs
+          withMagicNsCap fi name $ enforcePolicy info name newNs
           computeGas' fi (GPreWrite (WriteNamespace newNsPactValue) szVer) $
             writeNamespace info name newNsPactValue
 
+    withMagicNsCap i (NamespaceName name) =
+      withMagicCapability i "DEFINE_NAMESPACE" [PLiteral (LString name)]
+
     enforcePolicy info nn ns = do
       policy <- view eeNamespacePolicy
       allowNs <- case policy of
@@ -556,6 +560,7 @@ namespaceDef = setTopLevelOnly $ defGasRNative "namespace" namespace
           nsPactValue <- toNamespacePactValue info n
           computeGas' fa (GPostRead (ReadNamespace nsPactValue)) $ do
             -- Old behavior enforces ns at declaration.
+            -- Old behavior does not offer magic cap.
             -- New behavior enforces at ns-related action:
             -- 1. Module install (NOT at module upgrade)
             -- 2. Interface install (Interfaces non-upgradeable)

src/Pact/Native/Keysets.hs

@@ -21,7 +21,9 @@ import Data.Text (Text)
 
 import Pact.Eval
 import Pact.Native.Internal
+import Pact.Runtime.Capabilities
 import Pact.Types.KeySet
+import Pact.Types.PactValue
 import Pact.Types.Purity
 import Pact.Types.Runtime
 import Pact.Types.Namespace
@@ -78,6 +80,10 @@ defineKeyset fi as = case as of
   [TLitString name] -> readKeySet' fi name >>= go name
   _ -> argsError fi as
   where
+
+    withDefineKeysetMagicCap ksn =
+      withMagicCapability fi "DEFINE_KEYSET" [PLiteral (LString (asString ksn))]
+
     go name ks = do
       let i = _faInfo fi
 
@@ -105,7 +111,8 @@ defineKeyset fi as = case as of
             ksn' <- ifExecutionFlagSet FlagDisablePact44
               (pure ksn)
               (do
-                enforceGuard i ug
+                withNamespaceMagicCapability i nsn $
+                    enforceGuard i ug
                 if Just nsn == _ksnNamespace ksn
                   -- if namespaces match, leave the keyset name alone
                   then pure ksn
@@ -118,9 +125,13 @@ defineKeyset fi as = case as of
         Just oldKs -> do
           computeGas (Right fi) (GPostRead (ReadKeySet ksn oldKs))
           computeGas' fi (GPreWrite (WriteKeySet ksn ks) szVer) $ do
-            runSysOnly $ enforceKeySet i (Just ksn) oldKs
+            runSysOnly $
+                withDefineKeysetMagicCap ksn $
+                     enforceKeySet i (Just ksn) oldKs
             writeRow i Write KeySets ksn ks & success "Keyset defined"
 
+
+
 keyPred :: (Integer -> Integer -> Bool) -> RNativeFun e
 keyPred predfun _ [TLitInteger count,TLitInteger matched] =
     return $ toTerm (predfun count matched)

src/Pact/Runtime/Capabilities.hs

@@ -29,6 +29,8 @@ module Pact.Runtime.Capabilities
     ,InstallMgd
     ,checkSigCaps
     ,emitCapability
+    ,withMagicCapability
+    ,withNamespaceMagicCapability
     ) where
 
 import Control.Monad
@@ -72,6 +74,32 @@ popCapStack act = do
       evalCapabilities . capStack .= cs
       act c
 
+-- | Magic capabilities allow scoping signatures for natives that enforce guards.
+--
+-- Magic caps are defined in the reserved root @pact@ pseudomodule, such that
+-- @withMagicCapability "FOO" [PLiteral (LBool True)] action@ acquires the magic
+-- capability @(pact.FOO true)@ and executes @action@ with the cap in scope.
+--
+-- Magic caps are not managed and do not allow nested acquisition.
+--
+withMagicCapability :: HasInfo i => i -> Text -> [PactValue] -> Eval e a -> Eval e a
+withMagicCapability i name args action =
+  ifExecutionFlagSet FlagDisablePact49 action $ do
+    inscope <- capabilityAcquired cap
+    when inscope $ evalError' i "Internal error, magic capability already acquired"
+    evalCapabilities . capStack %= (slot:)
+    r <- action
+    popCapStack (const (return r))
+  where
+    slot = CapSlot CapCallStack cap []
+    cap = SigCapability (QualifiedName "pact" name def) args
+
+-- | Magic capability for enforcing namespace entry.
+withNamespaceMagicCapability :: HasInfo i => i -> NamespaceName -> Eval e a -> Eval e a
+withNamespaceMagicCapability i (NamespaceName name) =
+  withMagicCapability i "NAMESPACE" [PLiteral (LString name)]
+
+
 acquireModuleAdminCapability
   :: ModuleName -> Eval e () -> Eval e CapEvalResult
 acquireModuleAdminCapability mc test = do

src/Pact/Types/Runtime.hs

@@ -198,6 +198,8 @@ data ExecutionFlag
   | FlagDisableRuntimeReturnTypeChecking
   -- | Disable Pact 4.8 Features
   | FlagDisablePact48
+  -- | Disable Pact 4.9 Features
+  | FlagDisablePact49
   deriving (Eq,Ord,Show,Enum,Bounded)
 
 -- | Flag string representation

tests/PactContinuationSpec.hs

@@ -52,6 +52,7 @@ spec = describe "pacts in dev server" $ do
   describe "testTwoPartyEscrow" $ sequential testTwoPartyEscrow
   describe "testOldNestedPacts" testOldNestedPacts
   describe "testManagedCaps" testManagedCaps
+  describe "testMagicCapRotateKeyset" testMagicCapRotateKeyset
   describe "testElideModRefEvents" testElideModRefEvents
   describe "testNestedPactContinuation" testNestedPactContinuation
   describe "testNestedPactYield" testNestedPactYield
@@ -157,6 +158,19 @@ testManagedCaps = do
           mhash]))
       managedPayFails `failsWith` (`shouldBe` "insufficient balance")
 
+testMagicCapRotateKeyset :: Spec
+testMagicCapRotateKeyset = it "exercises keyset rotates with magic cap" $ do
+    let testPath t = testDir ++ "cont-scripts/magic/" ++ t ++ ".yaml"
+        mkTest f = snd <$> mkApiReq (testPath f)
+    setup <- mkTest "setup"
+    ksSuccess <- mkTest "ks-success"
+    ksFail <- mkTest "ks-fail"
+    allResults <- runAll [setup,ksSuccess,ksFail]
+
+    runResults allResults $ do
+      setup `succeedsWith` (`shouldBe` textVal "Keyset defined")
+      ksSuccess `succeedsWith` (`shouldBe` textVal "Keyset defined")
+      ksFail `failsWith` (`shouldSatisfy` (isInfixOf "Keyset failure"))
 
 -- | allows passing e.g. "-m CrossChain" to match only `testCrossChainYield` in ghci
 _runArgs :: String -> IO ()

tests/PactTestsSpec.hs

@@ -143,6 +143,16 @@ badErrors = M.fromList
    ,"Keyset failure")
   ,(pfx "bad-term-in-list.repl"
    ,"Expected: value level form")
+  ,(pfx "bad-ns-entry-module.repl"
+   ,"Keyset failure")
+  ,(pfx "bad-ns-entry-iface.repl"
+   ,"Keyset failure")
+  ,(pfx "bad-magic-module-keyset-install.repl"
+   ,"Keyset failure (keys-all): 'ns.magic")
+  ,(pfx "bad-magic-module-keyset-upgrade.repl"
+   ,"Keyset failure (keys-all): 'ns.magic")
+  ,(pfx "bad-gov-cap-acquire.repl"
+   ,"Keyset failure (keys-all): [gov]")
 
   ]
   where

tests/cont-scripts/magic/ks-fail.yaml

@@ -0,0 +1,11 @@
+nonce: keyset-fail
+code: |-
+  (define-keyset 'ks (read-keyset 'ks))
+data:
+  ks: ["7d0c9ba189927df85c8c54f8b5c8acd76c1d27e923abbf25a957afdf25550804"]
+keyPairs:
+  - public: 7d0c9ba189927df85c8c54f8b5c8acd76c1d27e923abbf25a957afdf25550804
+    secret: 2e8c91521479537221576a7c3c80c46d0fa3fc663804117f0c7011366dec35de
+    caps:
+      - name: pact.DEFINE_KEYSET
+        args: [ "other" ]

tests/cont-scripts/magic/ks-success.yaml

@@ -0,0 +1,11 @@
+nonce: keyset-success
+code: |-
+  (define-keyset 'ks (read-keyset 'ks))
+data:
+  ks: ["7d0c9ba189927df85c8c54f8b5c8acd76c1d27e923abbf25a957afdf25550804"]
+keyPairs:
+  - public: 7d0c9ba189927df85c8c54f8b5c8acd76c1d27e923abbf25a957afdf25550804
+    secret: 2e8c91521479537221576a7c3c80c46d0fa3fc663804117f0c7011366dec35de
+    caps:
+      - name: pact.DEFINE_KEYSET
+        args: [ "ks" ]

tests/cont-scripts/magic/setup.yaml

@@ -0,0 +1,10 @@
+nonce: setup
+code: |-
+  (define-namespace 'ns (read-keyset 'ks) (read-keyset 'ks))
+  (namespace 'ns)
+  (define-keyset 'ks (read-keyset 'ks))
+data:
+  ks: ["7d0c9ba189927df85c8c54f8b5c8acd76c1d27e923abbf25a957afdf25550804"]
+keyPairs:
+  - public: 7d0c9ba189927df85c8c54f8b5c8acd76c1d27e923abbf25a957afdf25550804
+    secret: 2e8c91521479537221576a7c3c80c46d0fa3fc663804117f0c7011366dec35de

tests/pact/bad/bad-gov-cap-acquire.repl

@@ -0,0 +1,22 @@
+;; ======== test governance cap acquire ========
+
+(begin-tx)
+(env-data { 'k: ['ns], 'gov: ['gov] })
+(define-namespace 'ns (read-keyset 'k) (read-keyset 'k))
+(namespace 'ns)
+(env-keys ['ns])
+(module govcap-acquire GOV
+  (defcap GOV ()
+    (enforce-guard (read-keyset 'gov)))
+  (defcap OTHER () true))
+(commit-tx)
+
+(begin-tx)
+(env-sigs
+ [ { 'key: 'gov
+   , 'caps: [ (ns.govcap-acquire.OTHER) ] } ])
+(namespace 'ns)
+;; failure because wrong cap scoped
+(module govcap-acquire GOV
+  (defcap GOV () true))
+(rollback-tx)

tests/pact/bad/bad-magic-module-keyset-install.repl

@@ -0,0 +1,26 @@
+(begin-tx "setup magic")
+;; repl tests need pseudomodule for 'env-sigs'
+(module pact GOV
+  (defcap GOV () true)
+  (defcap NAMESPACE (name:string)
+    (enforce false "Never called"))
+  (defcap MODULE_KEYSET (name:string)
+    (enforce false "Never called"))
+)
+(env-data { 'k: [ 'magic ] })
+(define-namespace 'ns (read-keyset 'k) (read-keyset 'k))
+(env-keys ['magic])
+(namespace 'ns)
+(define-keyset "ns.magic" (read-keyset 'k))
+(commit-tx)
+
+(begin-tx)
+(namespace 'ns)
+(env-sigs
+ [ { 'key: 'magic
+   , 'caps: [ (pact.MODULE_KEYSET "other")
+            , (pact.NAMESPACE "ns") ]
+   } ] )
+;; keyset enforced on install
+(module magic-module "ns.magic"
+  (defun f () 1))

tests/pact/bad/bad-magic-module-keyset-upgrade.repl

@@ -0,0 +1,25 @@
+(begin-tx "setup magic")
+;; repl tests need pseudomodule for 'env-sigs'
+(module pact GOV
+  (defcap GOV () true)
+  (defcap MODULE_KEYSET (name:string)
+    (enforce false "Never called"))
+)
+(env-data { 'k: [ 'magic ] })
+(define-namespace 'ns (read-keyset 'k) (read-keyset 'k))
+(env-keys ['magic])
+(namespace 'ns)
+(define-keyset "ns.magic" (read-keyset 'k))
+(env-keys ['magic])
+(module magic-module "ns.magic"
+  (defun f () 1))
+(commit-tx)
+
+(begin-tx)
+(namespace 'ns)
+(env-sigs
+ [ { 'key: 'magic
+   , 'caps: [(pact.MODULE_KEYSET "other")]
+   } ] )
+(module magic-module GOV
+  (defcap GOV () true))

tests/pact/bad/bad-ns-entry-iface.repl

@@ -0,0 +1,20 @@
+(begin-tx "setup magic")
+;; repl tests need pseudomodule for 'env-sigs'
+(module pact GOV
+  (defcap GOV () true)
+  (defcap NAMESPACE (name:string)
+    (enforce false "Never called"))
+)
+(env-data { 'k: ['magic] })
+(env-keys ['magic])
+(define-namespace 'magic (read-keyset 'k) (read-keyset 'k))
+(commit-tx)
+
+(begin-tx)
+(namespace 'magic)
+(env-sigs
+ [ { 'key: 'magic
+   , 'caps: [(pact.NAMESPACE 'other)]
+   } ] )
+(interface boom
+  (defun f ()))

tests/pact/bad/bad-ns-entry-module.repl

@@ -0,0 +1,20 @@
+(begin-tx "setup magic")
+;; repl tests need pseudomodule for 'env-sigs'
+(module pact GOV
+  (defcap GOV () true)
+  (defcap NAMESPACE (name:string)
+    (enforce false "Never called"))
+)
+(env-data { 'k: ['magic] })
+(env-keys ['magic])
+(define-namespace 'magic (read-keyset 'k) (read-keyset 'k))
+(commit-tx)
+
+(begin-tx)
+(namespace 'magic)
+(env-sigs
+ [ { 'key: 'magic
+   , 'caps: [(pact.NAMESPACE 'other)]
+   } ] )
+(module boom GOV
+  (defcap GOV () true))