language-puppet-0.12.3: Puppet/Interpreter/Resolve.hs
{-# LANGUAGE LambdaCase #-}
-- | This module is all about converting and resolving foreign data into
-- the fully exploitable corresponding data type. The main use case is the
-- conversion of 'Expression' to 'PValue'.
module Puppet.Interpreter.Resolve
( -- * Pure resolution functions
getVariable,
pValue2Bool,
-- * Monadic resolution functions
resolveVariable,
resolveExpression,
resolveValue,
resolvePValueString,
resolveExpressionString,
resolveExpressionStrings,
resolveArgument,
runHiera,
isNativeType,
-- * Search expression management
resolveSearchExpression,
checkSearchExpression,
searchExpressionToPuppetDB,
-- * Higher order puppet functions handling
hfGenerateAssociations,
hfSetvars,
hfRestorevars,
toNumbers
) where
import Puppet.PP
import Puppet.Interpreter.Types
import Puppet.Parser.Types
import Puppet.Interpreter.PrettyPrinter()
import Puppet.Parser.PrettyPrinter(showPos)
import Puppet.Interpreter.RubyRandom
import Data.Version (parseVersion)
import Text.ParserCombinators.ReadP (readP_to_S)
import Data.Maybe (fromMaybe)
import Data.Aeson hiding ((.=))
import Data.CaseInsensitive ( mk )
import qualified Data.Vector as V
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Monoid
import Control.Applicative hiding ((<$>))
import Control.Monad
import Control.Monad.Error
import Data.Tuple.Strict as S
import Control.Lens
import Data.Maybe (mapMaybe)
import Data.Aeson.Lens hiding (key)
import Data.Attoparsec.Number
import qualified Data.Either.Strict as S
import qualified Data.Maybe.Strict as S
import qualified Data.ByteString as BS
import qualified Crypto.Hash.MD5 as MD5
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Data.ByteString.Base16 as B16
import Data.Bits
import Control.Monad.Writer (tell)
import Control.Monad.Operational (singleton)
import Text.Regex.PCRE.ByteString.Utils
-- | A useful type that is used when trying to perform arithmetic on Puppet
-- numbers.
type NumberPair = S.Either (Pair Integer Integer) (Pair Double Double)
-- | A hiera helper function, that will throw all Hiera errors and log
-- messages to the main monad.
runHiera :: T.Text -> HieraQueryType -> InterpreterMonad (S.Maybe PValue)
runHiera q t = do
-- We need to merge the current scope with the top level scope
scps <- use scopes
ctx <- getScopeName
let getV scp = mapMaybe toStr $ HM.toList $ fmap (view (_1 . _1)) (scps ^. ix scp . scopeVariables)
-- we can't use _PString, because of dependency cycles
toStr (k,v) = case v of
PString x -> Just (k,x)
_ -> Nothing
toplevels = map (_1 %~ ("::" <>)) $ getV "::"
locals = getV ctx
vars = HM.fromList (toplevels <> locals)
(w :!: o) <- singleton (HieraQuery vars q t)
tell w
return o
-- | The implementation of all hiera_* functions
hieraCall :: HieraQueryType -> PValue -> (Maybe PValue) -> (Maybe PValue) -> InterpreterMonad PValue
hieraCall _ _ _ (Just _) = throwPosError "Overriding the hierarchy is not yet supported"
hieraCall qt q df _ = do
qs <- resolvePValueString q
o <- runHiera qs qt
case o of
S.Just p -> return p
S.Nothing -> case df of
Just d -> return d
Nothing -> throwPosError ("Lookup for " <> ttext qs <> " failed")
-- | Tries to convert a pair of 'PValue's into 'Number's, as defined in
-- attoparsec. If the two values can be converted, it will convert them so
-- that they are of the same type
toNumbers :: PValue -> PValue -> S.Maybe NumberPair
toNumbers (PString a) (PString b) =
let t2s = fmap scientific2Number . text2Scientific
in case t2s a :!: t2s b of
(Just (I x) :!: Just (I y)) -> S.Just (S.Left (x :!: y))
(Just (D x) :!: Just (D y)) -> S.Just (S.Right (x :!: y))
(Just (I x) :!: Just (D y)) -> S.Just (S.Right (fromIntegral x :!: y))
(Just (D x) :!: Just (I y)) -> S.Just (S.Right (x :!: fromIntegral y))
_ -> S.Nothing
toNumbers _ _ = S.Nothing
-- | This tries to run a numerical binary operation on two puppet
-- expressions. It will try to resolve them, then convert them to numbers
-- (using 'toNumbners'), and will finally apply the correct operation.
binaryOperation :: Expression -- ^ left operand
-> Expression -- ^ right operand
-> (Integer -> Integer -> Integer) -- ^ operation in case those are integers
-> (Double -> Double -> Double) -- ^ operation in case those are doubles
-> InterpreterMonad PValue
binaryOperation a b opi opd = do
ra <- resolveExpression a
rb <- resolveExpression b
case toNumbers ra rb of
S.Nothing -> throwPosError ("Expected numbers, not" <+> pretty ra <+> "or" <+> pretty rb)
S.Just (S.Right (na :!: nb)) -> return (_Double # opd na nb)
S.Just (S.Left (na :!: nb)) -> return (_Integer # opi na nb)
-- | Just like 'binaryOperation', but for operations that only work on
-- integers.
integerOperation :: Expression -> Expression -> (Integer -> Integer -> Integer) -> InterpreterMonad PValue
integerOperation a b opr = do
ra <- resolveExpression a
rb <- resolveExpression b
case toNumbers ra rb of
S.Nothing -> throwPosError ("Expected numbers, not" <+> pretty ra <+> "or" <+> pretty rb)
S.Just (S.Right _) -> throwPosError ("Expected integer values, not" <+> pretty ra <+> "or" <+> pretty rb)
S.Just (S.Left (na :!: nb)) -> return (_Integer # opr na nb)
-- | Resolves a variable, or throws an error if it can't.
resolveVariable :: T.Text -> InterpreterMonad PValue
resolveVariable fullvar = do
scps <- use scopes
scp <- getScopeName
case getVariable scps scp fullvar of
Left rr -> throwPosError rr
Right x -> return x
-- | A simple helper that checks if a given type is native or a define.
isNativeType :: T.Text -> InterpreterMonad Bool
isNativeType t = has (ix t) `fmap` (singleton GetNativeTypes)
-- | A pure function for resolving variables.
getVariable :: Container ScopeInformation -- ^ The whole scope data.
-> T.Text -- ^ Current scope name.
-> T.Text -- ^ Full variable name.
-> Either Doc PValue
getVariable scps scp fullvar = do
(varscope, varname) <- case T.splitOn "::" fullvar of
[] -> throwError "This doesn't make any sense in resolveVariable"
[vn] -> return (scp, vn) -- Non qualified variables
rst -> return (T.intercalate "::" (filter (not . T.null) (init rst)), last rst) -- qualified variables
let extractVariable (varval :!: _ :!: _) = return varval
case scps ^? ix varscope . scopeVariables . ix varname of
Just pp -> extractVariable pp
Nothing -> -- check top level scope
case scps ^? ix "::" . scopeVariables . ix varname of
Just pp -> extractVariable pp
Nothing -> throwError ("Could not resolve variable" <+> pretty (UVariableReference fullvar) <+> "in context" <+> ttext varscope <+> "or root")
-- | A helper for numerical comparison functions.
numberCompare :: Expression -> Expression -> (Integer -> Integer -> Bool) -> (Double -> Double -> Bool) -> InterpreterMonad PValue
numberCompare a b compi compd = do
ra <- resolveExpression a
rb <- resolveExpression b
case toNumbers ra rb of
S.Nothing -> throwPosError ("Comparison functions expect numbers, not:" <+> pretty ra <+> comma <+> pretty rb)
S.Just (S.Right (na :!: nb)) -> return (PBoolean (compd na nb))
S.Just (S.Left (na :!: nb)) -> return (PBoolean (compi na nb))
-- | Handles the wonders of puppet equality checks.
puppetEquality :: PValue -> PValue -> Bool
puppetEquality ra rb =
case toNumbers ra rb of
(S.Just (S.Right (na :!: nb))) -> na == nb
(S.Just (S.Left (na :!: nb))) -> na == nb
_ -> case (ra, rb) of
(PUndef , PBoolean x) -> not x
(PString "true", PBoolean x) -> x
(PString "false", PBoolean x) -> not x
(PBoolean x, PString "true") -> x
(PBoolean x, PString "false") -> not x
(PString sa, PString sb) -> mk sa == mk sb
-- TODO, check if array / hash equality should be recursed
-- for case insensitive matching
_ -> ra == rb
-- | The main resolution function : turns an 'Expression' into a 'PValue',
-- if possible.
resolveExpression :: Expression -> InterpreterMonad PValue
resolveExpression (PValue v) = resolveValue v
resolveExpression (Not e) = fmap (PBoolean . not . pValue2Bool) (resolveExpression e)
resolveExpression (And a b) = do
ra <- fmap pValue2Bool (resolveExpression a)
if ra
then do
rb <- fmap pValue2Bool (resolveExpression b)
return (PBoolean (ra && rb))
else return (PBoolean False)
resolveExpression (Or a b) = do
ra <- fmap pValue2Bool (resolveExpression a)
if ra
then return (PBoolean True)
else do
rb <- fmap pValue2Bool (resolveExpression b)
return (PBoolean (ra || rb))
resolveExpression (LessThan a b) = numberCompare a b (<) (<)
resolveExpression (MoreThan a b) = numberCompare a b (>) (>)
resolveExpression (LessEqualThan a b) = numberCompare a b (<=) (<=)
resolveExpression (MoreEqualThan a b) = numberCompare a b (>=) (>=)
resolveExpression (RegexMatch a v@(PValue (URegexp _ rv))) = do
ra <- fmap T.encodeUtf8 (resolveExpressionString a)
case execute' rv ra of
Left (_,rr) -> throwPosError ("Error when evaluating" <+> pretty v <+> ":" <+> string rr)
Right Nothing -> return $ PBoolean False
Right (Just _) -> return $ PBoolean True
resolveExpression (RegexMatch _ t) = throwPosError ("The regexp matching operator expects a regular expression, not" <+> pretty t)
resolveExpression (NotRegexMatch a v) = resolveExpression (Not (RegexMatch a v))
resolveExpression (Equal a b) = do
ra <- resolveExpression a
rb <- resolveExpression b
return $ PBoolean $ puppetEquality ra rb
resolveExpression (Different a b) = resolveExpression (Not (Equal a b))
resolveExpression (Contains idx a) =
resolveExpression a >>= \case
PHash h -> do
ridx <- resolveExpressionString idx
case h ^. at ridx of
Just _ -> return (PBoolean True)
Nothing -> return (PBoolean False)
PArray ar -> do
ridx <- resolveExpression idx
return (PBoolean (ridx `V.elem` ar))
PString st -> do
ridx <- resolveExpressionString idx
return (PBoolean (ridx `T.isInfixOf` st))
src -> throwPosError ("Can't use the 'in' operator with" <+> pretty src)
resolveExpression (Lookup a idx) =
resolveExpression a >>= \case
PHash h -> do
ridx <- resolveExpressionString idx
case h ^. at ridx of
Just v -> return v
Nothing -> throwPosError ("Can't find index '" <> ttext ridx <> "' in" <+> pretty (PHash h))
PArray ar -> do
ridx <- resolveExpression idx
i <- case ridx ^? _Integer of
Just n -> return (fromIntegral n)
_ -> throwPosError ("Need an integral number for indexing an array, not" <+> pretty ridx)
let arl = V.length ar
if arl <= i
then throwPosError ("Out of bound indexing, array size is" <+> int arl <+> "index is" <+> int i)
else return (ar V.! i)
src -> throwPosError ("This data can't be indexed:" <+> pretty src)
resolveExpression stmt@(ConditionalValue e conds) = do
rese <- resolveExpression e
let checkCond [] = throwPosError ("The selector didn't match anything for input" <+> pretty rese </> pretty stmt)
checkCond ((SelectorDefault :!: ce) : _) = resolveExpression ce
checkCond ((SelectorValue v@(URegexp _ rg) :!: ce) : xs) = do
rs <- fmap T.encodeUtf8 (resolvePValueString rese)
case execute' rg rs of
Left (_,rr) -> throwPosError ("Could not match" <+> pretty v <+> ":" <+> string rr)
Right Nothing -> checkCond xs
Right (Just _) -> resolveExpression ce
checkCond ((SelectorValue uv :!: ce) : xs) = do
rv <- resolveValue uv
if puppetEquality rese rv
then resolveExpression ce
else checkCond xs
checkCond (V.toList conds)
resolveExpression (Addition a b) = binaryOperation a b (+) (+)
resolveExpression (Substraction a b) = binaryOperation a b (-) (-)
resolveExpression (Division a b) = binaryOperation a b div (/)
resolveExpression (Multiplication a b) = binaryOperation a b (*) (*)
resolveExpression (Modulo a b) = integerOperation a b mod
resolveExpression (RightShift a b) = integerOperation a b (\x -> shiftR x . fromIntegral)
resolveExpression (LeftShift a b) = integerOperation a b (\x -> shiftL x . fromIntegral)
resolveExpression a@(FunctionApplication e (PValue (UHFunctionCall hf))) = do
unless (S.isNothing (hf ^. hfexpr)) (throwPosError ("You can't combine chains of higher order functions (with .) and giving them parameters, in:" <+> pretty a))
resolveValue (UHFunctionCall (hf & hfexpr .~ S.Just e))
resolveExpression (FunctionApplication _ x) = throwPosError ("Expected function application here, not" <+> pretty x)
resolveExpression x = throwPosError ("Don't know how to resolve this expression:" <$> pretty x)
-- | Resolves an 'UValue' (terminal for the 'Expression' data type) into
-- a 'PValue'
resolveValue :: UValue -> InterpreterMonad PValue
resolveValue n@(URegexp _ _) = throwPosError ("Regular expressions are not allowed in this context: " <+> pretty n)
resolveValue (UBoolean x) = return (PBoolean x)
resolveValue (UString x) = return (PString x)
resolveValue UUndef = return PUndef
resolveValue (UInterpolable vals) = fmap (PString . mconcat) (mapM resolveValueString (V.toList vals))
resolveValue (UResourceReference t e) = do
r <- resolveExpressionStrings e
case r of
[s] -> return (PResourceReference t s)
_ -> return (PArray (V.fromList (map (\s -> PResourceReference t s) r)))
resolveValue (UArray a) = fmap PArray (V.mapM resolveExpression a)
resolveValue (UHash a) = fmap (PHash . HM.fromList) (mapM resPair (V.toList a))
where
resPair (k :!: v) = (,) `fmap` resolveExpressionString k <*> resolveExpression v
resolveValue (UVariableReference v) = resolveVariable v
resolveValue (UFunctionCall fname args) = resolveFunction fname args
resolveValue (UHFunctionCall hf) = evaluateHFCPure hf
-- | Turns strings and booleans into 'T.Text', or throws an error.
resolvePValueString :: PValue -> InterpreterMonad T.Text
resolvePValueString (PString x) = return x
resolvePValueString (PBoolean True) = return "true"
resolvePValueString (PBoolean False) = return "false"
resolvePValueString x = throwPosError ("Don't know how to convert this to a string:" <$> pretty x)
-- | > resolveValueString = resolveValue >=> resolvePValueString
resolveValueString :: UValue -> InterpreterMonad T.Text
resolveValueString = resolveValue >=> resolvePValueString
-- | > resolveExpressionString = resolveExpression >=> resolvePValueString
resolveExpressionString :: Expression -> InterpreterMonad T.Text
resolveExpressionString = resolveExpression >=> resolvePValueString
-- | Just like 'resolveExpressionString', but accepts arrays.
resolveExpressionStrings :: Expression -> InterpreterMonad [T.Text]
resolveExpressionStrings x =
resolveExpression x >>= \case
PArray a -> mapM resolvePValueString (V.toList a)
y -> fmap return (resolvePValueString y)
-- | A special helper function for argument like argument like pairs.
resolveArgument :: Pair T.Text Expression -> InterpreterMonad (Pair T.Text PValue)
resolveArgument (argname :!: argval) = (:!:) `fmap` pure argname <*> resolveExpression argval
-- | Turns a 'PValue' into a 'Bool', as explained in the reference
-- documentation.
pValue2Bool :: PValue -> Bool
pValue2Bool PUndef = False
pValue2Bool (PString "") = False
pValue2Bool (PBoolean x) = x
pValue2Bool _ = True
-- | This resolve function calls at the expression level.
resolveFunction :: T.Text -> V.Vector Expression -> InterpreterMonad PValue
resolveFunction "fqdn_rand" args = do
let nbargs = V.length args
when (nbargs < 1 || nbargs > 2) (throwPosError "fqdn_rand(): Expects one or two arguments")
fqdn <- resolveVariable "::fqdn" >>= resolvePValueString
(mx:targs) <- mapM resolveExpressionString (V.toList args)
curmax <- case PString mx ^? _Integer of
Just x -> return x
_ -> throwPosError ("fqdn_rand(): the first argument must be an integer, not" <+> ttext mx)
let rargs = if null targs
then [fqdn, ""]
else fqdn : targs
val = fromIntegral (Prelude.fst (limitedRand (randInit myhash) (fromIntegral curmax)))
myhash = toint (MD5.hash (T.encodeUtf8 fullstring)) :: Integer
toint = BS.foldl' (\c nx -> c*256 + fromIntegral nx) 0
fullstring = T.intercalate ":" rargs
return (_Integer # val)
resolveFunction fname args = mapM resolveExpression (V.toList args) >>= resolveFunction' fname . map undefEmptyString
where
undefEmptyString PUndef = PString ""
undefEmptyString x = x
resolveFunction' :: T.Text -> [PValue] -> InterpreterMonad PValue
resolveFunction' "defined" [PResourceReference rt rn] = fmap (PBoolean . has (ix (RIdentifier rt rn))) (use definedResources)
resolveFunction' "defined" [ut] = do
t <- resolvePValueString ut
-- case 1, netsted thingie
nestedStuff <- use nestedDeclarations
if (has (ix (TopDefine, t)) nestedStuff) || (has (ix (TopClass, t)) nestedStuff)
then return (PBoolean True)
else do -- case 2, loadeded class
lc <- use loadedClasses
if has (ix t) lc
then return (PBoolean True)
else fmap PBoolean (isNativeType t)
resolveFunction' "defined" x = throwPosError ("defined(): expects a single resource reference, type or class name, and not" <+> pretty x)
resolveFunction' "fail" x = throwPosError ("fail:" <+> pretty x)
resolveFunction' "inline_template" [templatename] = calcTemplate Left templatename
resolveFunction' "inline_template" _ = throwPosError "inline_template(): Expects a single argument"
resolveFunction' "md5" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . MD5.hash . T.encodeUtf8) (resolvePValueString pstr)
resolveFunction' "md5" _ = throwPosError "md5(): Expects a single argument"
resolveFunction' "regsubst" [ptarget, pregexp, preplacement] = resolveFunction' "regsubst" [ptarget, pregexp, preplacement, PString "G"]
resolveFunction' "regsubst" [ptarget, pregexp, preplacement, pflags] = do
-- TODO handle all the flags
-- http://docs.puppetlabs.com/references/latest/function.html#regsubst
when (pflags /= "G") (use curPos >>= \p -> warn ("regsubst(): Currently only supports a single flag (G) " <> showPos (S.fst p)))
target <- fmap T.encodeUtf8 (resolvePValueString ptarget)
regexp <- fmap T.encodeUtf8 (resolvePValueString pregexp)
replacement <- fmap T.encodeUtf8 (resolvePValueString preplacement)
case substituteCompile' regexp target replacement of
Left rr -> throwPosError ("regsubst():" <+> string rr)
Right x -> fmap PString (safeDecodeUtf8 x)
resolveFunction' "regsubst" _ = throwPosError "regsubst(): Expects 3 or 4 arguments"
resolveFunction' "split" [psrc, psplt] = do
src <- fmap T.encodeUtf8 (resolvePValueString psrc)
splt <- fmap T.encodeUtf8 (resolvePValueString psplt)
case splitCompile' splt src of
Left rr -> throwPosError ("splitCompile():" <+> string rr)
Right x -> fmap (PArray . V.fromList) (mapM (fmap PString . safeDecodeUtf8) x)
resolveFunction' "sha1" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . SHA1.hash . T.encodeUtf8) (resolvePValueString pstr)
resolveFunction' "sha1" _ = throwPosError "sha1(): Expects a single argument"
resolveFunction' "mysql_password" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . SHA1.hash . SHA1.hash . T.encodeUtf8) (resolvePValueString pstr)
resolveFunction' "mysql_password" _ = throwPosError "mysql_password(): Expects a single argument"
resolveFunction' "file" args = mapM resolvePValueString args >>= fmap PString . singleton . ReadFile
resolveFunction' "tagged" ptags = do
tags <- fmap HS.fromList (mapM resolvePValueString ptags)
scp <- getScopeName
scpset <- use (scopes . ix scp . scopeExtraTags)
return (PBoolean (scpset `HS.intersection` tags == tags))
resolveFunction' "template" [templatename] = calcTemplate Right templatename
resolveFunction' "template" _ = throwPosError "template(): Expects a single argument"
resolveFunction' "versioncmp" [pa,pb] = do
a <- resolvePValueString pa
b <- resolvePValueString pb
let parser x = case filter (null . Prelude.snd) (readP_to_S parseVersion (T.unpack x)) of
( (v, _) : _ ) -> return v
_ -> throwPosError ("Could not parse this string as a version:" <+> ttext x)
va <- parser a
vb <- parser b
return $ PString $ case compare va vb of
EQ -> "0"
LT -> "-1"
GT -> "1"
resolveFunction' "versioncmp" _ = throwPosError "versioncmp(): Expects two arguments"
-- some custom functions
resolveFunction' "pdbresourcequery" [q] = pdbresourcequery q Nothing
resolveFunction' "pdbresourcequery" [q,k] = fmap Just (resolvePValueString k) >>= pdbresourcequery q
resolveFunction' "pdbresourcequery" _ = throwPosError "pdbresourcequery(): Expects one or two arguments"
resolveFunction' "hiera" [q] = hieraCall Priority q Nothing Nothing
resolveFunction' "hiera" [q,d] = hieraCall Priority q (Just d) Nothing
resolveFunction' "hiera" [q,d,o] = hieraCall Priority q (Just d) (Just o)
resolveFunction' "hiera_array" [q] = hieraCall ArrayMerge q Nothing Nothing
resolveFunction' "hiera_array" [q,d] = hieraCall ArrayMerge q (Just d) Nothing
resolveFunction' "hiera_array" [q,d,o] = hieraCall ArrayMerge q (Just d) (Just o)
resolveFunction' "hiera_hash" [q] = hieraCall HashMerge q Nothing Nothing
resolveFunction' "hiera_hash" [q,d] = hieraCall HashMerge q (Just d) Nothing
resolveFunction' "hiera_hash" [q,d,o] = hieraCall HashMerge q (Just d) (Just o)
resolveFunction' "hiera" _ = throwPosError "hiera(): Expects one, two or three arguments"
-- user functions
resolveFunction' fname args = singleton (ExternalFunction fname args)
pdbresourcequery :: PValue -> Maybe T.Text -> InterpreterMonad PValue
pdbresourcequery q mkey = do
rrv <- case fromJSON (toJSON q) of
Success rq -> singleton (PDBGetResources rq)
Error rr -> throwPosError ("Invalid resource query:" <+> Puppet.PP.string rr)
rv <- case fromJSON (toJSON rrv) of
Success x -> return x
Error rr -> throwPosError ("For some reason we could not convert a resource list to Puppet internal values!!" <+> Puppet.PP.string rr <+> pretty rrv)
let extractSubHash :: T.Text -> PValue -> InterpreterMonad PValue
extractSubHash ky (PHash h) = case h ^. at ky of
Just val -> return val
Nothing -> throwPosError ("pdbresourcequery strange error, could not find key" <+> ttext ky <+> "in" <+> pretty (PHash h))
extractSubHash _ x = throwPosError ("pdbresourcequery strange error, expected a hash, had" <+> pretty x)
case mkey of
Nothing -> return (PArray rv)
(Just k) -> fmap PArray (V.mapM (extractSubHash k) rv)
calcTemplate :: (T.Text -> Either T.Text T.Text) -> PValue -> InterpreterMonad PValue
calcTemplate templatetype templatename = do
fname <- resolvePValueString templatename
classes <- (PArray . V.fromList . map PString . HM.keys) `fmap` use loadedClasses
scp <- getScopeName
scps <- use scopes
-- inject the special template variables (just classes for now)
let cd = fromMaybe ContRoot (scps ^? ix scp . scopeContainer . cctype) -- get the current containder description
-- Inject the classes variable. Note that we are relying on the
-- invariant that the scope is already entered, and hence present
-- in the scps container.
cscps = scps & ix scp . scopeVariables . at "classes" ?~ ( classes :!: initialPPos "dummy" :!: cd )
PString `fmap` singleton (ComputeTemplate (templatetype fname) scp cscps)
resolveExpressionSE :: Expression -> InterpreterMonad PValue
resolveExpressionSE e = resolveExpression e >>=
\case
PArray _ -> throwPosError "The use of an array in a search expression is undefined"
PHash _ -> throwPosError "The use of an array in a search expression is undefined"
resolved -> return resolved
-- | Turns an unresolved 'SearchExpression' from the parser into a fully
-- resolved 'RSearchExpression'.
resolveSearchExpression :: SearchExpression -> InterpreterMonad RSearchExpression
resolveSearchExpression AlwaysTrue = return RAlwaysTrue
resolveSearchExpression (EqualitySearch a e) = REqualitySearch `fmap` pure a <*> resolveExpressionSE e
resolveSearchExpression (NonEqualitySearch a e) = RNonEqualitySearch `fmap` pure a <*> resolveExpressionSE e
resolveSearchExpression (AndSearch e1 e2) = RAndSearch `fmap` resolveSearchExpression e1 <*> resolveSearchExpression e2
resolveSearchExpression (OrSearch e1 e2) = ROrSearch `fmap` resolveSearchExpression e1 <*> resolveSearchExpression e2
-- | Turns a resource type and 'RSearchExpression' into something that can
-- be used in a PuppetDB query.
searchExpressionToPuppetDB :: T.Text -> RSearchExpression -> Query ResourceField
searchExpressionToPuppetDB rtype res = QAnd ( QEqual RType (capitalizeRT rtype) : mkSE res )
where
mkSE (RAndSearch a b) = [QAnd (mkSE a ++ mkSE b)]
mkSE (ROrSearch a b) = [QOr (mkSE a ++ mkSE b)]
mkSE (RNonEqualitySearch a b) = fmap QNot (mkSE (REqualitySearch a b))
mkSE (REqualitySearch a (PString b)) = [QEqual (mkFld a) b]
mkSE _ = []
mkFld "tag" = RTag
mkFld "title" = RTitle
mkFld z = RParameter z
-- | Checks whether a given 'Resource' matches a 'RSearchExpression'. Note
-- that the expression doesn't check for type, so you must filter the
-- resources by type beforehand, if needs be.
checkSearchExpression :: RSearchExpression -> Resource -> Bool
checkSearchExpression RAlwaysTrue _ = True
checkSearchExpression (RAndSearch a b) r = checkSearchExpression a r && checkSearchExpression b r
checkSearchExpression (ROrSearch a b) r = checkSearchExpression a r || checkSearchExpression b r
checkSearchExpression (RNonEqualitySearch a b) r = not (checkSearchExpression (REqualitySearch a b) r)
checkSearchExpression (REqualitySearch "tag" (PString s)) r = r ^. rtags . contains s
checkSearchExpression (REqualitySearch "tag" _) _ = False
checkSearchExpression (REqualitySearch "title" v) r =
let nameequal = puppetEquality v (PString (r ^. rid . iname))
aliasequal = case r ^. rattributes . at "alias" of
Just a -> puppetEquality v a
Nothing -> False
in nameequal || aliasequal
checkSearchExpression (REqualitySearch attributename v) r = case r ^. rattributes . at attributename of
Nothing -> False
Just x -> puppetEquality x v
-- | Generates variable associations for evaluation of blocks. Each item
-- corresponds to an iteration in the calling block.
hfGenerateAssociations :: HFunctionCall -> InterpreterMonad [[(T.Text, PValue)]]
hfGenerateAssociations hf = do
sourceexpression <- case hf ^. hfexpr of
S.Just x -> return x
S.Nothing -> throwPosError ("No expression to run the function on" <+> pretty hf)
sourcevalue <- resolveExpression sourceexpression
case (sourcevalue, hf ^. hfparams) of
(PArray pr, BPSingle varname) -> return (map (\x -> [(varname, x)]) (V.toList pr))
(PArray pr, BPPair idx var) -> return $ do
(i,v) <- Prelude.zip ([0..] :: [Int]) (V.toList pr)
return [(idx,PString (T.pack (show i))),(var,v)]
(PHash hh, BPSingle varname) -> return $ do
(k,v) <- HM.toList hh
return [(varname, PArray (V.fromList [PString k,v]))]
(PHash hh, BPPair idx var) -> return $ do
(k,v) <- HM.toList hh
return [(idx,PString k),(var,v)]
(invalid, _) -> throwPosError ("Can't iterate on this data type:" <+> pretty invalid)
-- | Sets the proper variables, and returns the scope variables the way
-- they were before being modified. This is a hack that ensures that
-- variables are local to the new scope.
--
-- It doesn't work at all like other Puppet parts, but consistency isn't
-- really expected here ...
hfSetvars :: [(T.Text, PValue)] -> InterpreterMonad (Container (Pair (Pair PValue PPosition) CurContainerDesc))
hfSetvars vals =
do
scp <- getScopeName
p <- use curPos
container <- getCurContainer
save <- use (scopes . ix scp . scopeVariables)
let hfSetvar (varname, varval) = scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: (container ^. cctype))
mapM_ hfSetvar vals
return save
-- | Restores what needs restoring. This will erase all allocations.
hfRestorevars :: Container (Pair (Pair PValue PPosition) CurContainerDesc) -> InterpreterMonad ()
hfRestorevars save =
do
scp <- getScopeName
scopes . ix scp . scopeVariables .= save
-- | Evaluates a statement in "pure" mode. TODO
evalPureStatement :: Statement -> InterpreterMonad ()
evalPureStatement _ = throwPosError "So called 'pure' statements are not yet supported"
-- | This extracts the final expression from an HFunctionCall.
-- When it does not exists, it checks if the last statement is in fact
-- a function call
transformPureHf :: HFunctionCall -> InterpreterMonad (HFunctionCall, Expression)
transformPureHf hf =
case hf ^. hfexpression of
S.Just x -> return (hf, x)
S.Nothing -> do
let statements = hf ^. hfstatements
if V.null statements
then throwPosError ("The statement block must not be empty" <+> pretty hf)
else case V.last statements of
(MainFunctionCall fn args _) ->
let expr = PValue (UFunctionCall fn args)
in return (hf & hfstatements %~ V.init
& hfexpression .~ S.Just expr
, expr)
_ -> throwPosError ("The statement block must end with an expression" <+> pretty hf)
-- | All the "higher order function" stuff, for "value" mode. In this case
-- we are in "pure" mode, and only a few statements are allowed.
evaluateHFCPure :: HFunctionCall -> InterpreterMonad PValue
evaluateHFCPure hf' = do
(hf, finalexpression) <- transformPureHf hf'
varassocs <- hfGenerateAssociations hf
let runblock :: [(T.Text, PValue)] -> InterpreterMonad PValue
runblock assocs = do
saved <- hfSetvars assocs
V.mapM_ evalPureStatement (hf ^. hfstatements)
r <- resolveExpression finalexpression
hfRestorevars saved
return r
case hf ^. hftype of
HFEach -> throwPosError "The 'each' function can't be used at the value level in language-puppet. Please use map."
HFMap -> fmap (PArray . V.fromList) (mapM runblock varassocs)
HFFilter -> do
res <- mapM (fmap pValue2Bool . runblock) varassocs
sourcevalue <- case hf ^. hfexpr of
S.Just x -> resolveExpression x
S.Nothing -> throwPosError "Internal error evaluateHFCPure 1"
case sourcevalue of
PArray ar -> return $ PArray $ V.map Prelude.fst $ V.filter Prelude.snd $ V.zip ar (V.fromList res)
PHash hh -> return $ PHash $ HM.fromList $ map Prelude.fst $ filter Prelude.snd $ Prelude.zip (HM.toList hh) res
x -> throwPosError ("Can't iterate on this data type:" <+> pretty x)
x -> throwPosError ("This type of function is not supported yet by language-puppet!" <+> pretty x)