Check for module in call stack when enforcing module guard (#541)

src/Pact/Eval.hs

@@ -42,6 +42,7 @@ module Pact.Eval
     ,resumePact
     ,enforcePactValue,enforcePactValue'
     ,toPersistDirect
+    ,searchCallStackApps
     ) where
 
 import Bound
@@ -121,6 +122,11 @@ enforceKeySet i ksn KeySet{..} = do
 liftTerm :: Term Name -> Term Ref
 liftTerm a = TVar (Direct a) def
 
+-- | Search up through call stack apps to find the first `Just a`
+searchCallStackApps :: (FunApp -> Maybe a) -> Eval e (Maybe a)
+searchCallStackApps f = uses evalCallStack $
+  preview (traverse . sfApp . _Just . _1 . to f . _Just)
+
 -- | Eval a function by name with supplied args, and guard against recursive execution.
 evalByName :: Name -> [Term Name] -> Info -> Eval e (Term Name)
 evalByName n as i = do
@@ -142,8 +148,7 @@ evalByName n as i = do
             | (DefName _faName) == dn && Just mn == _faModule = Just ()
             | otherwise = Nothing
 
-      found <- uses evalCallStack $
-               preview (traverse . sfApp . _Just . _1 . to (sameName _dDefName _dModule) . _Just)
+      found <- searchCallStackApps $ sameName _dDefName _dModule
 
       case found of
         Just () -> evalError i $ "evalByName: loop detected: " <> pretty n

src/Pact/Native/Internal.hs

@@ -168,16 +168,29 @@ enforceGuard i g = case g of
     unless (pid == _pgPactId) $
       evalError' i $ "Pact guard failed, intended: " <> pretty _pgPactId <> ", active: " <> pretty pid
   GModule mg@ModuleGuard{..} -> do
-    m <- _mdModule <$> getModule (_faInfo i) _mgModuleName
-    case m of
-      MDModule Module{..} -> enforceModuleAdmin (_faInfo i) _mGovernance
+    md <- _mdModule <$> getModule (_faInfo i) _mgModuleName
+    case md of
+      MDModule m@Module{..} -> calledByModule m >>= \r ->
+        if r then
+          return ()
+        else
+          enforceModuleAdmin (_faInfo i) _mGovernance
       MDInterface{} -> evalError' i $ "ModuleGuard not allowed on interface: " <> pretty mg
   GUser UserGuard{..} ->
     void $ runSysOnly $ evalByName _ugPredFun [TObject _ugData def] (_faInfo i)
 
 findCallingModule :: Eval e (Maybe ModuleName)
 findCallingModule = uses evalCallStack (firstOf (traverse . sfApp . _Just . _1 . faModule . _Just))
 
+calledByModule :: Module n -> Eval e Bool
+calledByModule Module{..} =
+  searchCallStackApps forModule >>= (return . maybe False (const True))
+  where
+    forModule :: FunApp -> Maybe ()
+    forModule FunApp{..} | _faModule == Just _mName = Just ()
+                         | otherwise = Nothing
+
+
 -- | Test that first module app found in call stack is specified module,
 -- running 'onFound' if true, otherwise requesting module admin.
 guardForModuleCall :: Info -> ModuleName -> Eval e () -> Eval e ()

tests/pact/caps.repl

@@ -7,6 +7,10 @@
 
 (env-keys ["admin"])
 
+(module other GOV
+  (defcap GOV () true)
+  (defun enforce-a-guard (g) (enforce-guard g)))
+
 (module caps 'kadmin
 
   (defschema guards g:guard)
@@ -90,6 +94,10 @@
   (defun loop (x:integer)
     (enforce-guard (create-user-guard x "loop")))
 
+  (defun test-module-guard-other ()
+    (other.enforce-a-guard (get-module-guard))
+    "success")
+
 )
 
 (create-table guard-table)
@@ -203,3 +211,5 @@
 (expect-failure "shadowed cap fails" (caps-shadow.bad-shadow-granted "k1"))
 
 (expect-failure "loop in guard detected" (loop 1))
+
+(expect "" "success" (test-module-guard-other))