Fix module guard + managed caps with on-demand install (#714)

* passing pact tests

* remove dead code

* review fixes

* small perf bump

* handle arity problems

* review fix

src-ghc/Pact/Interpreter.hs

@@ -51,7 +51,6 @@ import Control.Lens
 
 import Data.Aeson
 import Data.Default
-import Data.Foldable (traverse_)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.Map.Strict as M
 import Data.Maybe
@@ -63,11 +62,9 @@ import System.Directory
 import Pact.Compile
 import Pact.Eval
 import Pact.Native (nativeDefs)
-import Pact.Native.Capabilities (resolveCapInstallMaybe)
 import qualified Pact.Persist.Pure as Pure
 import qualified Pact.Persist.SQLite as PSL
 import Pact.PersistPactDb
-import Pact.Types.Capability
 import Pact.Types.Command
 import Pact.Types.Logger
 import Pact.Types.PactValue
@@ -236,33 +233,23 @@ evalTerms interp ss input = interpreter interp start end withRollback runInput
     start :: BeginTx e
     start act = do
       txid <- evalBeginTx def
-      sigsAndInstallers <- resolveSignerCaps ss
       -- install sigs into local environment
-      local (set eeMsgSigs (toSigs sigsAndInstallers)) $ do
-        -- install any caps
-        traverse_ (traverse_ (traverse_ id)) sigsAndInstallers
-        (,txid) <$> act
+      local (set eeMsgSigs mkMsgSigs) $ (,txid) <$> act
 
     end :: CommitTx e
     end (rs,txid) = do
       logs <- evalCommitTx def
       return (rs,logs,txid)
 
-    toSigs = fmap (S.fromList . M.keys)
     runInput = case input of
       Right ts -> mapM eval ts
       Left pe -> (:[]) <$> resumePact def pe
 
+    mkMsgSigs = M.fromList $ map toPair ss
+      where
+        toPair Signer{..} = (pk,S.fromList _siCapList)
+          where
+            pk = PublicKey $ encodeUtf8 $ fromMaybe _siPubKey _siAddress
 
-{-# INLINE evalTerms #-}
 
--- | Resolves capabilities and returns a datastructure allowing for
--- installing signature caps, and then running installs inside configured environment.
-resolveSignerCaps
-  :: [Signer]
-  -> Eval e (M.Map PublicKey (M.Map UserCapability (Maybe (Eval e CapAcquireResult))))
-resolveSignerCaps ss = M.fromList <$> mapM toPair ss
-  where
-    toPair Signer{..} = (pk,) . M.fromList <$> mapM resolveCapInstallMaybe _siCapList
-      where
-        pk = PublicKey $ encodeUtf8 $ fromMaybe _siPubKey _siAddress
+{-# INLINE evalTerms #-}

src/Pact/Eval.hs

@@ -177,7 +177,7 @@ topLevelCall i name gasArgs action = call (StackFrame name i Nothing) $
   computeGas (Left (i,name)) gasArgs >>= action
 
 -- | Acquire module admin with enforce.
-acquireModuleAdmin :: Info -> ModuleName -> Governance (Def Ref) -> Eval e CapAcquireResult
+acquireModuleAdmin :: Info -> ModuleName -> Governance (Def Ref) -> Eval e CapEvalResult
 acquireModuleAdmin i modName modGov =
   acquireModuleAdminCapability modName $ enforceModuleAdmin i modGov
 

src/Pact/Native/Capabilities.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 -- |
 -- Module      :  Pact.Native.Capabilities
@@ -15,7 +16,6 @@
 module Pact.Native.Capabilities
   ( capDefs
   , evalCap
-  , resolveCapInstallMaybe
   , getMgrFun
   ) where
 
@@ -114,21 +114,21 @@ installCapability =
 
         already <- evalCap i CapManaged True cap
 
-        return $ tStr $ case already of
-          NewlyAcquired -> "Installed capability"
-          AlreadyAcquired -> "Capability already installed"
+        case already of
+          NewlyInstalled _ -> return $ tStr $ "Installed capability"
+          _ -> evalError' i $ "Unexpected result from managed install"
 
       _ -> argsError' i as
 
 
 -- | Given cap app, enforce in-module call, eval args to form capability,
 -- and attempt to acquire. Return capability if newly-granted. When
 -- 'inModule' is 'True', natives can only be invoked within module code.
-evalCap :: HasInfo i => i -> CapScope -> Bool -> App (Term Ref) -> Eval e CapAcquireResult
+evalCap :: HasInfo i => i -> CapScope -> Bool -> App (Term Ref) -> Eval e CapEvalResult
 evalCap i scope inModule a@App{..} = do
       (cap,d,prep) <- appToCap a
       when inModule $ guardForModuleCall _appInfo (_dModule d) $ return ()
-      evalUserCapability i applyMgrFun scope cap d $ do
+      evalUserCapability i capFuns scope cap d $ do
         g <- computeUserAppGas d _appInfo
         void $ evalUserAppBody d prep _appInfo g reduceBody
 
@@ -167,25 +167,21 @@ applyMgrFun mgrFunDef mgArg capArg = doApply (map fromPactValue [mgArg,capArg])
 
     appVar = TVar (Ref (TDef mgrFunDef (getInfo mgrFunDef))) def
 
+capFuns :: (ApplyMgrFun e,InstallMgd e)
+capFuns = (applyMgrFun,installSigCap)
 
--- | Resolve and typecheck sig cap, and if "managed" (ie has a manager function),
--- return install command.
-resolveCapInstallMaybe :: SigCapability -> Eval e (SigCapability,Maybe (Eval e CapAcquireResult))
-resolveCapInstallMaybe s@SigCapability{..} = go
+installSigCap :: InstallMgd e
+installSigCap SigCapability{..} cdef = do
+  r <- evalCap cdef CapManaged True $ mkApp cdef (map fromPactValue _scArgs)
+  case r of
+    NewlyInstalled mc -> return mc
+    _ -> evalError' cdef "Unexpected result from managed sig cap install"
   where
-    go = resolveCap >>= fmap (s,) . installMaybe (map fromPactValue _scArgs)
-    resolveCap = resolveRef _scName (QName _scName) >>= \m -> case m of
-      Just (Ref (TDef d@Def{..} _))
-        | _dDefType == Defcap -> return d
-      Just _ -> evalError' _scName $ "resolveCapInstallMaybe: expected defcap reference"
-      Nothing -> evalError' _scName $ "resolveCapInstallMaybe: cannot resolve " <> pretty _scName
-    installMaybe as d@Def{..} = case _dDefMeta of
-      Nothing -> return Nothing
-      Just _ -> return $ Just $ evalCap d CapManaged False (mkApp d as)
     mkApp d@Def{..} as =
       App (TVar (Ref (TDef d (getInfo d))) (getInfo d))
           (map liftTerm as) (getInfo d)
 
+
 enforceNotWithinDefcap :: HasInfo i => i -> Doc -> Eval e ()
 enforceNotWithinDefcap i msg = defcapInStack Nothing >>= \p -> when p $
   evalError' i $ msg <> " not allowed within defcap execution"

src/Pact/Repl/Lib.hs

@@ -590,11 +590,12 @@ setGasModel _ as = do
 testCapability :: ZNativeFun ReplState
 testCapability i [ (TApp app _) ] = do
   (_,d,_) <- appToCap app
-  let (scope,verb) = maybe (CapCallStack,"acquired") (const (CapManaged,"installed")) (_dDefMeta d)
+  let scope = maybe CapCallStack (const CapManaged) (_dDefMeta d)
   r <- evalCap i scope False $ app
   return . tStr $ case r of
-    AlreadyAcquired -> "Capability already " <> verb
-    NewlyAcquired -> "Capability " <> verb
+    AlreadyAcquired -> "Capability already acquired"
+    NewlyAcquired -> "Capability acquired"
+    NewlyInstalled _ -> "Capability installed"
 testCapability i as = argsError' i as
 
 -- | Modify existing env chain data with new data, replacing just those

src/Pact/Runtime/Capabilities.hs

@@ -24,15 +24,16 @@ module Pact.Runtime.Capabilities
     ,popCapStack
     ,revokeAllCapabilities
     ,capabilityAcquired
-    ,ApplyMgrFun,noopApplyMgrFun
+    ,ApplyMgrFun
+    ,InstallMgd
     ,checkSigCaps
     ) where
 
 import Control.Monad
 import Control.Lens hiding (DefName)
 import Data.Default
 import Data.Foldable
-import Data.Maybe
+import Data.List
 import qualified Data.Map.Strict as M
 import qualified Data.Set as S
 
@@ -41,12 +42,11 @@ import Pact.Types.PactValue
 import Pact.Types.Pretty
 import Pact.Types.Runtime
 
--- | Tie the knot with Pact.Eval by having caller supply `apply`
+-- | 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
+type InstallMgd e = UserCapability -> Def Ref -> Eval e (ManagedCapability UserCapability)
 
--- | Noop fun always matches/returns same
-noopApplyMgrFun :: ApplyMgrFun e
-noopApplyMgrFun _ mgd _ = return mgd
 
 -- | Check for acquired/stack (or composed therein) capability.
 capabilityAcquired :: UserCapability -> Eval e Bool
@@ -69,7 +69,7 @@ popCapStack act = do
       act c
 
 acquireModuleAdminCapability
-  :: ModuleName -> Eval e () -> Eval e CapAcquireResult
+  :: ModuleName -> Eval e () -> Eval e CapEvalResult
 acquireModuleAdminCapability mc test = do
   prev <- preuse $ evalCapabilities . capModuleAdmin . ix mc
   case prev of
@@ -86,8 +86,8 @@ acquireModuleAdminCapability mc test = do
 evalUserCapability
   :: HasInfo i
   => i
-  -> ApplyMgrFun e
-  -- ^ knot-tying continuation for running a manager fun
+  -> (ApplyMgrFun e,InstallMgd e)
+  -- ^ knot-tying continuations
   -> CapScope
   -- ^ acquiring/installing scope
   -> UserCapability
@@ -96,15 +96,14 @@ evalUserCapability
   -- ^ cap definition
   -> Eval e ()
   -- ^ test to validate install
-  -> Eval e CapAcquireResult
+  -> Eval e CapEvalResult
 evalUserCapability i af scope cap cdef test = go scope
   where
 
     go CapManaged = do
       ci <- capabilityInstalled cap
       when ci $ evalError' i $ "Duplicate install of managed capability " <> pretty cap
       push >> test >> popCapStack installManaged
-      return NewlyAcquired
     go CapCallStack = ifNotAcquired evalStack
     go CapComposed = ifNotAcquired evalComposed
 
@@ -118,23 +117,18 @@ evalUserCapability i af scope cap cdef test = go scope
 
     installManaged cs = mkMC >>= install
       where
-        install mc = evalCapabilities . capManaged %= S.insert mc
+        install mc = do
+          evalCapabilities . capManaged %= S.insert mc
+          return (NewlyInstalled mc)
         mkMC = case _dDefMeta cdef of
           Nothing -> evalError' i $ "Installing managed capability without @managed metadata"
-          Just (DMDefcap (DefcapMeta mgrFunRef argName)) -> case findArg argName of
-            Nothing ->
-              evalError' cdef $ "Invalid managed argument name: " <> pretty argName
-            Just idx -> case decomposeManaged' idx cap of
-              Nothing -> evalError' i $ "Missing argument index from capability: " <> pretty idx
-              Just (static,v) -> case mgrFunRef of
-                (TVar (Ref (TDef d di)) _) -> case _dDefType d of
-                  Defun -> return $! ManagedCapability cs static v idx argName d
-                  _ -> evalError' di $ "Capability manager ref must be defun"
-                t -> evalError' t $ "Capability manager ref must be a function"
-        findArg an = foldl' (matchArg an) Nothing (zip [0..] $ _ftArgs $ _dFunType cdef)
-        matchArg _ (Just idx) _ = Just idx
-        matchArg an Nothing (idx,Arg{..}) | _aName == an = Just idx
-                                          | otherwise = Nothing
+          Just (DMDefcap dcm@(DefcapMeta mgrFunRef argName)) -> case defCapMetaParts cap dcm cdef of
+            Left e -> evalError' cdef e
+            Right (idx,static,v) -> case mgrFunRef of
+              (TVar (Ref (TDef d di)) _) -> case _dDefType d of
+                Defun -> return $! ManagedCapability cs static v idx argName d
+                _ -> evalError' di $ "Capability manager ref must be defun"
+              t -> evalError' t $ "Capability manager ref must be a function"
 
     -- Callstack: check if managed, in which case push, otherwise
     -- push and test.
@@ -154,31 +148,60 @@ evalUserCapability i af scope cap cdef test = go scope
 
     pushSlot s = evalCapabilities . capStack %= (s:)
 
+defCapMetaParts :: UserCapability -> DefcapMeta a -> Def Ref -> Either Doc (Int, SigCapability, PactValue)
+defCapMetaParts cap (DefcapMeta _ argName) cdef = case findArg argName of
+  Nothing -> Left $ "Invalid managed argument name: " <> pretty argName
+  Just idx -> case decomposeManaged' idx cap of
+    Nothing -> Left $ "Missing argument index from capability: " <> pretty idx
+    Just (static,v) -> return (idx,static,v)
+  where
+    findArg an = findIndex ((==) an . _aName) $ _ftArgs (_dFunType cdef)
 
 checkManaged
   :: HasInfo i
   => i
-  -> ApplyMgrFun e
+  -> (ApplyMgrFun e,InstallMgd e)
   -> UserCapability
   -> Def Ref
   -> Eval e (Maybe [UserCapability])
-checkManaged i applyF cap@SigCapability{..} cdef
-  | isManaged cdef = use (evalCapabilities . capManaged) >>= go . S.toList
-  | otherwise = return Nothing
+checkManaged i (applyF,installF) cap@SigCapability{..} cdef = case _dDefMeta cdef of
+  Nothing -> return Nothing
+  Just (DMDefcap dcm) -> use (evalCapabilities . capManaged) >>= go dcm . S.toList
   where
-    go [] = evalError' i $ "Managed capability not installed: " <> pretty cap
-    go (mc@ManagedCapability{..}:mcs) = case decomposeManaged' _mcManageParamIndex cap of
-      Nothing -> go mcs
+    go dcm [] = do
+      checkSigs dcm >>= \r -> case r of
+        Nothing -> die
+        Just mc -> testMC mc die
+    go dcm (mc:mcs) = testMC mc (go dcm mcs)
+
+    die = evalError' i $ "Managed capability not installed: " <> pretty cap
+
+    testMC (mc@ManagedCapability{..}) cont = case decomposeManaged' _mcManageParamIndex cap of
+      Nothing -> cont
       Just (cap',rv)
-        | cap' /= _mcStatic -> go mcs
+        | cap' /= _mcStatic -> cont
         | otherwise -> check mc rv
 
     check mc@ManagedCapability{..} rv = do
       newMgdValue <- applyF _mcMgrFun _mcManaged rv
       evalCapabilities . capManaged %= S.insert (set mcManaged newMgdValue mc)
       return $ Just $ _csComposed _mcInstalled
 
-    isManaged Def{..} = isJust _dDefMeta
+    getStatic dcm c = view _2 <$> defCapMetaParts c dcm cdef
+
+    checkSigs dcm = case getStatic dcm cap of
+      Left e -> evalError' cdef e
+      Right capStatic -> do
+        sigCaps <- S.unions <$> view eeMsgSigs
+        foldM (matchSig dcm capStatic) Nothing sigCaps
+
+    matchSig _ _ r@Just{} _ = return r
+    matchSig dcm capStatic Nothing sigCap = case getStatic dcm sigCap of
+      Left _ -> return Nothing
+      Right sigStatic | sigStatic == capStatic -> Just <$> doMgdInstall sigCap
+                      | otherwise -> return Nothing
+
+    doMgdInstall sigCap = installF sigCap cdef
 
 
 revokeAllCapabilities :: Eval e ()

src/Pact/Types/Capability.hs

@@ -19,7 +19,7 @@
 
 module Pact.Types.Capability
   ( Capability(..)
-  , CapAcquireResult(..)
+  , CapEvalResult(..)
   , SigCapability(..)
   , UserCapability
   , ManagedCapability(..), mcInstalled, mcStatic, mcManaged, mcManageParamIndex, mcManageParamName, mcMgrFun
@@ -78,10 +78,12 @@ instance FromJSON SigCapability where
     <$> o .: "name"
     <*> o .: "args"
 
--- | Literate boolean to signal whether cap was already in scope.
-data CapAcquireResult
+-- | Various results of evaluating a capability.
+-- Note: dupe managed install is an error, thus no case here.
+data CapEvalResult
   = NewlyAcquired
   | AlreadyAcquired
+  | NewlyInstalled (ManagedCapability UserCapability)
   deriving (Eq,Show)
 
 data CapScope
@@ -102,7 +104,6 @@ data CapSlot c = CapSlot
   , _csCap :: c
   , _csComposed :: [c]
   } deriving (Eq,Show,Ord,Functor,Foldable,Traversable,Generic)
-makeLenses ''CapSlot
 instance NFData c => NFData (CapSlot c)
 
 data ManagedCapability c = ManagedCapability
@@ -132,13 +133,14 @@ decomposeManaged' :: Int -> UserCapability -> Maybe (SigCapability,PactValue)
 decomposeManaged' idx cap@SigCapability{..} = case decomposeManaged idx cap of
   Nothing -> Nothing
   Just (h,v,t) -> Just (SigCapability _scName (h ++ t),v)
+{-# INLINABLE decomposeManaged' #-}
 
 -- | Match static value to managed.
 matchManaged :: ManagedCapability c -> UserCapability -> Bool
 matchManaged ManagedCapability{..} cap@SigCapability{..} = case decomposeManaged' _mcManageParamIndex cap of
   Nothing -> False
   Just (c,_) -> c == _mcStatic
-
+{-# INLINABLE matchManaged #-}
 
 instance Eq a => Eq (ManagedCapability a) where a == b = _mcStatic a == _mcStatic b
 instance Ord a => Ord (ManagedCapability a) where a `compare` b = _mcStatic a `compare` _mcStatic b
@@ -164,3 +166,4 @@ instance NFData Capabilities
 
 makeLenses ''ManagedCapability
 makeLenses ''Capabilities
+makeLenses ''CapSlot