Preferences.hs

{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-}

module Puppet.Runner.Preferences
  ( Preferences (Preferences),
    prefPuppetPaths,
    prefPDB,
    prefNatTypes,
    prefExtFuncs,
    prefHieraPath,
    prefIgnoredmodules,
    prefStrictness,
    prefExtraTests,
    prefKnownusers,
    prefKnowngroups,
    prefExternalmodules,
    prefPuppetSettings,
    prefFactsOverride,
    prefFactsDefault,
    prefLogLevel,
    prefRebaseFile,
    dfPreferences,
    PuppetDirPaths,
    HasPuppetDirPaths (..),
  )
where

import Data.Aeson
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Yaml as Yaml
import Puppet.Interpreter
import qualified Puppet.Runner.Puppetlabs as Puppetlabs
import Puppet.Runner.Stdlib
import PuppetDB
import qualified System.Directory as Directory
import qualified System.FilePath as FilePath
import qualified System.Log.Logger as LOG
import XPrelude

data Preferences m = Preferences
  { _prefPuppetPaths :: PuppetDirPaths,
    _prefPDB :: PuppetDBAPI m,
    -- | The list of native types.
    _prefNatTypes :: Container NativeTypeMethods,
    _prefExtFuncs :: Container ([PValue] -> InterpreterMonad PValue),
    _prefHieraPath :: Maybe FilePath,
    _prefIgnoredmodules :: HS.HashSet Text,
    _prefStrictness :: Strictness,
    _prefExtraTests :: Bool,
    _prefKnownusers :: [Text],
    _prefKnowngroups :: [Text],
    _prefExternalmodules :: HS.HashSet Text,
    -- | Puppet server settings
    _prefPuppetSettings :: Container Text,
    _prefFactsOverride :: Container PValue,
    _prefFactsDefault :: Container PValue,
    _prefLogLevel :: LOG.Priority,
    -- | Make all calls to file() with absolute pathes relative to the given path.
    _prefRebaseFile :: Maybe FilePath
  }

data Defaults = Defaults
  { _dfKnownusers :: Maybe [Text],
    _dfKnowngroups :: Maybe [Text],
    _dfIgnoredmodules :: Maybe [Text],
    _dfStrictness :: Maybe Strictness,
    _dfExtratests :: Maybe Bool,
    _dfExternalmodules :: Maybe [Text],
    _dfPuppetSettings :: Maybe (Container Text),
    _dfFactsDefault :: Maybe (Container PValue),
    _dfFactsOverride :: Maybe (Container PValue),
    _dfRebaseFile :: Maybe FilePath
  }
  deriving (Show)

makeLenses ''Preferences

instance FromJSON Defaults where
  parseJSON (Object v) =
    Defaults
      <$> v .:? "knownusers"
      <*> v .:? "knowngroups"
      <*> v .:? "ignoredmodules"
      <*> v .:? "strict"
      <*> v .:? "extratests"
      <*> v .:? "externalmodules"
      <*> v .:? "settings"
      <*> v .:? "factsdefault"
      <*> v .:? "factsoverride"
      <*> v .:? "rebasefile"
  parseJSON _ = mzero

-- | Generate default preferences.
dfPreferences ::
  FilePath ->
  IO (Preferences IO)
dfPreferences basedir = do
  let dirpaths = puppetPaths basedir
      modulesdir = dirpaths ^. modulesPath
      testdir = dirpaths ^. testPath
      hierafile = basedir <> "/hiera.yaml"
      defaultfile = testdir <> "/defaults.yaml"
  defaults <- ifM (Directory.doesFileExist defaultfile) (Yaml.decodeFileThrow defaultfile) (pure Nothing)
  hieradir <- ifM (Directory.doesFileExist hierafile) (pure $ Just hierafile) (pure Nothing)
  loadedtypes <- loadedTypes modulesdir
  labsFunctions <- Puppetlabs.extFunctions modulesdir
  return $
    Preferences
      dirpaths
      dummyPuppetDB
      (baseNativeTypes `HM.union` loadedtypes)
      (HM.union stdlibFunctions labsFunctions)
      hieradir
      (getIgnoredmodules defaults)
      (getStrictness defaults)
      (getExtraTests defaults)
      (getKnownusers defaults)
      (getKnowngroups defaults)
      (getExternalmodules defaults)
      (getPuppetSettings dirpaths defaults)
      (getFactsOverride defaults)
      (getFactsDefault defaults)
      LOG.NOTICE -- good default as INFO is quite noisy
      Nothing

loadedTypes :: FilePath -> IO (HM.HashMap NativeTypeName NativeTypeMethods)
loadedTypes modulesdir = do
  typenames <- map (Text.pack . FilePath.takeBaseName) <$> getFiles modulesdir "lib/puppet/type" ".rb"
  pure $ HM.fromList (map defaulttype typenames)
  where
    getFiles :: FilePath -> FilePath -> FilePath -> IO [FilePath]
    getFiles moduledir subdir extension =
      fmap concat $
        Directory.listDirectory moduledir
          >>= mapM (checkForSubFiles extension . (\x -> moduledir <> "/" <> x <> "/" <> subdir))
    checkForSubFiles :: FilePath -> FilePath -> IO [FilePath]
    checkForSubFiles extension dir =
      catch (fmap Right (Directory.listDirectory dir)) (\e -> return $ Left (e :: IOException)) >>= \case
        Right o -> return ((map (\x -> dir <> "/" <> x) . filter (List.isSuffixOf extension)) o)
        Left _ -> return []

-- Utilities for getting default values from the yaml file
-- It provides (the same) static defaults (see the 'Nothing' case) when
--     no default yaml file or
--     not key/value for the option has been provided
getKnownusers :: Maybe Defaults -> [Text]
getKnownusers = fromMaybe ["mysql", "vagrant", "nginx", "nagios", "postgres", "puppet", "root", "syslog", "www-data"] . (>>= _dfKnownusers)

getKnowngroups :: Maybe Defaults -> [Text]
getKnowngroups = fromMaybe ["adm", "syslog", "mysql", "nagios", "postgres", "puppet", "root", "www-data", "postfix"] . (>>= _dfKnowngroups)

getStrictness :: Maybe Defaults -> Strictness
getStrictness = fromMaybe Permissive . (>>= _dfStrictness)

getIgnoredmodules :: Maybe Defaults -> HS.HashSet Text
getIgnoredmodules = maybe mempty HS.fromList . (>>= _dfIgnoredmodules)

getExtraTests :: Maybe Defaults -> Bool
getExtraTests = fromMaybe True . (>>= _dfExtratests)

getExternalmodules :: Maybe Defaults -> HS.HashSet Text
getExternalmodules = maybe mempty HS.fromList . (>>= _dfExternalmodules)

getPuppetSettings :: PuppetDirPaths -> Maybe Defaults -> Container Text
getPuppetSettings dirpaths = fromMaybe df . (>>= _dfPuppetSettings)
  where
    df :: Container Text
    df =
      HM.fromList
        [ ("confdir", Text.pack $ dirpaths ^. baseDir),
          ("strict_variables", "true")
        ]

getFactsOverride :: Maybe Defaults -> Container PValue
getFactsOverride = fromMaybe mempty . (>>= _dfFactsOverride)

getFactsDefault :: Maybe Defaults -> Container PValue
getFactsDefault = fromMaybe mempty . (>>= _dfFactsDefault)