From 3e30bb87ae3b88b18eeeb709fa382608eb1c7057 Mon Sep 17 00:00:00 2001
From: Stuart Popejoy <slpopejoy@users.noreply.github.com>
Date: Fri, 7 Jun 2019 13:55:30 -0400
Subject: [PATCH] Check for module in call stack when enforcing module guard
 (#541)

---
 src/Pact/Eval.hs            |  9 +++++++--
 src/Pact/Native/Internal.hs | 19 ++++++++++++++++---
 tests/pact/caps.repl        | 10 ++++++++++
 3 files changed, 33 insertions(+), 5 deletions(-)

diff --git a/src/Pact/Eval.hs b/src/Pact/Eval.hs
index a90502bac..ce625fda5 100644
--- a/src/Pact/Eval.hs
+++ b/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
diff --git a/src/Pact/Native/Internal.hs b/src/Pact/Native/Internal.hs
index 8dfa14181..5713bc0ba 100644
--- a/src/Pact/Native/Internal.hs
+++ b/src/Pact/Native/Internal.hs
@@ -168,9 +168,13 @@ 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)
@@ -178,6 +182,15 @@ enforceGuard i g = case g of
 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 ()
diff --git a/tests/pact/caps.repl b/tests/pact/caps.repl
index 575e69230..9f5fe76c1 100644
--- a/tests/pact/caps.repl
+++ b/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))