diff --git a/Erb/Compute.hs b/Erb/Compute.hs --- a/Erb/Compute.hs +++ b/Erb/Compute.hs @@ -29,11 +29,11 @@ import System.Environment import Data.FileCache +import Control.Lens #ifdef HRUBY import qualified Foreign.Ruby as FR import Foreign.Ruby.Safe -import Control.Lens import Data.Tuple.Strict #else @@ -66,7 +66,7 @@ showRubyError (WithOutput str _) = PrettyError $ dullred (string str) initTemplateDaemon :: RubyInterpreter -> (Preferences IO) -> MStats -> IO (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either PrettyError T.Text)) -initTemplateDaemon intr (Preferences _ modpath templatepath _ _ _ _) mvstats = do +initTemplateDaemon intr (Preferences _ modpath templatepath _ _ _ _ _) mvstats = do controlchan <- newChan templatecache <- newFileCache let returnError rs = return $ \_ _ _ -> return (S.Left (showRubyError rs)) @@ -109,7 +109,7 @@ templateDaemon intr modpath templatepath qchan mvstats filecache computeTemplate :: RubyInterpreter -> Either T.Text T.Text -> T.Text -> Container ScopeInformation -> MStats -> FileCacheR TemplateParseError [RubyStatement] -> IO TemplateAnswer -computeTemplate intr fileinfo curcontext variables mstats filecache = do +computeTemplate intr fileinfo curcontext fvariables mstats filecache = do let (filename, ufilename) = case fileinfo of Left _ -> ("inline", "inline") Right x -> (x, T.unpack x) @@ -117,6 +117,9 @@ Left rr -> return (S.Left (showRubyError rr)) Right x -> return x encapsulateError = _Left %~ TemplateParseError + variables = fvariables & traverse . scopeVariables . traverse . _1 . _1 %~ toStr + toStr (PNumber n) = PString (scientific2text n) + toStr x = x traceEventIO ("START template " ++ T.unpack filename) parsed <- case fileinfo of Right _ -> measure mstats ("parsing - " <> filename) $ lazyQuery filecache ufilename $ fmap encapsulateError (parseErbFile ufilename) diff --git a/Facter.hs b/Facter.hs --- a/Facter.hs +++ b/Facter.hs @@ -104,7 +104,7 @@ factUser :: IO [(String, String)] factUser = do - username <- getLoginName + username <- getEffectiveUserName return [("id",username)] factUName :: IO [(String, String)] diff --git a/Puppet/Daemon.hs b/Puppet/Daemon.hs --- a/Puppet/Daemon.hs +++ b/Puppet/Daemon.hs @@ -112,7 +112,18 @@ gCatalog prefs getStatements getTemplate stats hquery ndename facts = do logDebug ("Received query for node " <> ndename) traceEventIO ("START gCatalog " <> T.unpack ndename) - (stmts :!: warnings) <- measure stats ndename $ getCatalog interpretMonad getStatements getTemplate (prefs ^. prefPDB) ndename facts (prefs ^. natTypes) (prefs ^. prefExtFuncs) hquery defaultImpureMethods + (stmts :!: warnings) <- measure stats ndename $ + getCatalog interpretMonad + getStatements + getTemplate + (prefs ^. prefPDB) + ndename + facts + (prefs ^. natTypes) + (prefs ^. prefExtFuncs) + hquery + defaultImpureMethods + (prefs ^. ignoredmodules) mapM_ (\(p :!: m) -> LOG.logM loggerName p (displayS (renderCompact (ttext ndename <> ":" <+> m)) "")) warnings traceEventIO ("STOP gCatalog " <> T.unpack ndename) return stmts diff --git a/Puppet/Interpreter.hs b/Puppet/Interpreter.hs --- a/Puppet/Interpreter.hs +++ b/Puppet/Interpreter.hs @@ -6,7 +6,7 @@ import Puppet.Interpreter.Resolve import Puppet.Parser.Types import Puppet.Parser.PrettyPrinter -import Puppet.PP +import Puppet.PP hiding ((<$>)) import Puppet.NativeTypes import Prelude hiding (mapM) @@ -28,6 +28,7 @@ import Data.Foldable (toList,foldl',Foldable,foldlM) import Data.Traversable (mapM,forM) import Control.Monad.Operational +import Control.Applicative -- helpers vmapM :: (Monad m, Foldable t) => (a -> m b) -> t a -> m [b] @@ -50,10 +51,11 @@ -> 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 = do +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 + 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) @@ -112,7 +114,7 @@ -- we must define if we can override the value let canOverride = CantOverride -- TODO check inheritance foldM (addAttribute canOverride) r (itoList resprms) - fmap toList getOver >>= mapM_ keepforlater + toList <$> getOver >>= mapM_ keepforlater let expandableDefine (curstd, curdef) r = do n <- isNativeType (r ^. rid . itype) return $! if n || (r ^. rvirtuality /= Normal) @@ -171,18 +173,15 @@ Exported -> curr :!: i cure ExportedRealized -> i curr :!: i cure _ -> curr :!: cure - verified <- fmap (ifromList . map (\r -> (r ^. rid, r))) $ mapM validateNativeType (toList real) + verified <- ifromList . map (\r -> (r ^. rid, r)) <$> mapM validateNativeType (toList real) mp <- makeEdgeMap verified definedRes <- use definedResources return (verified, mp, exported, HM.elems definedRes) -dependencyErrors :: [T.Tree G.Vertex] -> (G.Vertex -> (RIdentifier, RIdentifier, [RIdentifier])) -> InterpreterMonad () -dependencyErrors _ _ = throwPosError "Undefined dependency cycle" - makeEdgeMap :: FinalCatalog -> InterpreterMonad EdgeMap makeEdgeMap ct = do -- merge the looaded classes and resources - defs' <- HM.map _rpos `fmap` use definedResources + defs' <- HM.map _rpos <$> use definedResources clss' <- use loadedClasses let defs = defs' <> classes' <> aliases' <> names' names' = HM.map _rpos ct @@ -197,51 +196,35 @@ -- Preparation step : all relations to a container become relations to -- the stuff that's contained. We build a map of resources, stored by -- container. - let containerMap :: HM.HashMap RIdentifier [RIdentifier] - !containerMap = ifromListWith (<>) $ do - r <- toList ct - let toResource ContRoot = return $ RIdentifier "class" "::" - toResource (ContClass cn) = return $ RIdentifier "class" cn - toResource (ContDefine t n _) = return $ RIdentifier t n - toResource (ContImported _) = mzero - toResource (ContImport _ _) = mzero - o <- toResource (rcurcontainer r) - return (o, [r ^. rid]) - -- This function uses the previous map in order to resolve to non - -- container resources. - resolveDestinations :: RIdentifier -> [RIdentifier] - resolveDestinations r = case containerMap ^. at r of - Just x -> concatMap resolveDestinations x - Nothing -> [r] -- step 1 - add relations that are stored in resources let reorderlink :: (RIdentifier, RIdentifier, LinkType) -> (RIdentifier, RIdentifier, LinkType) - reorderlink (s, d, RBefore) = (d, s, RRequire) - reorderlink (s, d, RNotify) = (d, s, RSubscribe) + reorderlink (s, d, RRequire) = (d, s, RBefore) + reorderlink (s, d, RSubscribe) = (d, s, RNotify) reorderlink x = x addRR curmap r = iunionWith (<>) curmap newmap where - newmap = ifromListWith (<>) $ do + -- 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) - dst <- resolveDestinations rawdst lt <- toList lts - let (nsrc, ndst, nlt) = reorderlink (r ^. rid, dst, lt) - return (r ^. rid, [LinkInformation nsrc ndst nlt (r ^. rpos)]) + 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) = do + let realign (LinkInformation s d t p) = let (ns, nd, nt) = reorderlink (s, d, t) - rs <- resolveDestinations ns - rd <- resolveDestinations nd - return (rs, [LinkInformation rs rd nt p]) - rels <- fmap (concatMap realign) (use extraRelations) + 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 = unless (defs & has (ix r)) (throwPosError msg) - errmsg = "Unknown resource" <+> pretty ri <+> "used in the following relationships:" <+> vcat prels - prels = [ pretty (li ^. linksrc) <+> "->" <+> pretty (li ^. linkdst) <+> showPPos (li ^. linkPos) | li <- lifs ] + 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 @@ -250,10 +233,22 @@ return d ds <- mapM genlnk lifs return (ri, ri, ds) - (graph, gresolver) <- fmap G.graphFromEdges' $ mapM checkResDef (itoList step2) + 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) (dependencyErrors sccs gresolver) + 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) @@ -290,7 +285,7 @@ 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) +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 @@ -324,7 +319,7 @@ 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)) + 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 @@ -339,8 +334,8 @@ -- here ! They are also turned into "normal" resources res <- ( map (rvirtuality .~ Normal) . filter ((/= fqdn) . _rnode) - ) `fmap` singleton (PDBGetResources q) - scpdesc <- ContImported `fmap` getScope + ) <$> singleton (PDBGetResources q) + scpdesc <- ContImported <$> getScope void $ enterScope SENormal scpdesc "importing" p pushScope scpdesc o <- finalize res @@ -359,7 +354,7 @@ curPos .= p resnames <- resolveExpressionStrings ern args <- vmapM resolveArgument eargs >>= fromArgumentList - fmap concat (mapM (\n -> registerResource rt n args virt p) resnames) + concat <$> mapM (\n -> registerResource rt n args virt p) resnames evaluateStatement (MainFunctionCall funcname funcargs p) = do curPos .= p vmapM resolveExpression funcargs >>= mainFunctionCall funcname @@ -372,14 +367,14 @@ curPos .= p let checkCond [] = return [] checkCond ((e :!: stmts) : xs) = do - result <- fmap pValue2Bool (resolveExpression e) + 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) = fmap (prm :!:) (resolveExpression v) + 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 @@ -411,7 +406,7 @@ 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)) +evaluateStatement r = throwError (PrettyError ("Do not know how to evaluate this statement:" pretty r)) ----------------------------------------------------------- -- Class evaluation @@ -422,7 +417,7 @@ curcont <- getCurContainer scp <- getScopeName p <- use curPos - scopeDefined <- has (ix scp) `fmap` use scopes + 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) @@ -454,7 +449,7 @@ 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 (fmap S.fst (classParams ^.. folded)) + let !classParamSet = HS.fromList (S.fst <$> classParams ^.. folded) !definedParamSet = ikeys params !unsetParams = classParamSet `HS.difference` definedParamSet loadHieraParam curprms paramname = do @@ -504,7 +499,7 @@ curcaller <- case secontext of SEParent l -> return (PString $ T.takeWhile (/=':') l) _ -> resolveVariable "module_name" - scopeAlreadyDefined <- has (ix scopename) `fmap` use scopes + scopeAlreadyDefined <- has (ix scopename) <$> use scopes let isImported = case cont of ContImported _ -> True _ -> False @@ -541,11 +536,19 @@ (x:_) -> x 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 `fmap` getScope + isImportedDefine <- isImported <$> getScope case dls of (DefineDeclaration _ defineParams stmts cp) -> do curPos .= r ^. rpos @@ -558,7 +561,10 @@ -- errors loadParameters (r ^. rattributes) defineParams cp S.Nothing curPos .= cp - res <- evaluateStatementsVector stmts + imods <- singleton (IsIgnoredModule modulename) + res <- if imods + then return mempty + else evaluateStatementsVector stmts out <- finalize (spurious ++ res) when isImportedDefine popScope popScope @@ -603,8 +609,8 @@ [] -> classname (x:_) -> x secontext = case (inh, loadedfrom) of - (S.Just x,_) -> SEChild x - (_,S.Just x) -> SEParent x + (S.Just x,_) -> SEChild (dropInitialColons x) + (_,S.Just x) -> SEParent (dropInitialColons x) _ -> SENormal void $ enterScope secontext scopedesc modulename p classresource <- if cincludetype == IncludeStandard @@ -620,7 +626,10 @@ loadVariable "name" (PString classname) loadParameters params classParams cp (S.Just classname) curPos .= cp - res <- evaluateStatementsVector stmts + imods <- singleton (IsIgnoredModule modulename) + res <- if imods + then return mempty + else evaluateStatementsVector stmts out <- finalize (classresource ++ spurious ++ inhstmts ++ res) popScope return out @@ -632,7 +641,7 @@ addRelationship :: LinkType -> PValue -> Resource -> InterpreterMonad Resource addRelationship lt (PResourceReference dt dn) r = return (r & rrelations %~ insertLt) where - insertLt = iinsertWith (<>) (RIdentifier dt dn) (mempty & contains lt .~ True) + 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) @@ -641,14 +650,14 @@ addTagResource r rv = r & rtags . contains rv .~ True addAttribute :: OverrideType -> Resource -> (T.Text, PValue) -> InterpreterMonad Resource -addAttribute _ r ("alias", v) = fmap (\rv -> r & ralias . contains rv .~ True) (resolvePValueString v) +addAttribute _ r ("alias", v) = (\rv -> r & ralias . contains rv .~ True) <$> resolvePValueString v addAttribute _ r ("audit", _) = use curPos >>= \p -> warn ("Metaparameter audit ignored at" <+> showPPos p) >> return r addAttribute _ r ("noop", _) = use curPos >>= \p -> warn ("Metaparameter noop ignored at" <+> showPPos p) >> return r addAttribute _ r ("loglevel", _) = use curPos >>= \p -> warn ("Metaparameter loglevel ignored at" <+> showPPos p) >> return r addAttribute _ r ("schedule", _) = use curPos >>= \p -> warn ("Metaparameter schedule ignored at" <+> showPPos p) >> return r addAttribute _ r ("stage", _) = use curPos >>= \p -> warn ("Metaparameter stage ignored at" <+> showPPos p) >> return r -addAttribute _ r ("tag", PArray v) = foldM (\cr cv -> fmap (addTagResource cr) (resolvePValueString cv)) r (toList v) -addAttribute _ r ("tag", v) = fmap (addTagResource r) (resolvePValueString v) +addAttribute _ r ("tag", PArray v) = foldM (\cr cv -> addTagResource cr <$> resolvePValueString cv) r (toList v) +addAttribute _ r ("tag", v) = addTagResource r <$> resolvePValueString v addAttribute _ r ("before", d) = addRelationship RBefore d r addAttribute _ r ("notify", d) = addRelationship RNotify d r addAttribute _ r ("require", d) = addRelationship RRequire d r @@ -677,15 +686,16 @@ -- 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 = getClassTags cnt - getClassTags (ContClass cn ) = allsegs cn - getClassTags (ContDefine dt _ _) = allsegs dt - getClassTags (ContRoot ) = [] - getClassTags (ContImported _ ) = [] - getClassTags (ContImport _ _ ) = [] + (!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 mempty allScope vrt defaulttags p fqdn + let baseresource = Resource (RIdentifier rt rn) (HS.singleton rn) mempty defaultRelation allScope vrt defaulttags p fqdn r <- foldM (addAttribute CantOverride) baseresource (itoList arg) let resid = RIdentifier rt rn case rt of @@ -697,8 +707,8 @@ else IncludeResource _ -> {-# SCC "rrGeneralCase" #-} use (definedResources . at resid) >>= \case - Just otheres -> throwPosError ("Resource" <+> pretty resid <+> "already defined:" <$> - pretty r <$> + Just otheres -> throwPosError ("Resource" <+> pretty resid <+> "already defined:" + pretty r pretty otheres ) Nothing -> do @@ -736,7 +746,7 @@ 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) - fmap concat (mapM genRes (itoList hs)) + concat <$> mapM genRes (itoList 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 @@ -748,7 +758,7 @@ let addTag x = scopes . ix scp . scopeExtraTags . contains x .= True mapM_ (resolvePValueString >=> addTag) args return [] -mainFunctionCall "fail" [x] = fmap (("fail:" <+>) . dullred . ttext) (resolvePValueString x) >>= throwPosError +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 @@ -765,7 +775,7 @@ 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) + unless (rs == PUndef) $ throwPosError ("This function call should return" <+> pretty PUndef <+> "and not" <+> pretty rs pretty representation) return [] -- Method stuff diff --git a/Puppet/Interpreter/IO.hs b/Puppet/Interpreter/IO.hs --- a/Puppet/Interpreter/IO.hs +++ b/Puppet/Interpreter/IO.hs @@ -82,6 +82,7 @@ GetCurrentCallStack -> (rdr ^. ioMethods . imGetCurrentCallStack) >>= runC ReadFile fls -> strFail ((rdr ^. ioMethods . imReadFile) fls) (const $ PrettyError ("No file found in " <> list (map ttext fls))) TraceEvent e -> (rdr ^. ioMethods . imTraceEvent) e >>= runC + IsIgnoredModule m -> runC (rdr ^. ignoredModules . contains m) CallLua c fname args -> (rdr ^. ioMethods . imCallLua) c fname args >>= \case Right x -> runC x Left rr -> thpe (PrettyError (string rr)) diff --git a/Puppet/Interpreter/PrettyPrinter.hs b/Puppet/Interpreter/PrettyPrinter.hs --- a/Puppet/Interpreter/PrettyPrinter.hs +++ b/Puppet/Interpreter/PrettyPrinter.hs @@ -146,4 +146,13 @@ pretty (PDBGetResourcesOfNode n q) = pf "PDBGetResourcesOfNode" [ttext n, showQuery q] pretty (ReadFile f) = pf "ReadFile" (map ttext f) pretty (TraceEvent e) = pf "TraceEvent" [string e] + pretty (IsIgnoredModule m) = pf "IsIgnoredModule" [ttext m] +instance Pretty LinkInformation where + pretty (LinkInformation lsrc ldst ltype lpos) = pretty lsrc <+> plt <+> pretty ldst <+> showPPos lpos + where + plt = case ltype of + RNotify -> "~>" + RRequire -> "<-" + RBefore -> "->" + RSubscribe -> "<~" diff --git a/Puppet/Interpreter/Pure.hs b/Puppet/Interpreter/Pure.hs --- a/Puppet/Interpreter/Pure.hs +++ b/Puppet/Interpreter/Pure.hs @@ -34,7 +34,7 @@ -- templates, and that can include only the supplied top level statements. pureReader :: HM.HashMap (TopLevelType, T.Text) Statement -- ^ A top-level statement map -> InterpreterReader Identity -pureReader sttmap = InterpreterReader baseNativeTypes getstatementdummy templatedummy dummyPuppetDB mempty "dummy" hieradummy impurePure +pureReader sttmap = InterpreterReader baseNativeTypes getstatementdummy templatedummy dummyPuppetDB mempty "dummy" hieradummy impurePure mempty where templatedummy (Right _) _ _ = return (S.Left "Can't interpret files") templatedummy (Left cnt) ctx scope = diff --git a/Puppet/Interpreter/Resolve.hs b/Puppet/Interpreter/Resolve.hs --- a/Puppet/Interpreter/Resolve.hs +++ b/Puppet/Interpreter/Resolve.hs @@ -385,6 +385,7 @@ undefEmptyString x = x resolveFunction' :: T.Text -> [PValue] -> InterpreterMonad PValue +resolveFunction' "defined" [PResourceReference "class" cn] = fmap (PBoolean . has (ix cn)) (use loadedClasses) resolveFunction' "defined" [PResourceReference rt rn] = fmap (PBoolean . has (ix (RIdentifier rt rn))) (use definedResources) resolveFunction' "defined" [ut] = do t <- resolvePValueString ut diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -166,6 +166,7 @@ , _thisNodename :: T.Text , _hieraQuery :: HieraQueryFunc m , _ioMethods :: ImpureMethods m + , _ignoredModules :: HS.HashSet T.Text -- ^ The set of modules we will not include or whatsoever. } data ImpureMethods m = ImpureMethods { _imGetCurrentCallStack :: m [String] @@ -183,6 +184,7 @@ GetNodeName :: InterpreterInstr T.Text HieraQuery :: Container T.Text -> T.Text -> HieraQueryType -> InterpreterInstr (Pair InterpreterWriter (S.Maybe PValue)) GetCurrentCallStack :: InterpreterInstr [String] + IsIgnoredModule :: T.Text -> InterpreterInstr Bool -- error ErrorThrow :: PrettyError -> InterpreterInstr a ErrorCatch :: InterpreterMonad a -> (PrettyError -> InterpreterMonad a) -> InterpreterInstr a diff --git a/Puppet/Preferences.hs b/Puppet/Preferences.hs --- a/Puppet/Preferences.hs +++ b/Puppet/Preferences.hs @@ -14,6 +14,7 @@ import qualified Data.Text as T import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS import Control.Lens data Preferences m = Preferences @@ -24,6 +25,7 @@ , _natTypes :: Container PuppetTypeMethods -- ^ The list of native types. , _prefExtFuncs :: Container ( [PValue] -> InterpreterMonad PValue ) , _hieraPath :: Maybe FilePath + , _ignoredmodules :: HS.HashSet T.Text -- ^ The set of ignored modules } makeClassy ''Preferences @@ -36,4 +38,4 @@ templatedir = basedir <> "/templates" typenames <- fmap (map takeBaseName) (getFiles (T.pack modulesdir) "lib/puppet/type" ".rb") let loadedTypes = HM.fromList (map defaulttype typenames) - return $ Preferences manifestdir modulesdir templatedir dummyPuppetDB (baseNativeTypes `HM.union` loadedTypes) (stdlibFunctions) (Just (basedir <> "/hiera.yaml")) + return $ Preferences manifestdir modulesdir templatedir dummyPuppetDB (baseNativeTypes `HM.union` loadedTypes) (stdlibFunctions) (Just (basedir <> "/hiera.yaml")) mempty diff --git a/Puppet/Stdlib.hs b/Puppet/Stdlib.hs --- a/Puppet/Stdlib.hs +++ b/Puppet/Stdlib.hs @@ -46,6 +46,7 @@ , ("has_key", hasKey) , ("lstrip", stringArrayFunction T.stripStart) , ("merge", merge) + , ("pick", pick) , ("rstrip", stringArrayFunction T.stripEnd) , singleArgument "size" size , singleArgument "str2bool" str2Bool @@ -232,6 +233,12 @@ merge [PHash a, PHash b] = return (PHash (b `HM.union` a)) merge [a,b] = throwPosError ("merge(): Expects two hashes, not" <+> pretty a <+> pretty b) merge _ = throwPosError "merge(): Expects two hashes" + +pick :: [PValue] -> InterpreterMonad PValue +pick [] = throwPosError "pick(): must receive at least one non empty value" +pick (a:as) + | a `elem` [PUndef, PString "", PString "undef"] = pick as + | otherwise = return a size :: PValue -> InterpreterMonad PValue size (PHash h) = return (_Integer # fromIntegral (HM.size h)) diff --git a/Puppet/Testing.hs b/Puppet/Testing.hs --- a/Puppet/Testing.hs +++ b/Puppet/Testing.hs @@ -89,8 +89,8 @@ let getResourceType t = c ^.. traverse . filtered (\r -> r ^. rid . itype == t && r ^. rattributes . at "ensure" /= Just "absent") users = getResourceType "user" groups = getResourceType "group" - knownUsers = HS.fromList $ map (view (rid . iname)) users ++ ["root","","syslog","mysql","puppet"] - knownGroups = HS.fromList $ map (view (rid . iname)) groups ++ ["root", "adm", "syslog", "mysql", "nagios","puppet",""] + knownUsers = HS.fromList $ map (view (rid . iname)) users ++ ["root","","syslog","mysql","puppet","vagrant","nginx","www-data","nagios", "postgres"] + knownGroups = HS.fromList $ map (view (rid . iname)) groups ++ ["root", "adm", "syslog", "mysql", "nagios","puppet","","www-data", "postgres"] checkResource lensU lensG = mapM_ (checkResource' lensU lensG) checkResource' lensU lensG res = do let d = "Resource " <> show (pretty res) <> " should have a valid " diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -1,8 +1,8 @@ --- Initial language-puppet.cabal generated by cabal init. For further +-- Initial language-puppet.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet -version: 0.13.0 +version: 0.14.0 synopsis: Tools to parse and evaluate the Puppet DSL. description: This is a set of tools that is supposed to fill all your Puppet needs : syntax checks, catalog compilation, PuppetDB queries, simulationg of complex interactions between nodes, Puppet master replacement, and more ! homepage: http://lpuppet.banquise.net/ @@ -10,7 +10,7 @@ license-file: LICENSE author: Simon Marechal maintainer: bartavelle@gmail.com --- copyright: +-- copyright: category: System build-type: Simple cabal-version: >=1.8 @@ -80,7 +80,7 @@ ghc-options: -Wall -funbox-strict-fields ghc-prof-options: -auto-all -caf-all - -- other-modules: + -- other-modules: build-depends: base >=4.6 && < 4.8 , bytestring , strict-base-types >= 0.2.2 @@ -90,7 +90,7 @@ , vector == 0.10.* , parsec == 3.1.* , mtl == 2.1.* - , lens >= 4 && < 5 + , lens >= 4 && < 4.2 , parsers == 0.11.* , ansi-wl-pprint == 0.6.* , unix >= 2.6 && < 2.8 @@ -102,7 +102,7 @@ , time == 1.4.* , filecache >= 0.2.5 && < 0.3 , regex-pcre-builtin >= 0.94.4 - , pcre-utils >= 0.1.3 && < 0.2 + , pcre-utils >= 0.1.4 && < 0.2 , process >= 1.1 && < 1.3 , iconv == 0.4.* , http-types == 0.8.* @@ -117,7 +117,7 @@ , yaml >= 0.8.8 && < 0.9 , stateWriter >= 0.2.1 && < 0.3 , split == 0.2.* - , scientific == 0.2.* + , scientific >= 0.2 && < 0.4 , operational Test-Suite test-evals diff --git a/progs/PuppetResources.hs b/progs/PuppetResources.hs --- a/progs/PuppetResources.hs +++ b/progs/PuppetResources.hs @@ -104,6 +104,7 @@ import System.IO import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS import qualified Data.Set as Set import qualified System.Log.Logger as LOG import qualified Data.ByteString.Lazy.Char8 as BSL @@ -161,10 +162,10 @@ hackish as it will generate facts from the local computer ! -} -initializedaemonWithPuppet :: LOG.Priority -> PuppetDBAPI IO -> FilePath -> Maybe FilePath -> (Facts -> Facts) -> IO (QueryFunc, MStats, MStats, MStats) -initializedaemonWithPuppet prio pdbapi puppetdir hierapath overrideFacts = do +initializedaemonWithPuppet :: LOG.Priority -> PuppetDBAPI IO -> FilePath -> Maybe FilePath -> (Facts -> Facts) -> HS.HashSet T.Text -> IO (QueryFunc, MStats, MStats, MStats) +initializedaemonWithPuppet prio pdbapi puppetdir hierapath overrideFacts ignord = do LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel prio) - q <- fmap ((prefPDB .~ pdbapi) . (hieraPath .~ hierapath)) (genPreferences puppetdir) >>= initDaemon + q <- fmap ((prefPDB .~ pdbapi) . (hieraPath .~ hierapath) . (ignoredmodules .~ ignord)) (genPreferences puppetdir) >>= initDaemon let f ndename = fmap overrideFacts (puppetDBFacts ndename pdbapi) >>= _dGetCatalog q ndename return (f, _dParserStats q, _dCatalogStats q, _dTemplateStats q) @@ -181,20 +182,22 @@ Just (PString c) -> T.putStrLn c Just x -> print x -data CommandLine = CommandLine { _pdb :: Maybe String - , _showjson :: Bool - , _showContent :: Bool - , _resourceType :: Maybe T.Text - , _resourceName :: Maybe T.Text - , _puppetdir :: FilePath - , _nodename :: Maybe String - , _pdbfile :: Maybe FilePath - , _loglevel :: LOG.Priority - , _hieraFile :: Maybe FilePath - , _factsFile :: Maybe FilePath - , _factsDef :: Maybe FilePath - , _commitDB :: Bool - , _checkExport :: Bool +data CommandLine = CommandLine { _pdb :: Maybe String + , _showjson :: Bool + , _showContent :: Bool + , _resourceType :: Maybe T.Text + , _resourceName :: Maybe T.Text + , _puppetdir :: FilePath + , _nodename :: Maybe String + , _pdbfile :: Maybe FilePath + , _loglevel :: LOG.Priority + , _hieraFile :: Maybe FilePath + , _factsFile :: Maybe FilePath + , _factsDef :: Maybe FilePath + , _commitDB :: Bool + , _checkExport :: Bool + , _testusergroups :: Bool + , _ignoredMods :: HS.HashSet T.Text } deriving Show prepareForPuppetApply :: WireCatalog -> WireCatalog @@ -243,7 +246,17 @@ <*> optional fco <*> commitdb <*> checkExported + <*> tug + <*> imods where + imods = HS.fromList . T.splitOn "," . T.pack <$> + strOption ( long "ignoremodules" + <> help "Specify a comma-separated list of modules to ignore" + <> value "" + ) + tug = switch ( long "nousergrouptest" + <> help "Disable the user and group tests" + ) commitdb = switch ( long "commitdb" <> help "Commit the computed catalogs in the puppetDB" ) @@ -337,10 +350,10 @@ run :: CommandLine -> IO () -run (CommandLine _ _ _ _ _ f Nothing _ _ _ _ _ _ _) = parseFile f >>= \case +run (CommandLine _ _ _ _ _ f Nothing _ _ _ _ _ _ _ _ _) = parseFile f >>= \case Left rr -> error ("parse error:" ++ show rr) Right s -> putDoc (vcat (map pretty (V.toList s))) -run c@(CommandLine puppeturl _ _ _ _ puppetdir (Just ndename) mpdbf prio hpath fcts fdef docommit _) = do +run c@(CommandLine puppeturl _ _ _ _ puppetdir (Just ndename) mpdbf prio hpath fcts fdef docommit _ _ _) = do let checkError r (S.Left rr) = error (show (red r <> ":" <+> getError rr)) checkError _ (S.Right x) = return x tnodename = T.pack ndename @@ -354,7 +367,7 @@ (Just p, Nothing) -> HM.union `fmap` loadFactsOverrides p (Nothing, Just p) -> (flip HM.union) `fmap` loadFactsOverrides p (Nothing, Nothing) -> return id - (queryfunc,mPStats,mCStats,mTStats) <- initializedaemonWithPuppet prio pdbapi puppetdir hpath factsOverrides + (queryfunc,mPStats,mCStats,mTStats) <- initializedaemonWithPuppet prio pdbapi puppetdir hpath factsOverrides (_ignoredMods c) printFunc <- hIsTerminalDevice stdout >>= \isterm -> return $ \x -> if isterm then putDoc x >> putStrLn "" @@ -388,15 +401,17 @@ parserShare = 100 * parsing / cataloging templateShare = 100 * templating / cataloging formatDouble = take 5 . show -- yeah, well ... + nbnodes = length topnodes worstAndSum = (_1 %~ getSum) . (_2 %~ fmap swap . getMaximum) . ifoldMap (\k (StatsPoint cnt total _ _) -> (Sum total, Maximum $ Just (total / fromIntegral cnt, k))) - putStr ("Tested " ++ show (length topnodes) ++ " nodes. ") - putStrLn (formatDouble parserShare <> "% of total CPU time spent parsing, " <> formatDouble templateShare <> "% spent computing templates") - when (prio <= LOG.INFO) $ do - putStrLn ("Slowest template: " <> T.unpack wTName <> ", taking " <> formatDouble wTMean <> "s on average") - putStrLn ("Slowest file to parse: " <> T.unpack wPName <> ", taking " <> formatDouble wPMean <> "s on average") - putStrLn ("Slowest catalog to compute: " <> T.unpack wCName <> ", taking " <> formatDouble wCMean <> "s on average") + putStr ("Tested " ++ show nbnodes ++ " nodes. ") + unless (nbnodes == 0) $ do + putStrLn (formatDouble parserShare <> "% of total CPU time spent parsing, " <> formatDouble templateShare <> "% spent computing templates") + when (prio <= LOG.INFO) $ do + putStrLn ("Slowest template: " <> T.unpack wTName <> ", taking " <> formatDouble wTMean <> "s on average") + putStrLn ("Slowest file to parse: " <> T.unpack wPName <> ", taking " <> formatDouble wPMean <> "s on average") + putStrLn ("Slowest catalog to compute: " <> T.unpack wCName <> ", taking " <> formatDouble wCMean <> "s on average") return $ if testFailures > 0 then exitFailure else exitSuccess @@ -411,7 +426,7 @@ exit computeCatalogs :: Bool -> QueryFunc -> PuppetDBAPI IO -> (Doc -> IO ()) -> CommandLine -> T.Text -> IO (Maybe (FinalCatalog, [Resource]), Maybe H.Summary) -computeCatalogs testOnly queryfunc pdbapi printFunc (CommandLine _ showjson showcontent mrt mrn puppetdir _ _ _ _ _ _ _ checkExported) tnodename = queryfunc tnodename >>= \case +computeCatalogs testOnly queryfunc pdbapi printFunc (CommandLine _ showjson showcontent mrt mrn puppetdir _ _ _ _ _ _ _ checkExported disableugtest _) tnodename = queryfunc tnodename >>= \case S.Left rr -> do if testOnly then putDoc ("Problem with" <+> ttext tnodename <+> ":" <+> getError rr mempty) @@ -442,7 +457,7 @@ _ -> do catalog <- filterCatalog rawcatalog exported <- filterCatalog rawexported - r <- testCatalog tnodename puppetdir rawcatalog (basicTest >> usersGroupsDefined) + r <- testCatalog tnodename puppetdir rawcatalog (basicTest >> unless disableugtest usersGroupsDefined) printFunc (pretty (HM.elems catalog)) unless (HM.null exported) $ do printFunc (mempty <+> dullyellow "Exported:" <+> mempty)