{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
module Puppet.Daemon (
initDaemon
, checkError
-- * Re-exports
, module Puppet.Interpreter.Types
, module Puppet.PP
) where
import Control.Exception
import Control.Exception.Lens
import qualified Control.Lens as L
import Control.Lens.Operators
import qualified Data.Either.Strict as S
import Data.FileCache
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Tuple.Strict
import qualified Data.Vector as V
import Debug.Trace (traceEventIO)
import Foreign.Ruby.Safe
import System.Exit (exitFailure)
import System.IO (stdout)
import qualified System.Log.Formatter as LOG (simpleLogFormatter)
import System.Log.Handler (setFormatter)
import qualified System.Log.Handler.Simple as LOG (streamHandler)
import qualified System.Log.Logger as LOG
import Erb.Compute
import Hiera.Server
import Puppet.Interpreter
import Puppet.Interpreter.IO
import Puppet.Interpreter.Types
import Puppet.Lens (_PrettyError)
import Puppet.Manifests
import Puppet.OptionalTests
import Puppet.Parser
import Puppet.Parser.Types
import Puppet.Plugins
import Puppet.PP
import Puppet.Preferences
import Puppet.Stats
import Puppet.Utils
{-| This is a high level function, that will initialize the parsing and
interpretation infrastructure from the 'Preferences', and will return 'DaemonMethods'.
From there, you have access to 'getCatalog', a function that take a node name,
and the 'Facts' to return the result of the catalog computation. 'DaemonMethods' also returns
a few IO functions that can be used to query for statistics (see "Puppet.Stats").
It will internaly initialize a thread for the LUA interpreter, and a thread for the Ruby one.
It should cache the AST of every .pp file, and could use a bit of memory. As a comparison, it
fits in 60 MB with the author's manifests, but really breathes when given 300 MB
of heap space. In this configuration, even if it spawns a ruby process for every
template evaluation, it is way faster than the puppet stack.
It can optionnaly talk with PuppetDB, by setting an URL via the 'prefPDB'.
The recommended way to set it to http://localhost:8080 and set a SSH tunnel :
> ssh -L 8080:localhost:8080 puppet.host
Canveats :
* It might be buggy when top level statements that are not class\/define\/nodes
are altered, or when files loaded with require are changed.
* The catalog is not computed exactly the same way Puppet does. Some good practices are enforced, particularly in strict mode.
For instance, unknown variables are always an error. Querying a dictionary with a non existent key returns undef in puppet, whereas it would throw an error in strict mode.
-}
initDaemon :: Preferences IO -> IO DaemonMethods
initDaemon prefs = do
setupLogger (prefs ^. prefLogLevel)
logDebug "initDaemon"
traceEventIO "initDaemon"
templateStats <- newStats
parserStats <- newStats
catalogStats <- newStats
pfilecache <- newFileCache
intr <- startRubyInterpreter
hquery <- case prefs ^. prefHieraPath of
Just p -> either error id <$> startHiera p
Nothing -> return dummyHiera
luacontainer <- initLuaMaster (T.pack (prefs ^. prefPuppetPaths.modulesPath))
let myprefs = prefs & prefExtFuncs %~ HM.union luacontainer
getStatements = parseFunction myprefs pfilecache parserStats
getTemplate <- initTemplateDaemon intr myprefs templateStats
return (DaemonMethods (gCatalog myprefs getStatements getTemplate catalogStats hquery) parserStats catalogStats templateStats)
-- Public utils func to work with the daemon --
-- | In case of a Left value, print the error and exit immediately
checkError :: Show e => Doc -> Either e a -> IO a
checkError desc = either exit return
where
exit = \err -> putDoc (display err) >> exitFailure
display err = red desc <> ": " <+> (string . show) err
-- Some utils func internal to this module --
gCatalog :: Preferences IO
-> ( TopLevelType -> T.Text -> IO (S.Either PrettyError Statement) )
-> (Either T.Text T.Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError T.Text))
-> MStats
-> HieraQueryFunc IO
-> Nodename
-> Facts
-> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))
gCatalog prefs getStatements getTemplate stats hquery node facts = do
logDebug ("Received query for node " <> node)
traceEventIO ("START gCatalog " <> T.unpack node)
let catalogComputation = getCatalog (InterpreterReader
(prefs ^. prefNatTypes)
getStatements
getTemplate
(prefs ^. prefPDB)
(prefs ^. prefExtFuncs)
node
hquery
defaultImpureMethods
(prefs ^. prefIgnoredmodules)
(prefs ^. prefExternalmodules)
(prefs ^. prefStrictness == Strict)
(prefs ^. prefPuppetPaths)
)
node
facts
(prefs ^. prefPuppetSettings)
(stmts :!: warnings) <- measure stats node catalogComputation
mapM_ (\(p :!: m) -> LOG.logM daemonLoggerName p (displayS (renderCompact (ttext node <> ":" <+> m)) "")) warnings
traceEventIO ("STOP gCatalog " <> T.unpack node)
if prefs ^. prefExtraTests
then runOptionalTests stmts
else return stmts
where
runOptionalTests stm = case stm^?S._Right.L._1 of
Nothing -> return stm
(Just c) -> catching _PrettyError
(do {testCatalog prefs c; return stm})
(return . S.Left)
parseFunction :: Preferences IO -> FileCache (V.Vector Statement) -> MStats -> TopLevelType -> T.Text -> IO (S.Either PrettyError Statement)
parseFunction prefs filecache stats topleveltype toplevelname =
case compileFileList prefs topleveltype toplevelname of
S.Left rr -> return (S.Left rr)
S.Right fname -> do
let sfname = T.unpack fname
handleFailure :: SomeException -> IO (S.Either String (V.Vector Statement))
handleFailure e = return (S.Left (show e))
x <- measure stats fname (query filecache sfname (parseFile sfname `catch` handleFailure))
case x of
S.Right stmts -> filterStatements topleveltype toplevelname stmts
S.Left rr -> return (S.Left (PrettyError (red (text rr))))
-- TODO this is wrong, see
-- http://docs.puppetlabs.com/puppet/3/reference/lang_namespaces.html#behavior
compileFileList :: Preferences IO -> TopLevelType -> T.Text -> S.Either PrettyError T.Text
compileFileList prefs TopNode _ = S.Right (T.pack (prefs ^. prefPuppetPaths.manifestPath) <> "/site.pp")
compileFileList prefs _ name = moduleInfo
where
moduleInfo | length nameparts == 1 = S.Right (mpath <> "/" <> name <> "/manifests/init.pp")
| null nameparts = S.Left "no name parts, error in compilefilelist"
| otherwise = S.Right (mpath <> "/" <> head nameparts <> "/manifests/" <> T.intercalate "/" (tail nameparts) <> ".pp")
mpath = T.pack (prefs ^. prefPuppetPaths.modulesPath)
nameparts = T.splitOn "::" name
parseFile :: FilePath -> IO (S.Either String (V.Vector Statement))
parseFile fname = do
traceEventIO ("START parsing " ++ fname)
cnt <- T.readFile fname
o <- case runPParser fname cnt of
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
daemonLoggerName :: String
daemonLoggerName = "Puppet.Daemon"
logDebug :: T.Text -> IO ()
logDebug = LOG.debugM daemonLoggerName . T.unpack
setupLogger :: LOG.Priority -> IO ()
setupLogger p = do
LOG.updateGlobalLogger daemonLoggerName (LOG.setLevel p)
LOG.updateGlobalLogger hieraLoggerName (LOG.setLevel p)
hs <- consoleLogHandler
LOG.updateGlobalLogger LOG.rootLoggerName $ LOG.setHandlers [hs]
where
consoleLogHandler = setFormatter
<$> LOG.streamHandler stdout LOG.DEBUG
<*> pure (LOG.simpleLogFormatter "$prio: $msg")