diff --git a/Erb/Compute.hs b/Erb/Compute.hs --- a/Erb/Compute.hs +++ b/Erb/Compute.hs @@ -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 diff --git a/Puppet/Daemon.hs b/Puppet/Daemon.hs --- a/Puppet/Daemon.hs +++ b/Puppet/Daemon.hs @@ -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 + diff --git a/Puppet/Interpreter.hs b/Puppet/Interpreter.hs --- a/Puppet/Interpreter.hs +++ b/Puppet/Interpreter.hs @@ -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) diff --git a/Puppet/Stdlib.hs b/Puppet/Stdlib.hs --- a/Puppet/Stdlib.hs +++ b/Puppet/Stdlib.hs @@ -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 diff --git a/Puppet/Utils.hs b/Puppet/Utils.hs --- a/Puppet/Utils.hs +++ b/Puppet/Utils.hs @@ -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 diff --git a/PuppetDB/Remote.hs b/PuppetDB/Remote.hs --- a/PuppetDB/Remote.hs +++ b/PuppetDB/Remote.hs @@ -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")) diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -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 diff --git a/progs/PuppetResources.hs b/progs/PuppetResources.hs --- a/progs/PuppetResources.hs +++ b/progs/PuppetResources.hs @@ -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) diff --git a/progs/pdbQuery.hs b/progs/pdbQuery.hs --- a/progs/pdbQuery.hs +++ b/progs/pdbQuery.hs @@ -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")