module Puppet.Daemon (initDaemon, logDebug, logInfo, logWarning, logError) where
import Puppet.Parser
import Puppet.Utils
import Puppet.Preferences
import Puppet.Stats
import Puppet.Interpreter.Types
import Puppet.Parser.Types
import Puppet.Manifests
import Puppet.Interpreter
import Puppet.Plugins
import Hiera.Server
import Erb.Compute
import Puppet.PP
import Text.Parsec
import Data.FileCache
import qualified System.Log.Logger as LOG
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Vector as V
import qualified Data.HashMap.Strict as HM
import Debug.Trace
import Control.Lens
import Control.Monad
import Control.Concurrent
import qualified Data.Either.Strict as S
import Data.Tuple.Strict
import Control.Exception
#ifdef HRUBY
import Foreign.Ruby.Safe
#endif
loggerName :: String
loggerName = "Puppet.Daemon"
logDebug :: T.Text -> IO ()
logDebug = LOG.debugM loggerName . T.unpack
logInfo :: T.Text -> IO ()
logInfo = LOG.infoM loggerName . T.unpack
logWarning :: T.Text -> IO ()
logWarning = LOG.warningM loggerName . T.unpack
logError :: T.Text -> IO ()
logError = LOG.errorM loggerName . T.unpack
initDaemon :: Preferences -> IO DaemonMethods
initDaemon prefs = do
logDebug "initDaemon"
traceEventIO "initDaemon"
controlChan <- newChan
templateStats <- newStats
parserStats <- newStats
catalogStats <- newStats
getStatements <- initParserDaemon prefs parserStats
#ifdef HRUBY
intr <- startRubyInterpreter
getTemplate <- initTemplateDaemon intr prefs templateStats
#else
getTemplate <- initTemplateDaemon prefs templateStats
#endif
hquery <- case prefs ^. hieraPath of
Just p -> startHiera p >>= \case
Left _ -> return dummyHiera
Right x -> return x
Nothing -> return dummyHiera
let runMaster = do
(luastate, luafunctions) <- initLua (T.pack (prefs ^. modulesPath))
let luacontainer = HM.fromList [ (fname, puppetFunc luastate fname) | fname <- luafunctions ]
myprefs = prefs & prefExtFuncs %~ HM.union luacontainer
master myprefs controlChan getStatements getTemplate catalogStats hquery
replicateM_ (prefs ^. compilePoolSize) (forkIO runMaster)
return (DaemonMethods (gCatalog controlChan) parserStats catalogStats templateStats)
gCatalog :: Chan DaemonQuery -> T.Text -> Facts -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog))
gCatalog q ndename fcts = do
t <- newEmptyMVar
writeChan q (DaemonQuery ndename fcts t)
readMVar t
data DaemonQuery = DaemonQuery
{ _qNodeName :: T.Text
, _qFacts :: Facts
, _qQ :: MVar DaemonResponse
}
type DaemonResponse = S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog)
master :: Preferences
-> Chan DaemonQuery
-> ( TopLevelType -> T.Text -> IO (S.Either Doc Statement) )
-> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text))
-> MStats
-> HieraQueryFunc
-> IO ()
master prefs controlQ getStatements getTemplate stats hquery = forever $ do
(DaemonQuery ndename facts q) <- readChan controlQ
logDebug ("Received query for node " <> ndename)
traceEventIO ("Received query for node " <> 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)
putMVar q stmts
initParserDaemon :: Preferences -> MStats -> IO ( TopLevelType -> T.Text -> IO (S.Either Doc Statement) )
initParserDaemon prefs mstats = do
let nbthreads = prefs ^. parsePoolSize
logDebug ("initParserDaemon - " <> tshow nbthreads <> " threads")
controlChan <- newChan
filecache <- newFileCache
replicateM_ nbthreads (forkIO (pmaster prefs controlChan filecache mstats))
return $ \tt tn -> do
c <- newEmptyMVar
writeChan controlChan (ParserQuery tt tn c)
readMVar c
data ParserMessage = ParserQuery !TopLevelType !T.Text !(MVar (S.Either Doc Statement))
compileFileList :: Preferences -> TopLevelType -> T.Text -> S.Either Doc T.Text
compileFileList prefs TopNode _ = S.Right (T.pack (prefs ^. 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 ^. modulesPath)
nameparts = T.splitOn "::" name
parseFile :: FilePath -> IO (S.Either String (V.Vector Statement))
parseFile fname = do
cnt <- T.readFile fname
runParserT puppetParser () fname cnt >>= \case
Right r -> return (S.Right r)
Left rr -> return (S.Left (show rr))
pmaster :: Preferences -> Chan ParserMessage -> FileCache (V.Vector Statement) -> MStats -> IO ()
pmaster prefs controlqueue filecache stats = forever $ do
(ParserQuery topleveltype toplevelname responseQ) <- readChan controlqueue
case compileFileList prefs topleveltype toplevelname of
S.Left rr -> putMVar responseQ (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))
colorError (S.Right x) = S.Right x
colorError (S.Left rr) = S.Left (red (text rr))
fmap colorError ( measure stats fname (query filecache sfname (parseFile sfname `catch` handleFailure)) ) >>= \case
S.Left rr -> putMVar responseQ (S.Left rr)
S.Right stmts -> filterStatements topleveltype toplevelname stmts >>= putMVar responseQ