{-# LANGUAGE LambdaCase, RankNTypes #-} module Puppet.Interpreter where import Puppet.Interpreter.Types import Puppet.Interpreter.PrettyPrinter(containerComma) import Puppet.Interpreter.Resolve import Puppet.Parser.Types import Puppet.Lens import Puppet.Parser.PrettyPrinter import Puppet.PP hiding ((<$>)) import Puppet.NativeTypes import Prelude hiding (mapM) import Puppet.Utils import System.Log.Logger import Data.Maybe import Data.List (nubBy) import qualified Data.Text as T import Data.Tuple.Strict (Pair(..)) import qualified Data.Tuple.Strict as S import qualified Data.Either.Strict as S import qualified Data.HashSet as HS import qualified Data.HashMap.Strict as HM import Control.Monad.Error hiding (mapM,forM) import Control.Lens import qualified Data.Maybe.Strict as S import qualified Data.Graph as G import qualified Data.Tree as T import Data.Foldable (toList,foldl',Foldable,foldlM) import Data.Traversable (mapM) import Control.Monad.Operational hiding (view) import Control.Applicative -- 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 -- | This is the main function for computing catalogs. It returns the -- result of the compulation (either an error, or a tuple containing all -- the resources, dependency map, exported resources, and defined resources -- (this last one might not be up to date and is only useful for code -- coverage tests)) along with all messages that have been generated by the -- compilation process. getCatalog :: Monad m => (forall a. InterpreterReader m -> InterpreterState -> InterpreterMonad a -> m (Either PrettyError a, InterpreterState, InterpreterWriter)) -- ^ A function that will interpret the InterpreterMonad and will convert it to something else (for example, 'interpretIO') -> ( TopLevelType -> T.Text -> m (S.Either PrettyError Statement) ) -- ^ get statements function -> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> m (S.Either PrettyError T.Text)) -- ^ compute template function -> PuppetDBAPI m -> T.Text -- ^ Node name -> Facts -- ^ Facts ... -> Container PuppetTypeMethods -- ^ List of native types -> Container ( [PValue] -> InterpreterMonad PValue ) -> HieraQueryFunc m -- ^ Hiera query function -> ImpureMethods m -> HS.HashSet T.Text -- ^ The set of ignored modules -> m (Pair (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Priority Doc]) getCatalog convertMonad gtStatement gtTemplate pdbQuery ndename facts nTypes extfuncs hquery im ignord = do -- nameThread ("Catalog " <> T.unpack ndename) let rdr = InterpreterReader nTypes gtStatement gtTemplate pdbQuery extfuncs ndename hquery im ignord stt = initialState facts (output, _, warnings) <- convertMonad rdr stt (computeCatalog ndename) 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 n then return [r] else expandDefine r join <$> 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 computeCatalog :: T.Text -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource]) computeCatalog ndename = do (restop, node) <- getstt TopNode ndename 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 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 :: 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 _rpos <$> use definedResources clss' <- use loadedClasses let defs = defs' <> classes' <> aliases' <> names' names' = HM.map _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 realize :: [Resource] -> InterpreterMonad (Pair FinalCatalog FinalCatalog) realize rs = do let rma = ifromList (map (\r -> (r ^. rid, r)) rs) mutate :: Pair FinalCatalog FinalCatalog -> ResourceModifier -> InterpreterMonad (Pair FinalCatalog FinalCatalog) mutate (curmap :!: modified) rmod = do let filtrd = curmap ^.. folded . filtered fmod 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 (Pair FinalCatalog FinalCatalog) Bool -> Resource -> InterpreterMonad (Pair (Pair FinalCatalog FinalCatalog) Bool) applyModification (cma :!: cmo :!: matched) r = do nr <- mutation r let i m = m & at (nr ^. rid) ?~ nr return $ if nr /= r then i cma :!: i cmo :!: True else cma :!: cmo :!: matched (result :!: mtch) <- foldM applyModification (curmap :!: modified :!: False) filtrd when (rmod ^. rmModifierType == ModifierMustMatch && not mtch) (throwError (PrettyError ("Could not apply this resource override :" <+> pretty rmod))) 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 :: Statement -> InterpreterMonad [Resource] evaluateNode (Node _ 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 evaluateNode x = throwPosError ("Asked for a node evaluation, but got this instead:" pretty x) evaluateStatementsVector :: Foldable f => f Statement -> InterpreterMonad [Resource] evaluateStatementsVector = 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 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 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 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 <- ( map (rvirtuality .~ Normal) . filter ((/= fqdn) . _rnode) ) <$> singleton (PDBGetResources q) scpdesc <- ContImported <$> getScope void $ enterScope SENormal scpdesc "importing" p pushScope scpdesc o <- finalize res popScope return o else return [] evaluateStatement (Dependency (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 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 funcname funcargs p) = do curPos .= p vmapM resolveExpression funcargs >>= mainFunctionCall funcname evaluateStatement (VariableAssignment varname varexpr p) = do curPos .= p varval <- resolveExpression varexpr loadVariable varname varval return [] evaluateStatement (ConditionalStatement conds p) = do curPos .= p let checkCond [] = return [] checkCond ((e :!: stmts) : xs) = do result <- pValue2Bool <$> resolveExpression e if result then evaluateStatementsVector stmts else checkCond xs checkCond (toList conds) evaluateStatement (DefaultDeclaration 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 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 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 S.Nothing -> return curprms S.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 !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) let isDefault = not . flip HS.member definedParamSet . S.fst mapM_ (uncurry loadVariable) (itoList params') curPos .= defaultPos forM_ (filter isDefault (toList classParams)) $ \(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 let isImported (ContImported _) = True isImported _ = False isImportedDefine <- isImported <$> getScope case dls of (DefineDeclaration _ defineParams stmts cp) -> do 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 <- evaluateStatementsVector stmts finalize (spurious ++ res) when isImportedDefine popScope popScope return out _ -> throwPosError ("Internal error: we did not retrieve a DefineDeclaration, but had" <+> pretty dls) 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 case cls of (ClassDeclaration _ classParams inh stmts cp) -> do -- 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 <- evaluateStatementsVector stmts finalize (classresource ++ spurious ++ inhstmts ++ res) popScope return out _ -> throwPosError ("Internal error: we did not retrieve a ClassDeclaration, but had" <+> pretty cls) ----------------------------------------------------------- -- 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 _ "noop" r _ = use curPos >>= \p -> warn ("Metaparameter noop 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 "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 fname args = do p <- use curPos let representation = MainFunctionCall 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 [] -- 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 <- evaluateStatementsVector (hf ^. hfstatements) hfRestorevars saved return res results <- mapM runblock varassocs return (concat results)