language-puppet 0.12.1 → 0.12.2
raw patch · 9 files changed
+91/−31 lines, 9 filesdep ~hspecdep ~http-conduit
Dependency ranges changed: hspec, http-conduit
Files
- Erb/Compute.hs +9/−7
- Puppet/Daemon.hs +8/−5
- Puppet/Interpreter.hs +1/−0
- Puppet/Stdlib.hs +1/−1
- Puppet/Utils.hs +6/−0
- PuppetDB/Remote.hs +4/−4
- language-puppet.cabal +4/−4
- progs/PuppetResources.hs +43/−7
- progs/pdbQuery.hs +15/−3
Erb/Compute.hs view
@@ -67,8 +67,6 @@ initTemplateDaemon intr (Preferences _ modpath templatepath _ _ _ _) mvstats = do controlchan <- newChan templatecache <- newFileCache- -- forkOS is used because ruby doesn't like to change threads- -- all initialization is done on the current thread let returnError rs = return $ \_ _ _ -> return (S.Left (showRubyError rs)) getRubyScriptPath "hrubyerb.rb" >>= loadFile intr >>= \case Left rs -> returnError rs@@ -94,6 +92,7 @@ templateDaemon :: RubyInterpreter -> T.Text -> T.Text -> Chan TemplateQuery -> MStats -> FileCacheR ParseError [RubyStatement] -> IO () templateDaemon intr modpath templatepath qchan mvstats filecache = do+ nameThread "RubyTemplateDaemon" (respchan, fileinfo, scope, variables) <- readChan qchan case fileinfo of Right filename -> do@@ -103,8 +102,8 @@ acceptablefiles <- filterM (fileExist . T.unpack) searchpathes if null acceptablefiles then writeChan respchan (S.Left $ "Can't find template file for" <+> ttext filename <+> ", looked in" <+> list (map ttext searchpathes))- else measure mvstats ("total - " <> filename) (computeTemplate intr (Right (head acceptablefiles)) scope variables mvstats filecache) >>= writeChan respchan- Left _ -> measure mvstats "total - inline" (computeTemplate intr fileinfo scope variables mvstats filecache) >>= writeChan respchan+ else measure mvstats filename (computeTemplate intr (Right (head acceptablefiles)) scope variables mvstats filecache) >>= writeChan respchan+ Left _ -> measure mvstats "inline" (computeTemplate intr fileinfo scope variables mvstats filecache) >>= writeChan respchan templateDaemon intr modpath templatepath qchan mvstats filecache computeTemplate :: RubyInterpreter -> Either T.Text T.Text -> T.Text -> Container ScopeInformation -> MStats -> FileCacheR ParseError [RubyStatement] -> IO TemplateAnswer@@ -115,10 +114,11 @@ mkSafe a = makeSafe intr a >>= \case Left rr -> return (S.Left (showRubyError rr)) Right x -> return x+ traceEventIO ("START template " ++ T.unpack filename) parsed <- case fileinfo of Right _ -> measure mstats ("parsing - " <> filename) $ lazyQuery filecache ufilename $ parseErbFile ufilename Left content -> measure mstats ("parsing - " <> filename) $ return (runParser erbparser () "inline" (T.unpack content))- case parsed of+ o <- case parsed of Left err -> do let !msg = "template " ++ ufilename ++ " could not be parsed " ++ show err traceEventIO msg@@ -131,6 +131,8 @@ traceEventIO msg LOG.debugM "Erb.Compute" msg measure mstats ("ruby efail - " <> filename) $ mkSafe $ computeTemplateWRuby fileinfo curcontext variables+ traceEventIO ("STOP template " ++ T.unpack filename)+ return o getRubyScriptPath :: String -> IO String getRubyScriptPath rubybin = do@@ -212,9 +214,9 @@ input = T.fromText curcontext <> "\n" <> T.fromText filename <> "\n" <> rubyvars :: T.Builder ufilename = T.unpack filename rubyscriptpath <- getRubyScriptPath "calcerb.rb"- traceEventIO ("start running ruby" ++ ufilename)+ traceEventIO ("START ruby " ++ ufilename) !ret <- safeReadProcessTimeout "ruby" [rubyscriptpath] (T.toLazyText input) 1000- traceEventIO ("finished running ruby" ++ ufilename)+ traceEventIO ("STOP ruby " ++ ufilename) F.forM_ temp removeLink case ret of Just (Right x) -> return $! S.Right x
Puppet/Daemon.hs view
@@ -110,10 +110,10 @@ -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) gCatalog prefs getStatements getTemplate stats hquery ndename facts = do logDebug ("Received query for node " <> ndename)- traceEventIO ("Received query for node " <> T.unpack ndename)+ traceEventIO ("START gCatalog " <> T.unpack ndename) (stmts :!: warnings) <- measure stats ndename $ getCatalog getStatements getTemplate (prefs ^. prefPDB) ndename facts (prefs ^. natTypes) (prefs ^. prefExtFuncs) hquery- mapM_ (\(p :!: m) -> LOG.logM loggerName p (displayS (renderCompact m) "")) warnings- traceEventIO ("getCatalog finished for " <> T.unpack ndename)+ mapM_ (\(p :!: m) -> LOG.logM loggerName p (displayS (renderCompact (ttext ndename <> ":" <+> m)) "")) warnings+ traceEventIO ("STOP gCatalog " <> T.unpack ndename) return stmts parseFunction :: Preferences -> FileCache (V.Vector Statement) -> MStats -> TopLevelType -> T.Text -> IO (S.Either Doc Statement)@@ -143,9 +143,12 @@ parseFile :: FilePath -> IO (S.Either String (V.Vector Statement)) parseFile fname = do- traceEventIO ("Start parsing " ++ fname)+ traceEventIO ("START parsing " ++ fname) cnt <- T.readFile fname- runMyParser puppetParser fname cnt >>= \case+ o <- runMyParser puppetParser fname cnt >>= \case Right r -> traceEventIO ("Stopped parsing " ++ fname) >> return (S.Right r) Left rr -> traceEventIO ("Stopped parsing " ++ fname ++ " (failure: " ++ show rr ++ ")") >> return (S.Left (show rr))+ traceEventIO ("STOP parsing " ++ fname)+ return o+
Puppet/Interpreter.hs view
@@ -50,6 +50,7 @@ -> HieraQueryFunc -- ^ Hiera query function -> IO (Pair (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Priority Doc]) getCatalog gtStatement gtTemplate pdbQuery ndename facts nTypes extfuncs hquery = do+ nameThread ("Catalog " <> T.unpack ndename) let rdr = InterpreterReader nTypes gtStatement gtTemplate pdbQuery extfuncs ndename hquery dummypos = initialPPos "dummy" initialclass = mempty & at "::" ?~ (IncludeStandard :!: dummypos)
Puppet/Stdlib.hs view
@@ -200,7 +200,7 @@ return $ PBoolean $ not (T.null rs) && T.length rs <= 255 && all checkPart prts isInteger :: PValue -> InterpreterMonad PValue-isInteger = return . PBoolean . not . isn't _Integer+isInteger = return . PBoolean . has _Integer isString :: PValue -> InterpreterMonad PValue isString pv = return $ PBoolean $ case (pv ^? _PString, pv ^? _Number) of
Puppet/Utils.hs view
@@ -6,6 +6,7 @@ , takeBaseName , takeDirectory , strictifyEither+ , nameThread ) where import qualified Data.Text as T@@ -14,6 +15,8 @@ import Data.Monoid import System.Posix.Directory.ByteString import qualified Data.Either.Strict as S+import Control.Concurrent (myThreadId)+import GHC.Conc (labelThread) import Data.Attoparsec.Number import Puppet.Interpreter.Types@@ -28,6 +31,9 @@ textElem :: Char -> T.Text -> Bool textElem c = T.any (==c)++nameThread :: String -> IO ()+nameThread n = myThreadId >>= flip labelThread n getDirectoryContents :: T.Text -> IO [T.Text] getDirectoryContents fpath = do
PuppetDB/Remote.hs view
@@ -37,9 +37,9 @@ Null -> "" _ -> T.decodeUtf8 $ "?" <> W.renderSimpleQuery False [("query", jsonquery)] let fullurl = url <> "/v3/" <> querytype <> q- initReq <- case (parseUrl (T.unpack fullurl) :: Maybe (Request a)) of- Just x -> return x- Nothing -> throwError "Something failed when parsing the PuppetDB URL"+ initReq <- case parseUrl (T.unpack fullurl) of+ Right r -> return (r :: Request)+ Left rr -> throwError ("Something failed when parsing the PuppetDB URL" <+> string (show (rr :: HttpException))) let req = initReq { requestHeaders = [("Accept", "application/json")] } runRequest req @@ -54,5 +54,5 @@ (pdbRequest url "resources") (pdbRequest url "nodes") (return (S.Left "operation not supported"))- (\nodename -> pdbRequest url ("nodes/" <> nodename <> "/resources"))+ (\ndename -> pdbRequest url ("nodes/" <> ndename <> "/resources"))
language-puppet.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet-version: 0.12.1+version: 0.12.2 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/@@ -104,14 +104,14 @@ , process >= 1.1 && < 1.3 , iconv == 0.4.* , http-types == 0.8.*- , http-conduit >= 1.9 && < 1.10+ , http-conduit >= 2.0 && < 2.1 , attoparsec == 0.11.* , case-insensitive == 1.1.* , cryptohash >= 0.10 && < 0.12 , base16-bytestring == 0.1.* , containers == 0.5.* , stm == 2.4.*- , hspec >= 1.7.0 && < 1.8.0+ , hspec >= 1.7.0 && < 1.9.0 , yaml >= 0.8.0 && < 0.9 , stateWriter >= 0.2.1 && < 0.3 , split == 0.2.*@@ -156,7 +156,7 @@ executable puppetresources hs-source-dirs: progs extensions: BangPatterns, OverloadedStrings- ghc-options: -Wall -rtsopts -threaded -with-rtsopts "-A2M"+ ghc-options: -Wall -rtsopts -threaded -with-rtsopts "-A2M" -eventlog ghc-prof-options: -auto-all -caf-all -fprof-auto build-depends: language-puppet,base,text,parsec,vector,ansi-wl-pprint,bytestring,mtl,hslogger,Diff,unordered-containers,strict-base-types,optparse-applicative,regex-pcre-builtin,lens,aeson,yaml,parallel-io,containers,Glob,hspec main-is: PuppetResources.hs
progs/PuppetResources.hs view
@@ -127,6 +127,7 @@ import Data.List (isInfixOf) import qualified Test.Hspec.Runner as H import System.Exit (exitFailure, exitSuccess)+import Data.Tuple (swap) import Facter @@ -192,6 +193,8 @@ , _hieraFile :: Maybe FilePath , _factsFile :: Maybe FilePath , _factsDef :: Maybe FilePath+ , _commitDB :: Bool+ , _checkExport :: Bool } deriving Show prepareForPuppetApply :: WireCatalog -> WireCatalog@@ -238,7 +241,14 @@ <*> optional hiera <*> optional fcts <*> optional fco+ <*> commitdb+ <*> checkExported where+ commitdb = switch ( long "commitdb"+ <> help "Commit the computed catalogs in the puppetDB"+ )+ checkExported = switch ( long "checkExported"+ <> help "Save exported resources in the puppetDB") sc = switch ( long "showcontent" <> short 'c' <> help "When specifying a file resource, only output its content (useful for testing templates)")@@ -324,11 +334,20 @@ putDoc ("The following" <+> int (length deadResources) <+> "resource declarations are not used:" </> indent 4 (vcat (map pretty deadResources))) putStrLn "" +newtype Maximum a = Maximum { getMaximum :: Maybe a }++instance (Ord a) => Monoid (Maximum a) where+ mempty = Maximum Nothing+ mappend (Maximum Nothing) m2 = m2+ mappend m1 (Maximum Nothing) = m1+ mappend (Maximum (Just a1)) (Maximum (Just a2)) = Maximum (Just (max a1 a2))++ 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) = 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 <> ":" <+> rr)) checkError _ (S.Right x) = return x tnodename = T.pack ndename@@ -342,7 +361,7 @@ (Just p, Nothing) -> HM.union `fmap` loadFactsOverrides p (Nothing, Just p) -> (flip HM.union) `fmap` loadFactsOverrides p (Nothing, Nothing) -> return id- (queryfunc,mPStats,_,_) <- initializedaemonWithPuppet prio pdbapi puppetdir hpath factsOverrides+ (queryfunc,mPStats,mCStats,mTStats) <- initializedaemonWithPuppet prio pdbapi puppetdir hpath factsOverrides printFunc <- hIsTerminalDevice stdout >>= \isterm -> return $ \x -> if isterm then putDoc x >> putStrLn ""@@ -358,16 +377,33 @@ getNodeName (Node (NodeName n) _ _ _) = Just n getNodeName _ = Nothing cats <- parallel (map (computeCatalogs True queryfunc pdbapi printFunc c) topnodes)- putStrLn ("Tested " ++ show (length topnodes) ++ " nodes.") -- the the parsing statistics, so that we known which files -- were parsed pStats <- getStats mPStats+ cStats <- getStats mCStats+ tStats <- getStats mTStats -- merge all the resources together let cc = mapMaybe fst cats testFailures = getSum (cats ^. traverse . _2 . _Just . to (Sum . H.summaryFailures)) allres = (cc ^.. folded . _1 . folded) ++ (cc ^.. folded . _2 . folded) allfiles = Set.fromList $ map T.unpack $ HM.keys pStats when deadcode $ findDeadCode puppetdir allres allfiles+ -- compute statistics+ let (parsing, Just (wPName, wPMean)) = worstAndSum pStats+ (cataloging, Just (wCName, wCMean)) = worstAndSum cStats+ (templating, Just (wTName, wTMean)) = worstAndSum tStats+ parserShare = 100 * parsing / cataloging+ templateShare = 100 * templating / cataloging+ formatDouble = take 5 . show -- yeah, well ...+ 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") return $ if testFailures > 0 then exitFailure else exitSuccess@@ -378,11 +414,11 @@ then exitFailure else exitSuccess Nothing -> exitSuccess- void $ commitDB pdbapi+ when docommit $ void $ commitDB pdbapi exit computeCatalogs :: Bool -> QueryFunc -> PuppetDBAPI -> (Doc -> IO ()) -> CommandLine -> T.Text -> IO (Maybe (FinalCatalog, [Resource]), Maybe H.Summary)-computeCatalogs testOnly queryfunc pdbapi printFunc (CommandLine _ showjson showcontent mrt mrn puppetdir _ _ _ _ _ _) tnodename = queryfunc tnodename >>= \case+computeCatalogs testOnly queryfunc pdbapi printFunc (CommandLine _ showjson showcontent mrt mrn puppetdir _ _ _ _ _ _ _ checkExported) tnodename = queryfunc tnodename >>= \case S.Left rr -> do if testOnly then putDoc ("Problem with" <+> ttext tnodename <+> ":" <+> rr </> mempty)@@ -390,7 +426,7 @@ return (Nothing, Just (H.Summary 1 1)) S.Right (rawcatalog,m,rawexported,knownRes) -> do let wireCatalog = generateWireCatalog tnodename (rawcatalog <> rawexported) m- void $ replaceCatalog pdbapi wireCatalog+ when checkExported $ void $ replaceCatalog pdbapi wireCatalog let cmpMatch Nothing _ curcat = return curcat cmpMatch (Just rg) lns curcat = compile compBlank execBlank (T.unpack rg) >>= \case Left rr -> error ("Error compiling regexp 're': " ++ show rr)
progs/pdbQuery.hs view
@@ -7,7 +7,7 @@ import PuppetDB.Remote import Facter -import Options.Applicative as O+import Options.Applicative as O hiding ((&)) import qualified Data.Text as T import Data.Monoid import Data.Yaml hiding (Parser)@@ -17,6 +17,7 @@ import qualified Data.HashMap.Strict as HM import Control.Monad (forM_,unless) import qualified Data.Vector as V+import Data.List (foldl') data CommandLine = CommandLine { _pdbloc :: Maybe FilePath , _pdbtype :: PDBType@@ -58,7 +59,7 @@ <> value PDBTest <> help "PuppetDB types : test, remote, dummy" )- cmd = subparser ( command "dumpfacts" (ParserInfo (pure DumpFacts) True "Dump all facts" "Dump all facts" "" 4)+ cmd = subparser ( command "dumpfacts" (ParserInfo (pure DumpFacts) True "Dump all facts" "Dump all facts, and store them in /tmp/allfacts.yaml" "" 4) <> command "editfact" (ParserInfo factedit True "Edit a fact corresponding to a node" "" "" 7) <> command "dumpres" (ParserInfo resourcesparser True "Dump resources" "Dump resources" "" 5) <> command "delnode" (ParserInfo delnodeparser True "Deactivate node" "Deactivate node" "" 6)@@ -71,6 +72,10 @@ display s (S.Left rr) = error (s <> " " <> show rr) display _ (S.Right a) = BS.putStrLn (encode a) +checkError :: (Show r) => String -> S.Either r a -> IO a+checkError s (S.Left rr) = error (s <> " " <> show rr)+checkError _ (S.Right a) = return a+ run :: CommandLine -> IO () run cmdl = do epdbapi <- case (_pdbloc cmdl, _pdbtype cmdl) of@@ -85,7 +90,14 @@ case _pdbcmd cmdl of DumpFacts -> if _pdbtype cmdl == PDBDummy then puppetDBFacts "dummy" pdbapi >>= mapM_ print . HM.toList- else getFacts pdbapi QEmpty >>= display "get facts"+ else do+ allfacts <- getFacts pdbapi QEmpty >>= checkError "get facts"+ tmpdb <- loadTestDB "/tmp/allfacts.yaml" >>= checkError "load test db"+ let groupfacts = foldl' groupfact HM.empty allfacts+ groupfact curmap (PFactInfo ndname fctname fctval) =+ curmap & at ndname . non HM.empty %~ (at fctname ?~ fctval)+ replaceFacts tmpdb (HM.toList groupfacts) >>= checkError "replace facts in dummy db"+ commitDB tmpdb >>= checkError "commit db" DumpNodes -> getNodes pdbapi QEmpty >>= display "dump nodes" AddFacts n -> do unless (_pdbtype cmdl == PDBTest) (error "This option only works with the test puppetdb")