{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
module Puppet.Interpreter.Resolve
(
getVariable,
pValue2Bool,
resolveVariable,
resolveExpression,
resolveValue,
resolvePValueString,
resolvePValueNumber,
resolveExpressionString,
resolveExpressionStrings,
resolveFunction',
resolveDataType,
runHiera,
isNativeType,
resolveSearchExpression,
checkSearchExpression,
searchExpressionToPuppetDB,
hfGenerateAssociations,
hfSetvars,
hfRestorevars,
fixResourceName,
datatypeMatch,
checkMatch,
typeOf
) where
import XPrelude.Extra
import XPrelude.PP
import qualified Control.Monad.Operational as Operational
import "cryptonite" Crypto.Hash
import qualified Data.Aeson as Aeson
import Data.Aeson.Lens (_Integer, _Number)
import qualified Data.ByteArray as ByteArray
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.CaseInsensitive as CaseInsensitive
import qualified Data.Char as Char
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.List as List
import qualified Data.List.NonEmpty as NE
import qualified Data.Maybe.Strict as S
import qualified Data.Scientific as Scientific
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Tuple.Strict as Tuple
import qualified Data.Vector as V
import Data.Version (Version (..), parseVersion)
import Text.ParserCombinators.ReadP (readP_to_S)
import qualified Text.Regex.PCRE.ByteString.Utils as Regex
import Hiera.Server
import Puppet.Interpreter.Helpers
import Puppet.Interpreter.PrettyPrinter ()
import Puppet.Interpreter.Resolve.Sprintf (sprintf)
import Puppet.Interpreter.RubyRandom
import Puppet.Interpreter.Types
import Puppet.Parser
import PuppetDB
sha1 :: ByteString -> ByteString
sha1 = ByteArray.convert . (hash :: ByteString -> Digest SHA1)
md5 :: ByteString -> ByteString
md5 = ByteArray.convert . (hash :: ByteString -> Digest MD5)
type NumberPair = Pair Scientific Scientific
fixResourceName :: Text
-> Text
-> Text
fixResourceName "class" x = Text.toLower $ fromMaybe x $ Text.stripPrefix "::" x
fixResourceName _ x = x
runHiera :: Text -> HieraQueryType -> InterpreterMonad (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) = fmap (k,) (preview _PString v)
toplevels = map (_1 %~ ("::" <>)) $ getV "::"
locals = getV ctx
vars = HM.fromList (toplevels <> locals)
Operational.singleton (HieraQuery vars q t)
hieraCall :: HieraQueryType -> PValue -> Maybe PValue -> Maybe DataType -> Maybe PValue -> InterpreterMonad PValue
hieraCall _ _ _ _ (Just _) = throwPosError "Overriding the hierarchy is not supported (and deprecated in puppet)"
hieraCall qt q df dt _ = do
qs <- resolvePValueString q
runHiera qs qt >>= \case
Just p -> case dt of
Just dt' | not (datatypeMatch dt' p) -> throwPosError "Datatype mismatched"
_ -> pure p
Nothing -> case df of
Just d -> pure d
Nothing -> throwPosError ("Lookup for " <> ppline 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) -> pure (PNumber $ fromIntegral (opr na nb))
_ -> throwPosError ("Expected integer values, not" <+> pretty ra <+> "or" <+> pretty rb)
resolveVariable :: Text -> InterpreterMonad PValue
resolveVariable fullvar = do
scps <- use scopes
scp <- getScopeName
case getVariable scps scp fullvar of
Left rr -> throwPosError rr
Right x -> pure x
isNativeType :: Text -> InterpreterMonad Bool
isNativeType t = has (ix t) `fmap` Operational.singleton GetNativeTypes
getVariable :: Container ScopeInformation
-> Text
-> Text
-> Either Doc PValue
getVariable scps scp fullvar = do
(varscope, varname) <- case Text.splitOn "::" fullvar of
[] -> Left "This doesn't make any sense in resolveVariable"
[vn] -> pure (scp, vn)
rst -> pure (Text.intercalate "::" (filter (not . Text.null) (List.init rst)), List.last rst)
let extractVariable (varval :!: _ :!: _) = pure 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" <+> ppline 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) -> CaseInsensitive.mk sa == CaseInsensitive.mk sb
_ -> ra == rb
matchExpression :: Expression -> (Regex, Expression) -> InterpreterMonad PValue
matchExpression a (rv, rexpr) = do
ra <- Text.encodeUtf8 <$> resolveExpressionString a
case Regex.execute' rv ra of
Left (_,rr) -> throwPosError ("Error when executing regex" <+> pretty rexpr <+> ":" <+> pretty rr)
Right Nothing -> pure $ PBoolean False
Right (Just matches) -> do
p <- use curPos
ctype <- view cctype <$> getCurContainer
let captures = zip (map (Text.pack . show) [(0 :: Int)..]) (map mkMatch (toList matches))
mkMatch (offset, len) = PString (Text.decodeUtf8 (BS.take len (BS.drop offset ra))) :!: p :!: ctype
scp <- getScopeName
scopes . ix scp . scopeVariables %= HM.union (HM.fromList captures)
pure $ PBoolean True
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)
pure (PBoolean (ra && rb))
else pure (PBoolean False)
resolveExpression (Or a b) = do
ra <- pValue2Bool <$> resolveExpression a
if ra
then pure (PBoolean True)
else do
rb <- fmap pValue2Bool (resolveExpression b)
pure (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
matchExpression a (rv, v)
resolveExpression (RegexMatch a b) = do
resolveExpression b >>= \case
PRegexp (CompRegex _ rv) -> matchExpression a (rv, b)
_ -> throwPosError ("The regexp matching operator expects a regular expression, not" <+> pretty b)
resolveExpression (NotRegexMatch a v) = resolveExpression (Not (RegexMatch a v))
resolveExpression (Equal a b) = do
ra <- resolveExpression a
rb <- resolveExpression b
pure $ 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 _ -> pure (PBoolean True)
Nothing -> pure (PBoolean False)
PArray ar -> do
ridx <- resolveExpression idx
pure (PBoolean (ridx `V.elem` ar))
PString st -> do
ridx <- resolveExpressionString idx
pure (PBoolean (ridx `Text.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 -> pure v
Nothing -> do
checkStrict
("Look up for an hash with the unknown key '" <> ppline ridx <> "' for" <+> pretty (PHash h))
("Can't find index '" <> ppline ridx <> "' in" <+> pretty (PHash h))
pure PUndef
PArray ar -> do
ridx <- resolveExpression idx
i <- case ridx ^? _Integer of
Just n -> pure (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" <+> pretty arl <+> "index is" <+> pretty i)
else pure (ar V.! i)
_ -> throwPosError ("Enable to resolve a 'Lookup' expression. Cannot index:" <+> pretty a <+> "at" <+> pretty idx)
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 Text.encodeUtf8 (resolvePValueString rese)
case Regex.execute' rg rs of
Left (_,rr) -> throwPosError ("Could not match" <+> pretty v <+> ":" <+> ppstring rr)
Right Nothing -> checkCond xs
Right (Just _) -> resolveExpression ce
checkCond ((SelectorType udt :!: ce) : xs) = do
dt <- resolveDataType udt
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) -> pure (PHash (ha <> hb))
(PArray ha, PArray hb) -> pure (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) -> pure $ PNumber $ fromIntegral (ia `div` ib)
_ -> pure $ 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) -> pure (PArray (V.snoc ha v))
_ -> integerOperation a b (\x -> shiftL x . fromIntegral)
resolveExpression a@(FunctionApplication e (Terminal (UHOLambdaCall hol))) = do
unless (null (hol ^. hoLambdaExpr))
(throwPosError ("You can't combine chains of higher order functions (with .) and giving them parameters, in:" <+> pretty a))
resolveValue (UHOLambdaCall (hol & hoLambdaExpr .~ V.singleton e))
resolveExpression (FunctionApplication _ x) = throwPosError ("Expected function application here, not" <+> pretty x)
resolveExpression (Negate x) = PNumber . negate <$> resolveExpressionNumber x
resolveValue :: UnresolvedValue -> InterpreterMonad PValue
resolveValue (UNumber n) = pure (PNumber n)
resolveValue (URegexp r) = pure (PRegexp r)
resolveValue (UBoolean x) = pure (PBoolean x)
resolveValue (UString x) = pure (PString x)
resolveValue UUndef = pure PUndef
resolveValue (UInterpolable vals) = fmap (PString . mconcat) (mapM resolveExpressionString (V.toList vals))
resolveValue (UResourceReference t e) = do
r <- resolveExpressionStrings e
case r of
[s] -> pure (PResourceReference t (fixResourceName t s))
_ -> pure (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
resolveValue (UDataType dt) = PType <$> resolveDataType dt
resolvePValueString :: PValue -> InterpreterMonad Text
resolvePValueString (PString x) = pure x
resolvePValueString (PBoolean True) = pure "true"
resolvePValueString (PBoolean False) = pure "false"
resolvePValueString (PNumber x) = pure (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\""
pure "undef"
resolvePValueString x = throwPosError ("Don't know how to convert this to a string:" <> line <> pretty x)
resolvePValueNumber :: PValue -> InterpreterMonad Scientific
resolvePValueNumber x =
case x ^? _Number of
Just n -> pure n
Nothing -> throwPosError ("Don't know how to convert this to a number:" <> line <> pretty x)
resolveExpressionString :: Expression -> InterpreterMonad Text
resolveExpressionString = resolveExpression >=> resolvePValueString
resolveExpressionNumber :: Expression -> InterpreterMonad Scientific
resolveExpressionNumber = resolveExpression >=> resolvePValueNumber
resolveExpressionStrings :: Expression -> InterpreterMonad [Text]
resolveExpressionStrings x =
resolveExpression x >>= \case
PArray a -> mapM resolvePValueString (V.toList a)
y -> fmap pure (resolvePValueString y)
pValue2Bool :: PValue -> Bool
pValue2Bool PUndef = False
pValue2Bool (PString "") = True
pValue2Bool (PBoolean x) = x
pValue2Bool _ = True
resolveFunction :: 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 -> pure x
_ -> throwPosError ("fqdn_rand(): the first argument must be an integer, not" <+> ppline mx)
let rargs = if null targs
then [fqdn, ""]
else fqdn : targs
val = fromIntegral (fst (limitedRand (randInit myhash) (fromIntegral curmax)))
myhash = toint (md5 (Text.encodeUtf8 fullstring)) :: Integer
toint = BS.foldl' (\c nx -> c*256 + fromIntegral nx) 0
fullstring = Text.intercalate ":" rargs
pure (_Integer # val)
resolveFunction fname args =
mapM resolveExpression (V.toList args) >>= resolveFunction' fname . map undefEmptyString
where
undefEmptyString PUndef = PString ""
undefEmptyString x = x
resolveFunction' :: 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 (Text.null t) && Text.head t == '$'
then do
scps <- use scopes
scp <- getScopeName
pure $ PBoolean $ case getVariable scps scp (Text.tail t) of
Left _ -> False
Right _ -> True
else do
nestedStuff <- use nestedDeclarations
if has (ix (TopDefine, t)) nestedStuff || has (ix (TopClass, t)) nestedStuff
then pure (PBoolean True)
else do
lc <- use loadedClasses
if has (ix t) lc
then pure (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 =
let compute = fmap Inline . resolvePValueString >=> calcTemplate
in
PString . mconcat <$> traverse compute templates
resolveFunction' "md5" [pstr] = fmap (PString . Text.decodeUtf8 . B16.encode . md5 . Text.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 (Tuple.fst p)))
regexp <- fmap Text.encodeUtf8 (resolvePValueString pregexp)
replacement <- fmap Text.encodeUtf8 (resolvePValueString preplacement)
let sub t = do
t' <- fmap Text.encodeUtf8 (resolvePValueString t)
case Regex.substituteCompile' regexp t' replacement of
Left rr -> throwPosError ("regsubst():" <+> ppstring 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 Text.encodeUtf8 (resolvePValueString psrc)
splt <- fmap Text.encodeUtf8 (resolvePValueString psplt)
case Regex.splitCompile' splt src of
Left err -> throwPosError ("splitCompile():" <+> ppstring err)
Right x -> fmap (PArray . V.fromList) (mapM (fmap PString . safeDecodeUtf8) x)
resolveFunction' "sha1" [pstr] = fmap (PString . Text.decodeUtf8 . B16.encode . sha1 . Text.encodeUtf8) (resolvePValueString pstr)
resolveFunction' "sha1" _ = throwPosError "sha1(): Expects a single argument"
resolveFunction' "shellquote" args = do
sargs <- for args $ \arg ->
case arg of
PArray vals -> mapM resolvePValueString vals
_ -> V.singleton <$> resolvePValueString arg
let escape str | Text.all isSafe str = str
| not (Text.any isDangerous str) = between "\"" str
| Text.any (== '\'') str = between "\"" (Text.concatMap escapeDangerous str)
| otherwise = between "'" str
isSafe x = Char.isAlphaNum x || x `elem` ("@%_+=:,./-" :: String)
isDangerous x = x `elem` ("!\"`$\\" :: String)
escapeDangerous x | isDangerous x = Text.snoc "\\" x
| otherwise = Text.singleton x
between c s = c <> s <> c
pure $ PString $ Text.unwords $ V.toList (escape <$> mconcat sargs)
resolveFunction' "mysql_password" [pstr] = fmap (PString . Text.decodeUtf8 . B16.encode . sha1 . sha1 . Text.encodeUtf8) (resolvePValueString pstr)
resolveFunction' "mysql_password" _ = throwPosError "mysql_password(): Expects a single argument"
resolveFunction' "file" args = do
rebasefile <- fmap Text.pack <$> Operational.singleton RebaseFile
let fixFilePath s | Text.null s = let rr = "Empty file path passed to the 'file' function" in checkStrict rr rr >> pure s
| Text.head s == '/' = pure (maybe s (<> s) rebasefile)
| otherwise = case Text.splitOn "/" s of
(md:x:rst) -> do
moduledir <- view modulesPath <$> getPuppetPaths
pure (Text.intercalate "/" (Text.pack moduledir : md : "files" : x : rst))
_ -> throwPosError ("file() argument invalid: " <> ppline s)
mapM (resolvePValueString >=> fixFilePath) args >>= fmap PString . Operational.singleton . ReadFile
resolveFunction' "tagged" ptags = do
tags <- fmap HS.fromList (mapM resolvePValueString ptags)
scp <- getScopeName
scpset <- use (scopes . ix scp . scopeExtraTags)
pure (PBoolean (scpset `HS.intersection` tags == tags))
resolveFunction' "template" [] = throwPosError "template(): Expects at least one argument"
resolveFunction' "template" templates =
let compute = fmap (Filename . Text.unpack) . resolvePValueString >=> calcTemplate
in
PString . mconcat <$> traverse compute templates
resolveFunction' "versioncmp" [pa,pb] = do
a <- resolvePValueString pa
b <- resolvePValueString pb
let parser x =
case filter (null . snd) (readP_to_S parseVersion (Text.unpack x)) of
( (v, _) : _ ) -> v
_ -> Version [] []
va = parser a
vb = parser b
pure $ PString $ case compare va vb of
EQ -> "0"
LT -> "-1"
GT -> "1"
resolveFunction' "versioncmp" _ = throwPosError "versioncmp(): Expects two arguments"
resolveFunction' "sprintf" (PString str:args) = sprintf str args
resolveFunction' "sprintf" _ = throwPosError "sprintf(): Expects a string as its first argument"
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 QFirst q Nothing Nothing Nothing
resolveFunction' "hiera" [q,d] = hieraCall QFirst q (Just d) Nothing Nothing
resolveFunction' "hiera" [q,d,o] = hieraCall QFirst q (Just d) Nothing (Just o)
resolveFunction' "hiera_array" [q] = hieraCall QUnique q Nothing Nothing Nothing
resolveFunction' "hiera_array" [q,d] = hieraCall QUnique q (Just d) Nothing Nothing
resolveFunction' "hiera_array" [q,d,o] = hieraCall QUnique q (Just d) Nothing (Just o)
resolveFunction' "hiera_hash" [q] = hieraCall QHash q Nothing Nothing Nothing
resolveFunction' "hiera_hash" [q,d] = hieraCall QHash q (Just d) Nothing Nothing
resolveFunction' "hiera_hash" [q,d,o] = hieraCall QHash q (Just d) Nothing (Just o)
resolveFunction' "lookup" [q] = hieraCall QFirst q Nothing Nothing Nothing
resolveFunction' "lookup" [q, PType dt] = hieraCall QFirst q Nothing (Just dt) Nothing
resolveFunction' "lookup" [q, PType dt, PString qt, def] = do
case readQueryType qt of
Nothing -> throwPosError ("Unknown merge strategy " <> ppline qt)
Just qt' -> hieraCall qt' q (Just def) (Just dt) Nothing
resolveFunction' "lookup" _ = throwPosError "lookup(): Wrong set of arguments"
resolveFunction' fname args = Operational.singleton (ExternalFunction fname args)
pdbresourcequery :: PValue -> Maybe Text -> InterpreterMonad PValue
pdbresourcequery q mkey = do
rrv <- case fromJSON (toJSON q) of
Aeson.Success rq -> Operational.singleton (PDBGetResources rq)
Aeson.Error rr -> throwPosError ("Invalid resource query:" <+> ppstring rr)
rv <- case fromJSON (toJSON rrv) of
Aeson.Success x -> pure x
Aeson.Error rr -> throwPosError ("For some reason we could not convert a resource list to Puppet internal values!!" <+> ppstring rr <+> pretty rrv)
let extractSubHash :: Text -> PValue -> InterpreterMonad PValue
extractSubHash k (PHash h) =
case h ^. at k of
Just val -> pure val
Nothing -> throwPosError ("pdbresourcequery strange error, could not find key" <+> ppline k <+> "in" <+> pretty (PHash h))
extractSubHash _ x = throwPosError ("pdbresourcequery strange error, expected a hash, had" <+> pretty x)
case mkey of
Nothing -> pure (PArray rv)
(Just k) -> fmap PArray (V.mapM (extractSubHash k) rv)
calcTemplate :: TemplateSource -> InterpreterMonad Text
calcTemplate templatetype = do
intpstate <- use identity
Operational.singleton (ComputeTemplate templatetype intpstate)
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 -> pure resolved
resolveSearchExpression :: SearchExpression -> InterpreterMonad RSearchExpression
resolveSearchExpression AlwaysTrue = pure 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 :: 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 (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) -> any (`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 (all (`puppetEquality` v) x)
Just x -> not (puppetEquality x v)
resolveDataType :: UDataType -> InterpreterMonad DataType
resolveDataType ud
= case ud of
UDTType -> pure DTType
UDTString a b -> pure (DTString a b)
UDTInteger a b -> pure (DTInteger a b)
UDTFloat a b -> pure (DTFloat a b)
UDTBoolean -> pure DTBoolean
UDTArray dt a b -> DTArray <$> resolveDataType dt <*> pure a <*> pure b
UDTHash dt1 dt2 a b -> DTHash <$> resolveDataType dt1 <*> resolveDataType dt2 <*> pure a <*> pure b
UDTUndef -> pure DTUndef
UDTScalar -> pure DTScalar
UDTData -> pure DTData
UDTOptional dt -> DTOptional <$> resolveDataType dt
UNotUndef -> pure NotUndef
UDTVariant vrs -> DTVariant <$> traverse resolveDataType vrs
UDTPattern a -> pure (DTPattern a)
UDTEnum ens -> DTEnum . NE.fromList . sconcat <$> traverse resolveExpressionStrings ens
UDTAny -> pure DTAny
UDTCollection -> pure DTCollection
UDTRegexp mr -> pure (DTRegexp mr)
hfGenerateAssociations :: HOLambdaCall -> InterpreterMonad [[(Text, PValue)]]
hfGenerateAssociations hol = do
sourceexpression <- case hol ^.. hoLambdaExpr . folded of
[x] -> pure x
[] -> throwPosError ("No expression to run the function on" <+> pretty hol)
_ -> throwPosError ("Too many expressions to run the function on" <+> pretty hol)
sourcevalue <- resolveExpression sourceexpression
let check Nothing _ = pure ()
check (Just udtype) tocheck = do
dtype <- resolveDataType udtype
mapM_ (\v -> unless (datatypeMatch dtype v) (throwPosError (pretty v <+> "isn't of type" <+> pretty dtype))) tocheck
case (sourcevalue, V.toList (hol ^. hoLambdaParams)) of
(PArray pr, [LambdaParam mvtype varname]) -> do
check mvtype pr
pure (map (\x -> [(varname, x)]) (V.toList pr))
(PArray pr, [LambdaParam _ idx, LambdaParam mvtype var] ) -> do
check mvtype pr
pure [ [(idx,PString (Text.pack (show i))),(var,v)] | (i,v) <- zip ([0..] :: [Int]) (V.toList pr) ]
(PHash hh, [LambdaParam mvtype varname]) -> do
check mvtype hh
pure [ [(varname, PArray (V.fromList [PString k,v]))] | (k,v) <- HM.toList hh]
(PHash hh, [LambdaParam midxtype idx, LambdaParam mvtype var]) -> do
check mvtype hh
check midxtype (PString <$> HM.keys hh)
pure [ [(idx,PString k),(var,v)] | (k,v) <- HM.toList hh]
(invalid, _) -> throwPosError ("Can't iterate on this data type:" <+> pretty invalid)
hfSetvars :: [(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
pure 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 :: HOLambdaCall -> InterpreterMonad (HOLambdaCall, Expression)
transformPureHf hol =
case hol ^. hoLambdaLastExpr of
S.Just x -> pure (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 pure (hol & hoLambdaStatements %~ V.init
& hoLambdaLastExpr .~ S.Just expr
, expr)
_ -> throwPosError ("The statement block must end with an expression" <+> pretty hol)
evaluateHFCPure :: HOLambdaCall -> InterpreterMonad PValue
evaluateHFCPure hol' = do
(hol, finalexpression) <- transformPureHf hol'
let runblock :: [(Text, PValue)] -> InterpreterMonad PValue
runblock assocs = do
saved <- hfSetvars assocs
V.mapM_ evalPureStatement (hol ^. hoLambdaStatements)
r <- resolveExpression finalexpression
hfRestorevars saved
pure r
case hol ^. hoLambdaFunc of
LambdaFunc "each" -> throwPosError "The 'each' function can't be used at the value level in language-puppet. Please use map."
LambdaFunc "map" -> do
varassocs <- hfGenerateAssociations hol
fmap (PArray . V.fromList) (mapM runblock varassocs)
LambdaFunc "with" -> do
let expressions = hol ^. hoLambdaExpr
parameters = hol ^. hoLambdaParams
unless (V.length expressions == V.length parameters)
(throwPosError ("Mismatched number of arguments and lambda parameters in" <> pretty hol))
assocs <- forM (V.zip expressions parameters) $ \(uval, LambdaParam mt name) -> do
val <- resolveExpression uval
forM_ mt $ \ut -> do
t <- resolveDataType ut
checkMatch t val
return (name, val)
runblock (V.toList assocs)
LambdaFunc "filter" -> do
varassocs <- hfGenerateAssociations hol
res <- mapM (fmap pValue2Bool . runblock) varassocs
sourcevalue <- case hol ^.. hoLambdaExpr . folded of
[x] -> resolveExpression x
_ -> throwPosError "Internal error evaluateHFCPure 1"
case sourcevalue of
PArray ar -> pure $ PArray $ V.map fst $ V.filter snd $ V.zip ar (V.fromList res)
PHash hh -> pure $ PHash $ HM.fromList $ map fst $ filter snd $ zip (HM.toList hh) res
x -> throwPosError ("Can't iterate on this data type:" <+> pretty x)
x -> throwPosError ("This type of lambda function is not supported yet by language-puppet!" <+> pretty x)
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 Text.length mmin mmax
DTInteger mmin mmax -> boundedBy (_PNumber . to Scientific.toBoundedInteger . _Just) identity mmin mmax
DTFloat mmin mmax -> boundedBy _PNumber Scientific.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 (Text.encodeUtf8 str)) patterns) (v ^? _PString)
DTRegexp mr -> case v ^? _PRegexp of
Nothing -> False
Just cr -> maybe True (== cr) mr
where
checkPattern str (CompRegex _ ptrn) =
case Regex.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
pure $ and (catMaybes [fmap (vr >=) mmin, fmap (vr <=) mmax])
checkMatch :: DataType -> PValue -> InterpreterMonad ()
checkMatch dt pv = unless (datatypeMatch dt pv) (throwPosError (pretty pv <+> "does not match type" <+> pretty dt))
typeOf :: PValue -> DataType
typeOf pv =
case pv of
PBoolean _ -> DTBoolean
PUndef -> DTUndef
PString _ -> DTString Nothing Nothing
PResourceReference _ _ -> DTType
PArray _ -> DTArray DTAny 0 Nothing
PHash _ -> DTHash DTAny DTAny 0 Nothing
PType _ -> DTType
PRegexp _ -> DTRegexp Nothing
PNumber n -> if Scientific.isInteger n
then DTInteger Nothing Nothing
else DTFloat Nothing Nothing