Daemon.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Use <$>" #-}
module Puppet.Runner.Daemon
  ( Daemon (..),
    initDaemon,
  )
where

import qualified Data.Either.Strict as S
import Data.FileCache as FileCache
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as Text
import Debug.Trace (traceEventIO)
import Facter
import Foreign.Ruby.Safe
import Hiera.Server
import Puppet.Interpreter
import Puppet.Parser
import Puppet.Runner.Daemon.FileParser
import Puppet.Runner.Daemon.OptionalTests
import Puppet.Runner.Erb
import Puppet.Runner.Preferences
import Puppet.Runner.Stats
import qualified System.Directory as Directory
import qualified System.Log.Formatter as Log (simpleLogFormatter)
import qualified System.Log.Handler as Log (setFormatter)
import qualified System.Log.Handler.Simple as Log (streamHandler)
import qualified System.Log.Logger as Log
import XPrelude

-- | API for the Daemon.
-- The main method is `getCatalog`: given a node and a list of facts, it returns the result of the compilation.
-- This will be either an error, or a tuple containing:
--
-- - all the resources in this catalog
-- - the dependency map
-- - the exported resources
-- - a list of known resources, that might not be up to date, but are here for code coverage tests.
--
-- Notes :
--
-- * It might be buggy when top level statements that are not class\/define\/nodes are altered.
data Daemon = Daemon
  { getCatalog :: NodeName -> Facts -> IO (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])),
    parserStats :: MStats,
    catalogStats :: MStats,
    templateStats :: MStats
  }

-- | Entry point to get a Daemon.
-- It will initialize the parsing and interpretation infrastructure from the 'Preferences'.
--
-- Cache the AST of every .pp file. It 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 optionally 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
initDaemon ::
  Preferences IO ->
  IO Daemon
initDaemon pref = do
  setupLogger (pref ^. prefLogLevel)
  logDebug "Initialize daemon"
  traceEventIO "initDaemon"
  hquery <- hieraQuery pref
  fcache <- newFileCache
  intr <- startRubyInterpreter
  templStats <- newStats
  getTemplate <- initTemplateDaemon intr pref templStats
  catStats <- newStats
  parseStats <- newStats
  pure
    ( Daemon
        (getCatalog' pref (parseFunc (pref ^. prefPuppetPaths) fcache parseStats) getTemplate catStats hquery)
        parseStats
        catStats
        templStats
    )

getCatalog' ::
  Preferences IO ->
  (TopLevelType -> Text -> IO (S.Either PrettyError Statement)) ->
  (TemplateSource -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text)) ->
  MStats ->
  HieraQueryLayers IO ->
  NodeName ->
  Facts ->
  IO (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))
getCatalog' pref parsingfunc getTemplate stats hquery node facts = do
  logDebug ("Received query for node " <> node)
  traceEventIO ("START getCatalog' " <> Text.unpack node)
  let catalogComputation =
        interpretCatalog
          ( InterpreterReader
              (pref ^. prefNatTypes)
              parsingfunc
              getTemplate
              (pref ^. prefPDB)
              (pref ^. prefExtFuncs)
              node
              hquery
              defaultImpureMethods
              (pref ^. prefIgnoredmodules)
              (pref ^. prefExternalmodules)
              (pref ^. prefStrictness == Strict)
              (pref ^. prefPuppetPaths)
              (pref ^. prefRebaseFile)
              ((pref ^. prefFactsOverride) `HM.union` (pref ^. prefFactsDefault))
          )
          node
          facts
          (pref ^. prefPuppetSettings)
  (stmts :!: warnings) <- measure stats node catalogComputation
  mapM_ (\(p :!: m) -> Log.logM loggerName p (displayS (renderCompact (ppline node <> ":" <+> m)) "")) warnings
  traceEventIO ("STOP getCatalog' " <> toS node)
  case stmts of
    Left _ -> pure stmts -- no catalog so we can't do the extra tests
    Right r@(c, _, _, _) -> do
      if pref ^. prefExtraTests
        then second (const r) <$> testCatalog pref c
        else pure stmts

-- Build the 'HieraQueryLayers' needed by the interpreter to lookup hiera values.
hieraQuery :: Preferences IO -> IO (HieraQueryLayers IO)
hieraQuery pref = do
  global_api <- case pref ^. prefHieraPath of
    Just p -> startHiera "global" p
    Nothing -> pure dummyHiera
  env_api <- getEnvApi
  mod_api <- getModApis
  pure (HieraQueryLayers global_api env_api mod_api)
  where
    getEnvApi :: IO (HieraQueryFunc IO)
    getEnvApi = do
      let f = (pref ^. prefPuppetPaths . baseDir) <> "/hiera.yaml"
      found <- Directory.doesFileExist f
      if found then startHiera "environment" f else pure dummyHiera
    getModApis :: IO (Container (HieraQueryFunc IO))
    getModApis = do
      let ignored_modules = pref ^. prefIgnoredmodules
          modpath = pref ^. prefPuppetPaths . modulesPath
      dirs <- Directory.listDirectory modpath
      HM.fromList . catMaybes
        <$> for
          dirs
          ( \dir -> runMaybeT $ do
              let modname = toS dir
                  fp = modpath <> "/" <> dir <> "/hiera.yaml"
              guard (modname `notElem` ignored_modules)
              guard =<< liftIO (Directory.doesFileExist fp)
              liftIO $ (modname,) <$> startHiera "module" fp
          )

defaultImpureMethods :: (MonadIO m) => IoMethods m
defaultImpureMethods =
  IoMethods (liftIO currentCallStack) (liftIO . file) (liftIO . traceEventIO)
  where
    file [] = return $ Left ""
    file (x : xs) = (Right <$> readFile (Text.unpack x)) `catch` (\SomeException {} -> file xs)

setupLogger :: Log.Priority -> IO ()
setupLogger p = do
  Log.updateGlobalLogger loggerName (Log.setLevel p)
  hs <- consoleLogHandler
  Log.updateGlobalLogger Log.rootLoggerName $ Log.setHandlers [hs]
  where
    consoleLogHandler =
      Log.setFormatter
        <$> Log.streamHandler stdout Log.DEBUG
        <*> pure (Log.simpleLogFormatter "$prio: $msg")