{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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 XPrelude
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 qualified System.Directory as Directory
import qualified System.FilePath as FilePath
import qualified System.Log.Logger as LOG
import Puppet.Interpreter
import qualified Puppet.Runner.Puppetlabs as Puppetlabs
import Puppet.Runner.Stdlib
import PuppetDB
data Preferences m = Preferences
{ _prefPuppetPaths :: PuppetDirPaths
, _prefPDB :: PuppetDBAPI m
, _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
, _prefPuppetSettings :: Container Text
, _prefFactsOverride :: Container PValue
, _prefFactsDefault :: Container PValue
, _prefLogLevel :: LOG.Priority
, _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
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
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 []
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)