{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} module Puppet.Interpreter ( getCatalog ) where import Puppet.Interpreter.PrettyPrinter (containerComma) import Puppet.Interpreter.Resolve import Puppet.Interpreter.Types import Puppet.Interpreter.IO import Puppet.Lens import Puppet.NativeTypes import Puppet.Parser.PrettyPrinter import Puppet.Parser.Types import Puppet.PP import Control.Applicative import Control.Lens import Control.Monad.Except import Control.Monad.Operational hiding (view) import qualified Data.Either.Strict as S import Data.Foldable (Foldable, foldl', foldlM, toList) import qualified Data.Graph as G import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS import Data.HashSet.Lens import Data.List (nubBy, sortBy) import Data.Maybe import qualified Data.Maybe.Strict as S import Data.Ord (comparing) import qualified Data.Text as T import Data.Traversable (mapM, for) import qualified Data.Tree as T import Data.Tuple.Strict (Pair (..)) import qualified Data.Tuple.Strict as S import qualified Data.Vector as V import Puppet.Utils import System.Log.Logger import Prelude hiding (mapM) -- helpers vmapM :: (Monad m, Foldable t) => (a -> m b) -> t a -> m [b] vmapM f = mapM f . toList getModulename :: RIdentifier -> T.Text getModulename (RIdentifier t n) = let gm x = case T.splitOn "::" x of [] -> x (y:_) -> y in case t of "class" -> gm n _ -> gm t {-| Call the operational 'interpretMonad' function to compute the catalog. Returns either an error, or a tuple containing all the resources, dependency map, exported resources, and defined resources alongside with all messages that have been generated by the compilation process. The later 'definedResources' (eg. all class declarations) are pulled out of the 'InterpreterState' and might not be up to date. There are only useful for coverage testing (checking dependencies for instance). -} getCatalog :: (Functor m, Monad m) => InterpreterReader m -- ^ The whole environment required for computing catalog. -> Nodename -> Facts -> m (Pair (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Priority Doc]) getCatalog interpretReader node facts = do (output, _, warnings) <- interpretMonad interpretReader (initialState facts) (computeCatalog node) return (strictifyEither output :!: warnings) isParent :: T.Text -> CurContainerDesc -> InterpreterMonad Bool isParent cur (ContClass possibleparent) = preuse (scopes . ix cur . scopeParent) >>= \case Nothing -> throwPosError ("Internal error: could not find scope" <+> ttext cur <+> "possible parent" <+> ttext possibleparent) Just S.Nothing -> return False Just (S.Just p) -> if p == possibleparent then return True else isParent p (ContClass possibleparent) isParent _ _ = return False finalize :: [Resource] -> InterpreterMonad [Resource] finalize rlist = do -- step 1, apply defaults scp <- getScopeName defs <- use (scopes . ix scp . scopeDefaults) let getOver = use (scopes . ix scp . scopeOverrides) -- retrieves current overrides addDefaults r = ifoldlM (addAttribute CantReplace) r thisresdefaults where thisresdefaults = defs ^. ix (r ^. rid . itype) . defValues addOverrides r = getOver >>= foldlM addOverrides' r addOverrides' r (ResRefOverride _ prms p) = do -- we used this override, so we discard it scopes . ix scp . scopeOverrides . at (r ^. rid) .= Nothing let forb = throwPosError ("Override of parameters of the following resource is forbidden in the current context:" pretty r <+> showPPos p) s <- getScope overrideType <- case r ^. rscope of [] -> forb -- we could not get the current resource context (x:_) -> if x == s then return CantOverride -- we are in the same context : can't replace, but add stuff else isParent (scopeName s) x >>= \i -> if i then return Replace -- we can override what's defined in a parent else forb ifoldlM (addAttribute overrideType) r prms withDefaults <- mapM (addOverrides >=> addDefaults) rlist -- There might be some overrides that could not be applied. The only -- valid reason is that they override something in exported resources. -- -- This will probably do something unexpected on defines, but let's do -- it that way for now. let keepforlater (ResRefOverride resid resprms ropos) = resMod %= (appended : ) where appended = ResourceModifier (resid ^. itype) ModifierMustMatch DontRealize (REqualitySearch "title" (PString (resid ^. iname))) overrider ropos overrider r = do -- we must define if we can override the value let canOverride = CantOverride -- TODO check inheritance ifoldlM (addAttribute canOverride) r resprms void $ getOver >>= mapM keepforlater let expandableDefine r = do n <- isNativeType (r ^. rid . itype) -- if we have a native type, or a virtual/exported resource it -- should not be expanded ! if n || r ^. rvirtuality /= Normal then return [r] else expandDefine r concat <$> mapM expandableDefine withDefaults popScope :: InterpreterMonad () popScope = curScope %= tail pushScope :: CurContainerDesc -> InterpreterMonad () pushScope s = curScope %= (s :) evalTopLevel :: Statement -> InterpreterMonad ([Resource], Statement) evalTopLevel (TopContainer tops s) = do pushScope ContRoot r <- vmapM evaluateStatement tops >>= finalize . concat -- popScope (nr, ns) <- evalTopLevel s popScope return (r <> nr, ns) evalTopLevel x = return ([], x) getstt :: TopLevelType -> T.Text -> InterpreterMonad ([Resource], Statement) getstt topleveltype toplevelname = -- check if this is a known class (spurious or inner class) use (nestedDeclarations . at (topleveltype, toplevelname)) >>= \case Just x -> return ([], x) -- it is known ! Nothing -> singleton (GetStatement topleveltype toplevelname) >>= evalTopLevel extractPrism :: Prism' a b -> Doc -> a -> InterpreterMonad b extractPrism p t a = case preview p a of Just b -> return b Nothing -> throwPosError ("Could not extract prism in " <> t) computeCatalog :: Nodename -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource]) computeCatalog ndename = do (restop, node') <- getstt TopNode ndename node <- extractPrism _Node' "computeCatalog" node' let finalStep [] = return [] finalStep allres = do -- collect stuff and apply thingies (realized :!: modified) <- realize allres -- we need to run it again against collected stuff, especially -- for custom types (defines) that have been realized refinalized <- finalize (toList modified) >>= finalStep -- replace the modified stuff let res = foldl' (\curm e -> curm & at (e ^. rid) ?~ e) realized refinalized return (toList res) mainstage = Resource (RIdentifier "stage" "main") mempty mempty mempty [ContRoot] Normal mempty dummypos ndename resnode <- evaluateNode node >>= finalStep . (++ (mainstage : restop)) let (real :!: exported) = foldl' classify (mempty :!: mempty) resnode -- Classify sorts resources between exported and normal ones. It -- drops virtual resources, and puts in both categories resources -- that are at the same time exported and realized. classify :: Pair (HM.HashMap RIdentifier Resource) (HM.HashMap RIdentifier Resource) -> Resource -> Pair (HM.HashMap RIdentifier Resource) (HM.HashMap RIdentifier Resource) classify (curr :!: cure) r = let i curm = curm & at (r ^. rid) ?~ r in case r ^. rvirtuality of Normal -> i curr :!: cure Exported -> curr :!: i cure ExportedRealized -> i curr :!: i cure _ -> curr :!: cure verified <- ifromList . map (\r -> (r ^. rid, r)) <$> mapM validateNativeType (toList real) mp <- makeEdgeMap verified definedRes <- use definedResources return (verified, mp, exported, HM.elems definedRes) makeEdgeMap :: FinalCatalog -> InterpreterMonad EdgeMap makeEdgeMap ct = do -- merge the looaded classes and resources defs' <- HM.map (view rpos) <$> use definedResources clss' <- use loadedClasses let defs = defs' <> classes' <> aliases' <> names' names' = HM.map (view rpos) ct -- generate fake resources for all extra aliases aliases' = ifromList $ do r <- ct ^.. traversed :: [Resource] extraAliases <- r ^.. ralias . folded . filtered (/= r ^. rid . iname) :: [T.Text] return (r ^. rid & iname .~ extraAliases, r ^. rpos) classes' = ifromList $ do (cn, _ :!: cp) <- itoList clss' return (RIdentifier "class" cn, cp) -- Preparation step : all relations to a container become relations to -- the stuff that's contained. We build a map of resources, stored by -- container. -- step 1 - add relations that are stored in resources let reorderlink :: (RIdentifier, RIdentifier, LinkType) -> (RIdentifier, RIdentifier, LinkType) reorderlink (s, d, RRequire) = (d, s, RBefore) reorderlink (s, d, RSubscribe) = (d, s, RNotify) reorderlink x = x addRR curmap r = iunionWith (<>) curmap newmap where -- compute the explicit resources, along with the container relationship newmap = ifromListWith (<>) resresources resid = r ^. rid respos = r ^. rpos resresources = do (rawdst, lts) <- itoList (r ^. rrelations) lt <- toList lts let (nsrc, ndst, nlt) = reorderlink (resid, rawdst, lt) return (nsrc, [LinkInformation nsrc ndst nlt respos]) step1 = foldl' addRR mempty ct -- step 2 - add other relations (mainly stuff made from the "->" -- operator) let realign (LinkInformation s d t p) = let (ns, nd, nt) = reorderlink (s, d, t) in (ns, [LinkInformation ns nd nt p]) rels <- map realign <$> use extraRelations let step2 = iunionWith (<>) step1 (ifromList rels) -- check that all resources are defined, and build graph let checkResDef :: (RIdentifier, [LinkInformation]) -> InterpreterMonad (RIdentifier, RIdentifier, [RIdentifier]) checkResDef (ri, lifs) = do let checkExists r msg = do let modulename = getModulename r ign <- singleton (IsIgnoredModule modulename) unless ((defs & has (ix r)) || ign) (throwPosError msg) errmsg = "Unknown resource" <+> pretty ri <+> "used in the following relationships:" <+> vcat (map pretty lifs) checkExists ri errmsg let genlnk :: LinkInformation -> InterpreterMonad RIdentifier genlnk lif = do let d = lif ^. linkdst checkExists d ("Unknown resource" <+> pretty d <+> "used in a relation at" <+> showPPos (lif ^. linkPos)) return d ds <- mapM genlnk lifs return (ri, ri, ds) edgeList <- mapM checkResDef (itoList step2) let (graph, gresolver) = G.graphFromEdges' edgeList -- now check for scc let sccs = filter ((>1) . length . T.flatten) (G.scc graph) unless (null sccs) $ do let trees = vcat (map showtree sccs) showtree = indent 2 . vcat . map (mkp . gresolver) . T.flatten mkp (a,_,links) = resdesc <+> lnks where resdesc = case ct ^. at a of Just r -> pretty r _ -> pretty a lnks = pretty links throwPosError $ "Dependency error, the following resources are strongly connected!" trees -- let edgePairs = concatMap (\(_,k,ls) -> [(k,l) | l <- ls]) edgeList -- throwPosError (vcat (map (\(RIdentifier st sn, RIdentifier dt dn) -> "\"" <> ttext st <> ttext sn <> "\" -> \"" <> ttext dt <> ttext dn <> "\"") edgePairs)) return step2 -- | This functions performs all the actions triggered by calls to the -- realize function or other collectors. It returns a pair of -- "finalcatalogs", where the first part is the new catalog, and the second -- part the map of all modified resources. The second part is needed so -- that we know for example which resources we should test for expansion -- (custom types). realize :: [Resource] -> InterpreterMonad (Pair FinalCatalog FinalCatalog) realize rs = do let -- rma is the initial map of resources, indexed by resource identifier rma = ifromList (map (\r -> (r ^. rid, r)) rs) -- mutate runs all the resource modifiers (ie. realize, overrides -- and other collectors). It stores the modified resources on the -- "right" of the resulting pair. mutate :: Pair FinalCatalog FinalCatalog -> ResourceModifier -> InterpreterMonad (Pair FinalCatalog FinalCatalog) mutate (curmap :!: modified) rmod = do let filtrd = curmap ^.. folded . filtered fmod -- all the resources that match the selector/realize criteria vcheck f r = f (r ^. rvirtuality) (isGoodvirtuality, alterVirtuality) = case rmod ^. rmType of RealizeVirtual -> (vcheck (/= Exported), \r -> return (r & rvirtuality .~ Normal)) RealizeCollected -> (vcheck (`elem` [Exported, ExportedRealized]), \r -> return (r & rvirtuality .~ ExportedRealized)) DontRealize -> (vcheck (`elem` [Normal, ExportedRealized]), return) fmod r = (r ^. rid . itype == rmod ^. rmResType) && checkSearchExpression (rmod ^. rmSearch) r && isGoodvirtuality r mutation = alterVirtuality >=> rmod ^. rmMutation applyModification :: Pair FinalCatalog FinalCatalog -> Resource -> InterpreterMonad (Pair FinalCatalog FinalCatalog) applyModification (cma :!: cmo) r = do nr <- mutation r let i m = m & at (nr ^. rid) ?~ nr return $ if nr /= r then i cma :!: i cmo else cma :!: cmo result <- foldM applyModification (curmap :!: modified) filtrd -- apply the modifiation to all the matching resources when (rmod ^. rmModifierType == ModifierMustMatch && null filtrd) (throwError (PrettyError ("Could not apply this resource override :" <+> pretty rmod <> ",no matching resource was found."))) return result equalModifier (ResourceModifier a1 b1 c1 d1 _ e1) (ResourceModifier a2 b2 c2 d2 _ e2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 result <- use resMod >>= foldM mutate (rma :!: mempty) . nubBy equalModifier resMod .= [] return result evaluateNode :: Nd -> InterpreterMonad [Resource] evaluateNode (Nd _ stmts inheritance p) = do curPos .= p pushScope ContRoot unless (S.isNothing inheritance) $ throwPosError "Node inheritance is not handled yet, and will probably never be" vmapM evaluateStatement stmts >>= finalize . concat evaluateStatementsFoldable :: Foldable f => f Statement -> InterpreterMonad [Resource] evaluateStatementsFoldable = fmap concat . vmapM evaluateStatement -- | Converts a list of pairs into a container, checking there is no -- duplicate fromArgumentList :: [Pair T.Text a] -> InterpreterMonad (Container a) fromArgumentList = foldM insertArgument mempty where insertArgument curmap (k :!: v) = case curmap ^. at k of Just _ -> throwPosError ("Parameter" <+> dullyellow (ttext k) <+> "already defined!") Nothing -> return (curmap & at k ?~ v) evaluateStatement :: Statement -> InterpreterMonad [Resource] evaluateStatement r@(ClassDeclaration (ClassDecl cname _ _ _ _)) = if "::" `T.isInfixOf` cname then nestedDeclarations . at (TopClass, cname) ?= r >> return [] else do scp <- getScopeName let rcname = if scp == "::" then cname else scp <> "::" <> cname nestedDeclarations . at (TopClass, rcname) ?= r return [] evaluateStatement r@(DefineDeclaration (DefineDec dname _ _ _)) = if "::" `T.isInfixOf` dname then nestedDeclarations . at (TopDefine, dname) ?= r >> return [] else do scp <- getScopeName if scp == "::" then nestedDeclarations . at (TopDefine, dname) ?= r >> return [] else nestedDeclarations . at (TopDefine, scp <> "::" <> dname) ?= r >> return [] evaluateStatement r@(ResourceCollection (RColl e resType searchExp mods p)) = do curPos .= p unless (fnull mods || e == Collector) (throwPosError ("It doesnt seem possible to amend attributes with an exported resource collector:" pretty r)) rsearch <- resolveSearchExpression searchExp let et = case e of Collector -> RealizeVirtual ExportedCollector -> RealizeCollected resMod %= (ResourceModifier resType ModifierCollector et rsearch return p : ) -- Now collectd from the PuppetDB ! if et == RealizeCollected then do let q = searchExpressionToPuppetDB resType rsearch fqdn <- singleton GetNodeName -- we must filter the resources that originated from this host -- here ! They are also turned into "normal" resources res <- toListOf (folded . filtered ( hasn't (rnode . only fqdn) ) . to (rvirtuality .~ Normal) ) <$> singleton (PDBGetResources q) scpdesc <- ContImported <$> getScope void $ enterScope SENormal scpdesc "importing" p pushScope scpdesc o <- finalize res popScope return o else return [] evaluateStatement (Dependency (Dep (t1 :!: n1) (t2 :!: n2) lt p)) = do curPos .= p rn1 <- map (fixResourceName t1) <$> resolveExpressionStrings n1 rn2 <- map (fixResourceName t2) <$> resolveExpressionStrings n2 extraRelations <>= [ LinkInformation (RIdentifier t1 an1) (RIdentifier t2 an2) lt p | an1 <- rn1, an2 <- rn2 ] return [] evaluateStatement (ResourceDeclaration (ResDec rt ern eargs virt p)) = do curPos .= p resnames <- resolveExpressionStrings ern args <- vmapM resolveArgument eargs >>= fromArgumentList concat <$> mapM (\n -> registerResource rt n args virt p) resnames evaluateStatement (MainFunctionCall (MFC funcname funcargs p)) = do curPos .= p vmapM resolveExpression funcargs >>= mainFunctionCall funcname evaluateStatement (VariableAssignment (VarAss varname varexpr p)) = do curPos .= p varval <- resolveExpression varexpr loadVariable varname varval return [] evaluateStatement (ConditionalStatement (CondStatement conds p)) = do curPos .= p let checkCond [] = return [] checkCond ((e :!: stmts) : xs) = do result <- pValue2Bool <$> resolveExpression e if result then evaluateStatementsFoldable stmts else checkCond xs checkCond (toList conds) evaluateStatement (DefaultDeclaration (DefaultDec resType decls p)) = do curPos .= p let resolveDefaultValue (prm :!: v) = (prm :!:) <$> resolveExpression v rdecls <- vmapM resolveDefaultValue decls >>= fromArgumentList scp <- getScopeName -- invariant that must be respected : the current scope must me create -- in "scopes", or nothing gets saved let newDefaults = ResDefaults resType scp rdecls p addDefaults x = scopes . ix scp . scopeDefaults . at resType ?= x -- default merging with parent mergedDefaults curdef = newDefaults & defValues .~ (rdecls <> (curdef ^. defValues)) preuse (scopes . ix scp . scopeDefaults . ix resType) >>= \case Nothing -> addDefaults newDefaults Just de -> if de ^. defSrcScope == scp then throwPosError ("Defaults for resource" <+> ttext resType <+> "already declared at" <+> showPPos (de ^. defPos)) else addDefaults (mergedDefaults de) return [] evaluateStatement (ResourceOverride (ResOver rt urn eargs p)) = do curPos .= p raassignements <- vmapM resolveArgument eargs >>= fromArgumentList rn <- resolveExpressionString urn scp <- getScopeName curoverrides <- use (scopes . ix scp . scopeOverrides) let rident = RIdentifier rt rn -- check that we didn't already override those values withAssignements <- case curoverrides ^. at rident of Just (ResRefOverride _ prevass prevpos) -> do let cm = prevass `HM.intersection` raassignements unless (fnull cm) (throwPosError ("The following parameters were already overriden at" <+> showPPos prevpos <+> ":" <+> containerComma cm)) return (prevass <> raassignements) Nothing -> return raassignements scopes . ix scp . scopeOverrides . at rident ?= ResRefOverride rident withAssignements p return [] evaluateStatement (SHFunctionCall (SFC c p)) = curPos .= p >> evaluateHFC c evaluateStatement r = throwError (PrettyError ("Do not know how to evaluate this statement:" pretty r)) ----------------------------------------------------------- -- Class evaluation ----------------------------------------------------------- loadVariable :: T.Text -> PValue -> InterpreterMonad () loadVariable varname varval = do curcont <- getCurContainer scp <- getScopeName p <- use curPos scopeDefined <- has (ix scp) <$> use scopes variableDefined <- preuse (scopes . ix scp . scopeVariables . ix varname) case (scopeDefined, variableDefined) of (False, _) -> throwPosError ("Internal error: trying to save a variable in unknown scope" <+> ttext scp) (_, Just (_ :!: pp :!: ctx)) -> isParent scp (curcont ^. cctype) >>= \case True -> do debug("The variable" <+> pretty (UVariableReference varname) <+> "had been overriden because of some arbitrary inheritance rule that was set up to emulate puppet behaviour. It was defined at" <+> showPPos pp ) scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype) False -> throwPosError ("Variable" <+> pretty (UVariableReference varname) <+> "already defined at" <+> showPPos pp "Context:" <+> pretty ctx "Value:" <+> pretty varval "Current scope:" <+> ttext scp ) _ -> scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype) -- | This function loads class and define parameters into scope. It checks -- that all mandatory parameters are set, that no extra parameter is -- declared. -- -- It is able to fill unset parameters with values from Hiera (for classes -- only) or default values. loadParameters :: Foldable f => Container PValue -> f (Pair T.Text (S.Maybe Expression)) -> PPosition -> S.Maybe T.Text -> InterpreterMonad () loadParameters params classParams defaultPos wHiera = do params' <- case wHiera of S.Just classname -> do -- pass 1 : with classes, we retrieve the parameters that have no default values and -- that are not set, to try to get them with Hiera let !classParamSet = HS.fromList (S.fst <$> classParams ^.. folded) !definedParamSet = ikeys params !unsetParams = classParamSet `HS.difference` definedParamSet loadHieraParam curprms paramname = do v <- runHiera (classname <> "::" <> paramname) Priority case v of Nothing -> return curprms Just vl -> return (curprms & at paramname ?~ vl) foldM loadHieraParam params (toList unsetParams) S.Nothing -> return params -- pass 2 : we check that everything is right let classParamSet = HS.fromList (map S.fst (toList classParams)) mandatoryParamSet = HS.fromList (map S.fst (classParams ^.. folded . filtered (S.isNothing . S.snd))) definedParamSet = ikeys params' unsetParams = mandatoryParamSet `HS.difference` definedParamSet defaultParams = setOf (folded . _1) classParams undefParamsWdefs = ikeys (HM.filter (== PUndef) params') `HS.intersection` defaultParams spuriousParams = definedParamSet `HS.difference` classParamSet mclassdesc = S.maybe mempty ((\x -> mempty <+> "when including class" <+> x) . ttext) wHiera unless (fnull unsetParams) $ throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ttext $ toList unsetParams) <> mclassdesc) unless (fnull spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ttext) $ toList spuriousParams) <> mclassdesc) -- a default can override an undefined value let isDefault (k :!: _) = not (k `HS.member` definedParamSet) || k `HS.member` undefParamsWdefs defaultPairs = filter isDefault (toList classParams) -- we load all parameters that are set, except thos that are set as -- undefined and have a default value itraverse_ loadVariable (HM.filterWithKey (\k _ -> not (k `HS.member` undefParamsWdefs)) params' ) curPos .= defaultPos forM_ defaultPairs $ \(k :!: v) -> do rv <- case v of S.Nothing -> throwPosError "Internal error: invalid invariant at loadParameters" S.Just e -> resolveExpression e loadVariable k rv data ScopeEnteringContext = SENormal | SEChild !T.Text -- ^ We enter the scope as the child of another class | SEParent !T.Text -- ^ We enter the scope as the parent of another class -- | Enters a new scope, checks it is not already defined, and inherits the -- defaults from the current scope -- -- Inheriting the defaults is necessary for non native types, because they -- will be expanded in "finalize", so if this was not done, we would be -- expanding the defines without the defaults applied enterScope :: ScopeEnteringContext -> CurContainerDesc -> T.Text -> PPosition -> InterpreterMonad T.Text enterScope secontext cont modulename p = do let scopename = scopeName cont -- This is a special hack for inheritance, because at this time we -- have not properly stacked the scopes. curcaller <- case secontext of SEParent l -> return (PString $ T.takeWhile (/=':') l) _ -> resolveVariable "module_name" scopeAlreadyDefined <- has (ix scopename) <$> use scopes let isImported = case cont of ContImported _ -> True _ -> False -- it is OK to reuse a scope related to imported stuff unless (scopeAlreadyDefined && isImported) $ do when scopeAlreadyDefined (throwPosError ("Internal error: scope" <+> brackets (ttext scopename) <+> "already defined when loading scope for" <+> pretty cont)) scp <- getScopeName -- TODO fill tags basescope <- case secontext of SEChild prt -> do parentscope <- use (scopes . at prt) when (isNothing parentscope) (throwPosError ("Internal error: could not find parent scope" <+> ttext prt)) let Just psc = parentscope return (psc & scopeParent .~ S.Just prt) _ -> do curdefs <- use (scopes . ix scp . scopeDefaults) return $ ScopeInformation mempty curdefs mempty (CurContainer cont mempty) mempty S.Nothing scopes . at scopename ?= basescope scopes . ix scopename . scopeVariables . at "caller_module_name" ?= (curcaller :!: p :!: cont) scopes . ix "::" . scopeVariables . at "calling_module" ?= (curcaller :!: p :!: cont) scopes . ix scopename . scopeVariables . at "module_name" ?= (PString modulename :!: p :!: cont) debug ("enterScope, scopename=" <> ttext scopename <+> "caller_module_name=" <> pretty curcaller <+> "module_name=" <> ttext modulename) return scopename dropInitialColons :: T.Text -> T.Text dropInitialColons t = fromMaybe t (T.stripPrefix "::" t) expandDefine :: Resource -> InterpreterMonad [Resource] expandDefine r = do let deftype = dropInitialColons (r ^. rid . itype) defname = r ^. rid . iname modulename = getModulename (r ^. rid) let curContType = ContDefine deftype defname (r ^. rpos) p <- use curPos -- we add the relations of this define to the global list of relations -- before dropping it, so that they are stored for the final -- relationship resolving let extr = do (dstid, linkset) <- itoList (r ^. rrelations) link <- toList linkset return (LinkInformation (r ^. rid) dstid link p) extraRelations <>= extr void $ enterScope SENormal curContType modulename p (spurious, dls') <- getstt TopDefine deftype DefineDec _ defineParams stmts cp <- extractPrism _DefineDeclaration' "expandDefine" dls' let isImported (ContImported _) = True isImported _ = False isImportedDefine <- isImported <$> getScope curPos .= r ^. rpos curscp <- getScope when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp )) pushScope curContType imods <- singleton (IsIgnoredModule modulename) out <- if imods then return mempty else do loadVariable "title" (PString defname) loadVariable "name" (PString defname) -- not done through loadvariable because of override -- errors loadParameters (r ^. rattributes) defineParams cp S.Nothing curPos .= cp res <- evaluateStatementsFoldable stmts finalize (spurious ++ res) when isImportedDefine popScope popScope return out loadClass :: T.Text -> S.Maybe T.Text -- ^ Set if this is an inheritance load, so that we can set calling module properly -> Container PValue -> ClassIncludeType -> InterpreterMonad [Resource] loadClass rclassname loadedfrom params cincludetype = do let classname = dropInitialColons rclassname ndn <- singleton GetNodeName singleton (TraceEvent ('[' : T.unpack ndn ++ "] loadClass " ++ T.unpack classname)) p <- use curPos -- check if the class has already been loaded -- http://docs.puppetlabs.com/puppet/3/reference/lang_classes.html#using-resource-like-declarations use (loadedClasses . at classname) >>= \case Just (prv :!: pp) -> do when ( (cincludetype == IncludeResource) || (prv == IncludeResource) ) (throwPosError ("Can't include class" <+> ttext classname <+> "twice when using the resource-like syntax (first occurence at" <+> showPPos pp <> ")")) return [] -- already loaded, go on Nothing -> do loadedClasses . at classname ?= (cincludetype :!: p) -- load the actual class, note we are not changing the current position -- right now (spurious, cls') <- getstt TopClass classname ClassDecl _ classParams inh stmts cp <- extractPrism _ClassDeclaration' "loadClass" cls' -- check if we need to define a resource representing the class -- This will be the case for the first standard include inhstmts <- case inh of S.Nothing -> return [] S.Just ihname -> loadClass ihname (S.Just classname) mempty IncludeStandard let !scopedesc = ContClass classname modulename = getModulename (RIdentifier "class" classname) secontext = case (inh, loadedfrom) of (S.Just x,_) -> SEChild (dropInitialColons x) (_,S.Just x) -> SEParent (dropInitialColons x) _ -> SENormal void $ enterScope secontext scopedesc modulename p classresource <- if cincludetype == IncludeStandard then do scp <- use curScope fqdn <- singleton GetNodeName return [Resource (RIdentifier "class" classname) (HS.singleton classname) mempty mempty scp Normal mempty p fqdn] else return [] pushScope scopedesc imods <- singleton (IsIgnoredModule modulename) out <- if imods then return mempty else do loadVariable "title" (PString classname) loadVariable "name" (PString classname) loadParameters params classParams cp (S.Just classname) curPos .= cp res <- evaluateStatementsFoldable stmts finalize (classresource ++ spurious ++ inhstmts ++ res) popScope return out ----------------------------------------------------------- -- Resource stuff ----------------------------------------------------------- addRelationship :: LinkType -> PValue -> Resource -> InterpreterMonad Resource addRelationship lt (PResourceReference dt dn) r = return (r & rrelations %~ insertLt) where insertLt = iinsertWith (<>) (RIdentifier dt dn) (HS.singleton lt) addRelationship lt (PArray vals) r = foldlM (flip (addRelationship lt)) r vals addRelationship _ PUndef r = return r addRelationship _ notrr _ = throwPosError ("Expected a resource reference, not:" <+> pretty notrr) addTagResource :: Resource -> T.Text -> Resource addTagResource r rv = r & rtags . contains rv .~ True addAttribute :: OverrideType -> T.Text -> Resource -> PValue -> InterpreterMonad Resource addAttribute _ "alias" r v = (\rv -> r & ralias . contains rv .~ True) <$> resolvePValueString v addAttribute _ "audit" r _ = use curPos >>= \p -> warn ("Metaparameter audit ignored at" <+> showPPos p) >> return r addAttribute _ "loglevel" r _ = use curPos >>= \p -> warn ("Metaparameter loglevel ignored at" <+> showPPos p) >> return r addAttribute _ "schedule" r _ = use curPos >>= \p -> warn ("Metaparameter schedule ignored at" <+> showPPos p) >> return r addAttribute _ "stage" r _ = use curPos >>= \p -> warn ("Metaparameter stage ignored at" <+> showPPos p) >> return r addAttribute _ "tag" r (PArray v) = foldM (\cr cv -> addTagResource cr <$> resolvePValueString cv) r (toList v) addAttribute _ "tag" r v = addTagResource r <$> resolvePValueString v addAttribute _ "before" r d = addRelationship RBefore d r addAttribute _ "notify" r d = addRelationship RNotify d r addAttribute _ "require" r d = addRelationship RRequire d r addAttribute _ "subscribe" r d = addRelationship RSubscribe d r addAttribute b t r v = case (r ^. rattributes . at t, b) of (_, Replace) -> return (r & rattributes . at t ?~ v) (Nothing, _) -> return (r & rattributes . at t ?~ v) (_, CantReplace) -> return r _ -> do -- we must check if the resource scope is -- a parent of the current scope curscope <- getScopeName i <- isParent curscope (rcurcontainer r) if i then return (r & rattributes . at t ?~ v) else throwPosError ("Attribute" <+> dullmagenta (ttext t) <+> "defined multiple times for" <+> pretty (r ^. rid) <+> showPPos (r ^. rpos)) registerResource :: T.Text -> T.Text -> Container PValue -> Virtuality -> PPosition -> InterpreterMonad [Resource] registerResource "class" _ _ Virtual p = curPos .= p >> throwPosError "Cannot declare a virtual class (or perhaps you can, but I do not know what this means)" registerResource "class" _ _ Exported p = curPos .= p >> throwPosError "Cannot declare an exported class (or perhaps you can, but I do not know what this means)" registerResource rt rn arg vrt p = do curPos .= p CurContainer cnt tgs <- getCurContainer -- default tags -- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#automatic-tagging -- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#containment let !defaulttags = {-# SCC "rrGetTags" #-} HS.fromList (rt : classtags) <> tgs allsegs x = x : T.splitOn "::" x (!classtags, !defaultLink) = getClassTags cnt getClassTags (ContClass cn ) = (allsegs cn,RIdentifier "class" cn) getClassTags (ContDefine dt dn _) = (allsegs dt,RIdentifier dt dn) getClassTags (ContRoot ) = ([],RIdentifier "class" "::") getClassTags (ContImported _ ) = ([],RIdentifier "class" "::") getClassTags (ContImport _ _ ) = ([],RIdentifier "class" "::") defaultRelation = HM.singleton defaultLink (HS.singleton RRequire) allScope <- use curScope fqdn <- singleton GetNodeName let baseresource = Resource (RIdentifier rt rn) (HS.singleton rn) mempty defaultRelation allScope vrt defaulttags p fqdn r <- ifoldlM (addAttribute CantOverride) baseresource arg let resid = RIdentifier rt rn case rt of "class" -> {-# SCC "rrClass" #-} do definedResources . at resid ?= r let attrs = r ^. rattributes fmap (r:) $ loadClass rn S.Nothing attrs $ if HM.null attrs then IncludeStandard else IncludeResource _ -> {-# SCC "rrGeneralCase" #-} use (definedResources . at resid) >>= \case Just otheres -> throwPosError ("Resource" <+> pretty resid <+> "already defined:" pretty r pretty otheres ) Nothing -> do definedResources . at resid ?= r return [r] -- A helper function for the various loggers logWithModifier :: Priority -> (Doc -> Doc) -> [PValue] -> InterpreterMonad [Resource] logWithModifier prio m [t] = do p <- use curPos rt <- resolvePValueString t logWriter prio (m (ttext rt) <+> showPPos p) return [] logWithModifier _ _ _ = throwPosError "This function takes a single argument" -- functions : this can't really be exported as it uses a lot of stuff from -- this module ... mainFunctionCall :: T.Text -> [PValue] -> InterpreterMonad [Resource] mainFunctionCall "showscope" _ = use curScope >>= warn . pretty >> return [] -- The logging functions mainFunctionCall "alert" a = logWithModifier ALERT red a mainFunctionCall "crit" a = logWithModifier CRITICAL red a mainFunctionCall "debug" a = logWithModifier DEBUG dullwhite a mainFunctionCall "emerg" a = logWithModifier EMERGENCY red a mainFunctionCall "err" a = logWithModifier ERROR dullred a mainFunctionCall "info" a = logWithModifier INFO green a mainFunctionCall "notice" a = logWithModifier NOTICE white a mainFunctionCall "warning" a = logWithModifier WARNING dullyellow a mainFunctionCall "include" includes = concat <$> mapM doInclude includes where doInclude e = do classname <- resolvePValueString e loadClass classname S.Nothing mempty IncludeStandard mainFunctionCall "create_resources" [rtype, hs] = mainFunctionCall "create_resources" [rtype, hs, PHash mempty] mainFunctionCall "create_resources" [PString rtype, PHash hs, PHash defs] = do p <- use curPos let genRes rname (PHash rargs) = registerResource rtype rname (rargs <> defs) Normal p genRes rname x = throwPosError ("create_resource(): the value corresponding to key" <+> ttext rname <+> "should be a hash, not" <+> pretty x) concat . HM.elems <$> itraverse genRes hs mainFunctionCall "create_resources" args = throwPosError ("create_resource(): expects between two and three arguments, of type [string,hash,hash], and not:" <+> pretty args) mainFunctionCall "ensure_packages" args = ensurePackages args mainFunctionCall "ensure_resource" args = ensureResource args mainFunctionCall "realize" args = do p <- use curPos let realiz (PResourceReference rt rn) = resMod %= (ResourceModifier rt ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) return p : ) realiz x = throwPosError ("realize(): all arguments must be resource references, not" <+> pretty x) mapM_ realiz args return [] mainFunctionCall "tag" args = do scp <- getScopeName let addTag x = scopes . ix scp . scopeExtraTags . contains x .= True mapM_ (resolvePValueString >=> addTag) args return [] mainFunctionCall "fail" [x] = ("fail:" <+>) . dullred . ttext <$> resolvePValueString x >>= throwPosError mainFunctionCall "fail" _ = throwPosError "fail(): This function takes a single argument" mainFunctionCall "hiera_include" [x] = do ndname <- resolvePValueString x classes <- toListOf (traverse . _PArray . traverse) <$> runHiera ndname ArrayMerge p <- use curPos curPos . _1 . lSourceName <>= " [hiera_include call]" o <- mainFunctionCall "include" classes curPos .= p return o mainFunctionCall "hiera_include" _ = throwPosError "hiera_include(): This function takes a single argument" mainFunctionCall "dumpinfos" _ = do let prntline = logWriter ALERT indentln = (<>) " " prntline "Scope stack :" scps <- use curScope mapM_ (prntline . indentln . pretty) scps prntline "Variables in local scope :" scp <- getScopeName vars <- use (scopes . ix scp . scopeVariables) forM_ (sortBy (comparing fst) (itoList vars)) $ \(idx, pv :!: _ :!: _) -> prntline $ indentln $ ttext idx <> " -> " <> pretty pv return [] mainFunctionCall fname args = do p <- use curPos let representation = MainFunctionCall (MFC fname mempty p) rs <- singleton (ExternalFunction fname args) unless (rs == PUndef) $ throwPosError ("This function call should return" <+> pretty PUndef <+> "and not" <+> pretty rs pretty representation) return [] ensurePackages :: [PValue] -> InterpreterMonad [Resource] ensurePackages [packages] = ensurePackages [packages, PHash mempty] ensurePackages [PString p, x] = ensurePackages [ PArray (V.singleton (PString p)), x ] ensurePackages [PArray packages, PHash defaults] = do checkStrict "The use of the 'ensure_packages' function is a code smell." "The 'ensure_packages' function is not allowed in strict mode." concat <$> for packages (resolvePValueString >=> ensureResource' "package" (HM.singleton "ensure" "present" <> defaults)) ensurePackages [PArray _,_] = throwPosError "ensure_packages(): the second argument must be a hash." ensurePackages [_,_] = throwPosError "ensure_packages(): the first argument must be a string or an array of strings." ensurePackages _ = throwPosError "ensure_packages(): requires one or two arguments." ensureResource :: [PValue] -> InterpreterMonad [Resource] ensureResource [PString tp, PString ttl, PHash params] = do checkStrict "The use of the 'ensure_resource' function is a code smell." "The 'ensure_resource' function is not allowed in strict mode." ensureResource' tp params ttl ensureResource [tp,ttl] = ensureResource [tp,ttl,PHash mempty] ensureResource [_, PString _, PHash _] = throwPosError "ensureResource(): The first argument must be a string." ensureResource [PString _, _, PHash _] = throwPosError "ensureResource(): The second argument must be a string." ensureResource [PString _, PString _, _] = throwPosError "ensureResource(): The thrid argument must be a hash." ensureResource _ = throwPosError "ensureResource(): expects 2 or 3 arguments." ensureResource' :: T.Text -> HM.HashMap T.Text PValue -> T.Text -> InterpreterMonad [Resource] ensureResource' tp params ttl = do def <- has (ix (RIdentifier tp ttl)) <$> use definedResources if def then return [] else use curPos >>= registerResource tp ttl params Normal -- Method stuff evaluateHFC :: HFunctionCall -> InterpreterMonad [Resource] evaluateHFC hf = do varassocs <- hfGenerateAssociations hf let runblock :: [(T.Text, PValue)] -> InterpreterMonad [Resource] runblock assocs = do saved <- hfSetvars assocs res <- evaluateStatementsFoldable (hf ^. hfstatements) hfRestorevars saved return res results <- mapM runblock varassocs return (concat results)