language-puppet 0.13.0 → 0.14.0
raw patch · 14 files changed
+177/−116 lines, 14 filesdep ~lensdep ~pcre-utilsdep ~scientific
Dependency ranges changed: lens, pcre-utils, scientific
Files
- Erb/Compute.hs +6/−3
- Facter.hs +1/−1
- Puppet/Daemon.hs +12/−1
- Puppet/Interpreter.hs +82/−72
- Puppet/Interpreter/IO.hs +1/−0
- Puppet/Interpreter/PrettyPrinter.hs +9/−0
- Puppet/Interpreter/Pure.hs +1/−1
- Puppet/Interpreter/Resolve.hs +1/−0
- Puppet/Interpreter/Types.hs +2/−0
- Puppet/Preferences.hs +3/−1
- Puppet/Stdlib.hs +7/−0
- Puppet/Testing.hs +2/−2
- language-puppet.cabal +7/−7
- progs/PuppetResources.hs +43/−28
Erb/Compute.hs view
@@ -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)
Facter.hs view
@@ -104,7 +104,7 @@ factUser :: IO [(String, String)] factUser = do- username <- getLoginName+ username <- getEffectiveUserName return [("id",username)] factUName :: IO [(String, String)]
Puppet/Daemon.hs view
@@ -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
Puppet/Interpreter.hs view
@@ -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
Puppet/Interpreter/IO.hs view
@@ -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))
Puppet/Interpreter/PrettyPrinter.hs view
@@ -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 -> "<~"
Puppet/Interpreter/Pure.hs view
@@ -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 =
Puppet/Interpreter/Resolve.hs view
@@ -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
Puppet/Interpreter/Types.hs view
@@ -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
Puppet/Preferences.hs view
@@ -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
Puppet/Stdlib.hs view
@@ -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))
Puppet/Testing.hs view
@@ -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 "
language-puppet.cabal view
@@ -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
progs/PuppetResources.hs view
@@ -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)