language-puppet-1.3.8: Puppet/Interpreter/Resolve.hs
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
-- | 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,
resolvePValueNumber,
resolveExpressionString,
resolveExpressionStrings,
resolveFunction',
runHiera,
isNativeType,
-- * Search expression management
resolveSearchExpression,
checkSearchExpression,
searchExpressionToPuppetDB,
-- * Higher order puppet functions handling
hfGenerateAssociations,
hfSetvars,
hfRestorevars,
toNumbers,
fixResourceName,
datatypeMatch
) where
import Control.Lens
import Control.Monad
import Control.Monad.Operational (singleton)
import Crypto.Hash
import Data.Aeson hiding ((.=))
import Data.Aeson.Lens hiding (key)
import Data.Bits
import Data.ByteArray (convert)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import Data.CaseInsensitive (mk)
import Data.Char (isAlphaNum)
import qualified Data.Foldable as F
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (fromMaybe, mapMaybe, catMaybes)
import qualified Data.Maybe.Strict as S
import Data.Scientific
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Tuple.Strict as S
import qualified Data.Vector as V
import Data.Version (Version (..), parseVersion)
import Text.ParserCombinators.ReadP (readP_to_S)
import qualified Text.PrettyPrint.ANSI.Leijen as PP
import Text.Regex.PCRE.ByteString.Utils
import Puppet.Interpreter.PrettyPrinter ()
import Puppet.Interpreter.RubyRandom
import Puppet.Interpreter.Types
import Puppet.Interpreter.Utils
import Puppet.Interpreter.Resolve.Sprintf (sprintf)
import Puppet.Parser.Types
import Puppet.Paths
import Puppet.PP
import Puppet.Utils
sha1 :: ByteString -> ByteString
sha1 = convert . (hash :: ByteString -> Digest SHA1)
md5 :: ByteString -> ByteString
md5 = convert . (hash :: ByteString -> Digest MD5)
-- | A useful type that is used when trying to perform arithmetic on Puppet
-- numbers.
type NumberPair = Pair Scientific Scientific
-- | Converts class resource names to lowercase (fix for the jenkins
-- plugin).
fixResourceName :: T.Text -- ^ Resource type
-> T.Text -- ^ Resource name
-> T.Text
fixResourceName "class" x = T.toLower $ fromMaybe x $ T.stripPrefix "::" x
fixResourceName _ x = x
-- | A hiera helper function, that will throw all Hiera errors and log
-- messages to the main monad.
runHiera :: T.Text -> HieraQueryType -> InterpreterMonad (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)
singleton (HieraQuery vars q t)
-- | 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
Just p -> return p
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) 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
-- | 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
-> (Scientific -> Scientific -> Scientific) -- ^ operation
-> InterpreterMonad PValue
binaryOperation a b opr = ((PNumber .) . opr) `fmap` resolveExpressionNumber a <*> resolveExpressionNumber b
-- 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 <- 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))
-- | 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
[] -> Left "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 -> Left ("Could not resolve variable" <+> pretty (UVariableReference fullvar) <+> "in context" <+> ttext varscope <+> "or root")
-- | A helper for numerical comparison functions.
numberCompare :: Expression -> Expression -> (Scientific -> Scientific -> Bool) -> InterpreterMonad PValue
numberCompare a b comp = ((PBoolean .) . comp) `fmap` resolveExpressionNumber a <*> resolveExpressionNumber b
-- | Handles the wonders of puppet equality checks.
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
-- 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 (Terminal 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@(Terminal (URegexp (CompRegex _ 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 matches) -> do
-- A bit of logic to save the capture variables.
-- Note that this will pollute the namespace, as it should only
-- happen in conditional expressions ...
p <- use curPos
ctype <- view cctype <$> getCurContainer
let captures = Prelude.zip (map (T.pack . show) [(0 :: Int)..]) (map mkMatch (F.toList matches))
mkMatch (offset, len) = PString (T.decodeUtf8 (BS.take len (BS.drop offset ra))) :!: p :!: ctype
scp <- getScopeName
scopes . ix scp . scopeVariables %= HM.union (HM.fromList captures)
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 -> do
checkStrict
("Look up for an hash with the unknown key '" <> ttext ridx <> "' for" <+> pretty (PHash h))
("Can't find index '" <> ttext ridx <> "' in" <+> pretty (PHash h))
return PUndef
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 (CompRegex _ 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 ((SelectorType dt :!: ce) : xs) = if datatypeMatch dt rese
then resolveExpression ce
else checkCond xs
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 (Terminal (UHOLambdaCall hol))) = do
unless (S.isNothing (hol ^. hoLambdaExpr)) (throwPosError ("You can't combine chains of higher order functions (with .) and giving them parameters, in:" <+> pretty a))
resolveValue (UHOLambdaCall (hol & hoLambdaExpr .~ S.Just e))
resolveExpression (FunctionApplication _ x) = throwPosError ("Expected function application here, not" <+> pretty x)
resolveExpression (Negate x) = PNumber . negate <$> resolveExpressionNumber x
-- | Resolves an 'UnresolvedValue' (terminal for the 'Expression' data type) into
-- a 'PValue'
resolveValue :: UnresolvedValue -> 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 resolveExpressionString (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 (UHOLambdaCall hol) = evaluateHFCPure hol
-- | Turns strings, numbers 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 (PNumber x) = return (scientific2text x)
resolvePValueString PUndef = do
checkStrict
"Resolving the keyword `undef` to the string \"undef\""
"Strict mode won't convert the keyword `undef` to the string \"undef\""
return "undef"
resolvePValueString x = throwPosError ("Don't know how to convert this to a string:" PP.<$> pretty x)
-- | Turns everything it can into a number, or throws an error
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:" PP.<$> pretty x)
-- | > resolveExpressionString = resolveExpression >=> resolvePValueString
resolveExpressionString :: Expression -> InterpreterMonad T.Text
resolveExpressionString = resolveExpression >=> resolvePValueString
-- | > resolveExpressionNumber = resolveExpression >=> resolvePValueNumber
resolveExpressionNumber :: Expression -> InterpreterMonad Scientific
resolveExpressionNumber = resolveExpression >=> resolvePValueNumber
-- | 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)
-- | 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 (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] = do
checkStrict "The use of the 'defined' function is a code smell"
"The 'defined' function is not allowed in strict mode."
fmap (PBoolean . has (ix cn)) (use loadedClasses)
resolveFunction' "defined" [PResourceReference rt rn] = do
checkStrict "The use of the 'defined' function is a code smell"
"The 'defined' function is not allowed in strict mode."
fmap (PBoolean . has (ix (RIdentifier rt rn))) (use definedResources)
resolveFunction' "defined" [ut] = do
checkStrict "The use of the 'defined' function is a code smell."
"The 'defined' function is not allowed in strict mode."
t <- resolvePValueString ut
if (not (T.null t) && T.head t == '$') -- variable test
then do
scps <- use scopes
scp <- getScopeName
return $ PBoolean $ case getVariable scps scp (T.tail t) of
Left _ -> False
Right _ -> True
else do -- resource test
-- case 1, nested thingie
nestedStuff <- use nestedDeclarations
if has (ix (TopDefine, t)) nestedStuff || has (ix (TopClass, t)) nestedStuff
then return (PBoolean True)
else do -- case 2, loaded 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" [] = throwPosError "inline_template(): Expects at least one argument"
resolveFunction' "inline_template" templates = PString . mconcat <$> mapM (calcTemplate Left) templates
resolveFunction' "md5" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . md5 . 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)))
regexp <- fmap T.encodeUtf8 (resolvePValueString pregexp)
replacement <- fmap T.encodeUtf8 (resolvePValueString preplacement)
let sub t = do
t' <- fmap T.encodeUtf8 (resolvePValueString t)
case substituteCompile' regexp t' replacement of
Left rr -> throwPosError ("regsubst():" <+> string rr)
Right x -> fmap PString (safeDecodeUtf8 x)
case ptarget of
PArray a -> fmap PArray (traverse sub a)
s -> sub s
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 . T.encodeUtf8) (resolvePValueString pstr)
resolveFunction' "sha1" _ = throwPosError "sha1(): Expects a single argument"
resolveFunction' "shellquote" args = do
sargs <- forM args $ \arg -> case arg of
PArray vals -> mapM resolvePValueString vals
_ -> V.singleton <$> resolvePValueString arg
let escape str | T.all isSafe str = str
| not (T.any isDangerous str) = between "\"" str
| T.any (== '\'') str = between "\"" (T.concatMap escapeDangerous str)
| otherwise = between "'" str
isSafe x = isAlphaNum x || x `elem` ("@%_+=:,./-" :: String)
isDangerous x = x `elem` ("!\"`$\\" :: String)
escapeDangerous x | isDangerous x = T.snoc "\\" x
| otherwise = T.singleton x
between c s = c <> s <> c
return $ PString $ T.unwords $ V.toList $ fmap escape $ mconcat sargs
resolveFunction' "mysql_password" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . sha1 . sha1 . T.encodeUtf8) (resolvePValueString pstr)
resolveFunction' "mysql_password" _ = throwPosError "mysql_password(): Expects a single argument"
resolveFunction' "file" args = mapM (resolvePValueString >=> fixFilePath) args >>= fmap PString . singleton . ReadFile
where
fixFilePath s | T.null s = let rr = "Empty file path passed to the 'file' function" in checkStrict rr rr >> return s
| T.head s == '/' = return s
| otherwise = case T.splitOn "/" s of
(md:x:rst) -> do
moduledir <- view modulesPath <$> getPuppetPaths
return (T.intercalate "/" (T.pack moduledir : md : "files" : x : rst))
_ -> throwPosError ("file() argument invalid: " <> ttext s)
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" [] = throwPosError "template(): Expects at least one argument"
resolveFunction' "template" templates = PString . mconcat <$> mapM (calcTemplate Right) templates
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, _) : _ ) -> v
_ -> Version [] [] -- fallback :(
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"
-- | Simplified implementation of sprintf
resolveFunction' "sprintf" (PString str:args) = sprintf str args
resolveFunction' "sprintf" _ = throwPosError "sprintf(): Expects a string as its first argument"
-- 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 T.Text
calcTemplate templatetype templatename = do
fname <- resolvePValueString templatename
stt <- use id
singleton (ComputeTemplate (templatetype fname) stt)
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 (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 (PArray x) -> F.any (flip puppetEquality v) x
Just x -> puppetEquality x v
checkSearchExpression (RNonEqualitySearch attributename v) r
| attributename == "tag" = True
| attributename == "title" = not (checkSearchExpression (REqualitySearch attributename v) r)
| otherwise = case r ^. rattributes . at attributename of
Nothing -> True
Just (PArray x) -> not (F.all (flip puppetEquality v) x)
Just x -> not (puppetEquality x v)
-- | Generates variable associations for evaluation of blocks. Each item
-- corresponds to an iteration in the calling block.
hfGenerateAssociations :: HOLambdaCall -> InterpreterMonad [[(T.Text, PValue)]]
hfGenerateAssociations hol = do
sourceexpression <- case hol ^. hoLambdaExpr of
S.Just x -> return x
S.Nothing -> throwPosError ("No expression to run the function on" <+> pretty hol)
sourcevalue <- resolveExpression sourceexpression
case (sourcevalue, hol ^. hoLambdaParams) 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 HOLambdaCall.
-- When it does not exists, it checks if the last statement is in fact
-- a function call
transformPureHf :: HOLambdaCall -> InterpreterMonad (HOLambdaCall, Expression)
transformPureHf hol =
case hol ^. hoLambdaLastExpr of
S.Just x -> return (hol, x)
S.Nothing -> do
let statements = hol ^. hoLambdaStatements
if V.null statements
then throwPosError ("The statement block must not be empty" <+> pretty hol)
else case V.last statements of
(MainFunctionDeclaration (MainFuncDecl fn args _)) ->
let expr = Terminal (UFunctionCall fn args)
in return (hol & hoLambdaStatements %~ V.init
& hoLambdaLastExpr .~ S.Just expr
, expr)
_ -> throwPosError ("The statement block must end with an expression" <+> pretty hol)
-- | 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 :: HOLambdaCall -> InterpreterMonad PValue
evaluateHFCPure hol' = do
(hol, finalexpression) <- transformPureHf hol'
varassocs <- hfGenerateAssociations hol
let runblock :: [(T.Text, PValue)] -> InterpreterMonad PValue
runblock assocs = do
saved <- hfSetvars assocs
V.mapM_ evalPureStatement (hol ^. hoLambdaStatements)
r <- resolveExpression finalexpression
hfRestorevars saved
return r
case hol ^. hoLambdaFunc of
LambEach -> throwPosError "The 'each' function can't be used at the value level in language-puppet. Please use map."
LambMap -> fmap (PArray . V.fromList) (mapM runblock varassocs)
LambFilter -> do
res <- mapM (fmap pValue2Bool . runblock) varassocs
sourcevalue <- case hol ^. hoLambdaExpr 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)
-- | Checks that a value matches a puppet datatype
datatypeMatch :: DataType -> PValue -> Bool
datatypeMatch dt v
= case dt of
DTType -> has _PType v
DTUndef -> v == PUndef
NotUndef -> v /= PUndef
DTString mmin mmax -> boundedBy _PString T.length mmin mmax
DTInteger mmin mmax -> boundedBy (_PNumber . to toBoundedInteger . _Just) id mmin mmax
DTFloat mmin mmax -> boundedBy _PNumber toRealFloat mmin mmax
DTBoolean -> has _PBoolean v
DTArray sdt mi mmx -> container (_PArray . to V.toList) (datatypeMatch sdt) mi mmx
DTHash kt sdt mi mmx -> container (_PHash . to itoList) (\(k,a) -> datatypeMatch kt (PString k) && datatypeMatch sdt a) mi mmx
DTScalar -> datatypeMatch (DTVariant (DTInteger Nothing Nothing :| [DTString Nothing Nothing, DTBoolean])) v
DTData -> datatypeMatch (DTVariant (DTScalar :| [DTArray DTData 0 Nothing, DTHash DTScalar DTData 0 Nothing])) v
DTOptional sdt -> datatypeMatch (DTVariant (DTUndef :| [sdt])) v
DTVariant sdts -> any (`datatypeMatch` v) sdts
DTEnum lst -> maybe False (`elem` lst) (v ^? _PString)
DTAny -> True
DTCollection -> datatypeMatch (DTVariant (DTArray DTData 0 Nothing :| [DTHash DTScalar DTData 0 Nothing])) v
DTPattern patterns -> maybe False (\str -> any (checkPattern (T.encodeUtf8 str)) patterns) (v ^? _PString)
where
checkPattern str (CompRegex _ ptrn)
= case execute' ptrn str of
Right (Just _) -> True
_ -> False
container :: Fold PValue [a] -> (a -> Bool) -> Int -> Maybe Int -> Bool
container f c mi mmx =
let lst = v ^. f
ln = length lst
in ln >= mi && (fmap (ln <=) mmx /= Just False) && all c lst
boundedBy :: Ord b => Fold PValue a -> (a -> b) -> Maybe b -> Maybe b -> Bool
boundedBy prm f mmin mmax
= fromMaybe False $ do
vr <- f <$> v ^? prm
return $ and $ catMaybes [fmap (vr >=) mmin, fmap (vr <=) mmax]