Preferences.hs

{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase             #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE TemplateHaskell        #-}
module Puppet.Preferences (
    dfPreferences
  , HasPreferences(..)
  , Preferences(Preferences)
  , PuppetDirPaths
  , HasPuppetDirPaths(..)
) where

import           Puppet.Prelude

import           Data.Aeson
import qualified Data.HashMap.Strict        as HM
import qualified Data.HashSet               as HS
import qualified Data.Text                  as Text
import qualified Data.Yaml                  as Yaml
import qualified System.Log.Logger          as LOG
import           System.Posix               (fileExist)

import           Puppet.Interpreter.Types
import           Puppet.NativeTypes
import           Puppet.NativeTypes.Helpers
import           Puppet.Paths
import qualified Puppet.Puppetlabs          as Puppetlabs
import           Puppet.Stdlib
import           PuppetDB.Dummy

data Preferences m = Preferences
    { _prefPuppetPaths     :: PuppetDirPaths
    , _prefPDB             :: PuppetDBAPI m
    , _prefNatTypes        :: Container NativeTypeMethods -- ^ The list of native types.
    , _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 -- ^ Make all calls to file() with absolute pathes relative to the given path.
    }

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


makeClassy ''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 (fileExist defaultfile) (Yaml.decodeFile defaultfile) (pure Nothing)
    hieradir <- ifM (fileExist 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 <- fmap (map takeBaseName) (getFiles (Text.pack modulesdir) "lib/puppet/type" ".rb")
  pure $ HM.fromList (map defaulttype typenames)

-- 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)