module Puppet.Interpreter.Resolve
(
getVariable,
pValue2Bool,
resolveVariable,
resolveExpression,
resolveValue,
resolvePValueString,
resolveExpressionString,
resolveExpressionStrings,
resolveArgument,
runHiera,
isNativeType,
resolveSearchExpression,
checkSearchExpression,
searchExpressionToPuppetDB,
hfGenerateAssociations,
hfSetvars,
hfRestorevars,
toNumbers,
fixResourceName
) 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 Puppet.Utils
import Data.Version (parseVersion)
import Text.ParserCombinators.ReadP (readP_to_S)
import Data.Maybe (fromMaybe, mapMaybe)
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 Control.Applicative hiding ((<$>))
import Control.Monad
import Data.Tuple.Strict as S
import Control.Lens
import Data.Aeson.Lens hiding (key)
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
import Data.Scientific
type NumberPair = Pair Scientific Scientific
fixResourceName :: T.Text
-> T.Text
-> T.Text
fixResourceName "class" = T.toLower
fixResourceName _ = id
runHiera :: T.Text -> HieraQueryType -> InterpreterMonad (S.Maybe PValue)
runHiera q t = do
scps <- use scopes
ctx <- getScopeName
let getV scp = mapMaybe toStr $ HM.toList $ fmap (view (_1 . _1)) (scps ^. ix scp . scopeVariables)
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
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")
toNumbers :: PValue -> PValue -> S.Maybe NumberPair
toNumbers (PString a) b = case text2Scientific a of
Just na -> toNumbers (PNumber na) b
Nothing -> S.Nothing
toNumbers a (PString b) = toNumbers (PString b) a
toNumbers (PNumber a) (PNumber b) = S.Just (a :!: b)
toNumbers _ _ = S.Nothing
binaryOperation :: Expression
-> Expression
-> (Scientific -> Scientific -> Scientific)
-> InterpreterMonad PValue
binaryOperation a b opr = ((PNumber .) . opr) `fmap` resolveExpressionNumber a <*> resolveExpressionNumber b
integerOperation :: Expression -> Expression -> (Integer -> Integer -> Integer) -> InterpreterMonad PValue
integerOperation a b opr = do
ra <- resolveExpressionNumber a
rb <- resolveExpressionNumber b
case (preview _Integer ra, preview _Integer rb) of
(Just na, Just nb) -> return (PNumber $ fromIntegral (opr na nb))
_ -> throwPosError ("Expected integer values, not" <+> string (show ra) <+> "or" <+> string (show rb))
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
isNativeType :: T.Text -> InterpreterMonad Bool
isNativeType t = has (ix t) `fmap` singleton GetNativeTypes
getVariable :: Container ScopeInformation
-> T.Text
-> T.Text
-> Either Doc PValue
getVariable scps scp fullvar = do
(varscope, varname) <- case T.splitOn "::" fullvar of
[] -> Left "This doesn't make any sense in resolveVariable"
[vn] -> return (scp, vn)
rst -> return (T.intercalate "::" (filter (not . T.null) (init rst)), last rst)
let extractVariable (varval :!: _ :!: _) = return varval
case scps ^? ix varscope . scopeVariables . ix varname of
Just pp -> extractVariable pp
Nothing ->
case scps ^? ix "::" . scopeVariables . ix varname of
Just pp -> extractVariable pp
Nothing -> Left ("Could not resolve variable" <+> pretty (UVariableReference fullvar) <+> "in context" <+> ttext varscope <+> "or root")
numberCompare :: Expression -> Expression -> (Scientific -> Scientific -> Bool) -> InterpreterMonad PValue
numberCompare a b comp = ((PBoolean .) . comp) `fmap` resolveExpressionNumber a <*> resolveExpressionNumber b
puppetEquality :: PValue -> PValue -> Bool
puppetEquality ra rb =
case toNumbers ra rb of
(S.Just (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
_ -> ra == rb
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) = do
ra <- resolveExpression a
rb <- resolveExpression b
case (ra, rb) of
(PHash ha, PHash hb) -> return (PHash (ha <> hb))
(PArray ha, PArray hb) -> return (PArray (ha <> hb))
_ -> binaryOperation a b (+)
resolveExpression (Substraction a b) = binaryOperation a b ()
resolveExpression (Division a b) = do
ra <- resolveExpressionNumber a
rb <- resolveExpressionNumber b
case rb of
0 -> throwPosError "Division by 0"
_ -> case (,) `fmap` preview _Integer ra <*> preview _Integer rb of
Just (ia, ib) -> return $ PNumber $ fromIntegral (ia `div` ib)
_ -> return $ PNumber $ ra / rb
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) = do
ra <- resolveExpression a
rb <- resolveExpression b
case (ra, rb) of
(PArray ha, v) -> return (PArray (V.snoc ha v))
_ -> 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)
resolveValue :: UValue -> InterpreterMonad PValue
resolveValue (UNumber n) = return (PNumber n)
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 (fixResourceName t s))
_ -> return (PArray (V.fromList (map (PResourceReference t . fixResourceName t) 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
resolvePValueString :: PValue -> InterpreterMonad T.Text
resolvePValueString (PString x) = return x
resolvePValueString (PBoolean True) = return "true"
resolvePValueString (PBoolean False) = return "false"
resolvePValueString (PNumber x) = return (scientific2text x)
resolvePValueString x = throwPosError ("Don't know how to convert this to a string:" <$> pretty x)
resolvePValueNumber :: PValue -> InterpreterMonad Scientific
resolvePValueNumber x = case x ^? _Number of
Just n -> return n
Nothing -> throwPosError ("Don't know how to convert this to a number:" <$> pretty x)
resolveValueString :: UValue -> InterpreterMonad T.Text
resolveValueString = resolveValue >=> resolvePValueString
resolveExpressionString :: Expression -> InterpreterMonad T.Text
resolveExpressionString = resolveExpression >=> resolvePValueString
resolveExpressionNumber :: Expression -> InterpreterMonad Scientific
resolveExpressionNumber = resolveExpression >=> resolvePValueNumber
resolveExpressionStrings :: Expression -> InterpreterMonad [T.Text]
resolveExpressionStrings x =
resolveExpression x >>= \case
PArray a -> mapM resolvePValueString (V.toList a)
y -> fmap return (resolvePValueString y)
resolveArgument :: Pair T.Text Expression -> InterpreterMonad (Pair T.Text PValue)
resolveArgument (argname :!: argval) = (:!:) `fmap` pure argname <*> resolveExpression argval
pValue2Bool :: PValue -> Bool
pValue2Bool PUndef = False
pValue2Bool (PString "") = False
pValue2Bool (PBoolean x) = x
pValue2Bool _ = True
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 "class" cn] = fmap (PBoolean . has (ix cn)) (use loadedClasses)
resolveFunction' "defined" [PResourceReference rt rn] = fmap (PBoolean . has (ix (RIdentifier rt rn))) (use definedResources)
resolveFunction' "defined" [ut] = do
t <- resolvePValueString ut
nestedStuff <- use nestedDeclarations
if has (ix (TopDefine, t)) nestedStuff || has (ix (TopClass, t)) nestedStuff
then return (PBoolean True)
else do
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
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"
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"
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
let cd = fromMaybe ContRoot (scps ^? ix scp . scopeContainer . cctype)
cscps = scps & ix scp . scopeVariables . at "classes" ?~ ( classes :!: dummypos :!: 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
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
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
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
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)
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
hfRestorevars :: Container (Pair (Pair PValue PPosition) CurContainerDesc) -> InterpreterMonad ()
hfRestorevars save =
do
scp <- getScopeName
scopes . ix scp . scopeVariables .= save
evalPureStatement :: Statement -> InterpreterMonad ()
evalPureStatement _ = throwPosError "So called 'pure' statements are not yet supported"
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)
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)