{-# LANGUAGE LambdaCase #-} module Puppet.Interpreter.Resolve where import Puppet.PP import Puppet.Interpreter.Types import Puppet.Parser.Types import Puppet.Interpreter.PrettyPrinter() import Puppet.Parser.PrettyPrinter() import Data.Version (parseVersion) import Text.ParserCombinators.ReadP (readP_to_S) 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.IO as T import qualified Data.Text.Encoding as T import Data.Monoid import Control.Applicative hiding ((<$>)) import Control.Exception import Control.Monad import Control.Monad.Error import Data.Tuple.Strict import Control.Lens import Data.Attoparsec.Number import Data.Attoparsec.Text import qualified Data.Either.Strict as S import qualified Data.Maybe.Strict as S import Text.Regex.PCRE.ByteString import Puppet.Interpreter.RubyRandom 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 Text.Regex.PCRE.ByteString.Utils import Data.Bits type NumberPair = S.Either (Pair Integer Integer) (Pair Double Double) -- | Tries to convert a pair of PValues into numbers, as defined in -- attoparsec. If the two values can be converted, it will convert them so -- that they are of the same type toNumbers :: PValue -> PValue -> S.Maybe NumberPair toNumbers (PString a) (PString b) = case parseOnly number a :!: parseOnly number b of (Right (I x) :!: Right (I y)) -> S.Just (S.Left (x :!: y)) (Right (D x) :!: Right (D y)) -> S.Just (S.Right (x :!: y)) (Right (I x) :!: Right (D y)) -> S.Just (S.Right (fromIntegral x :!: y)) (Right (D x) :!: Right (I y)) -> S.Just (S.Right (x :!: fromIntegral y)) _ -> S.Nothing toNumbers _ _ = S.Nothing binaryOperation :: Expression -> Expression -> (Integer -> Integer -> Integer) -> (Double -> Double -> Double) -> InterpreterMonad PValue binaryOperation a b opi opd = do ra <- resolveExpression a rb <- resolveExpression b case toNumbers ra rb of S.Nothing -> throwPosError ("Expected numbers, not" <+> pretty ra <+> "or" <+> pretty rb) S.Just (S.Right (na :!: nb)) -> return (pvnum # D (opd na nb)) S.Just (S.Left (na :!: nb)) -> return (pvnum # I (opi na nb)) integerOperation :: Expression -> Expression -> (Integer -> Integer -> Integer) -> InterpreterMonad PValue integerOperation a b opr = do ra <- resolveExpression a rb <- resolveExpression b case toNumbers ra rb of S.Nothing -> throwPosError ("Expected numbers, not" <+> pretty ra <+> "or" <+> pretty rb) S.Just (S.Right _) -> throwPosError ("Expected integer values, not" <+> pretty ra <+> "or" <+> pretty rb) S.Just (S.Left (na :!: nb)) -> return (pvnum # I (opr na nb)) -- | Converting PValue to and from Number with a prism! pvnum :: Prism' PValue Number pvnum = prism num2PValue toNumber where num2PValue :: Number -> PValue num2PValue (I x) = PString (T.pack (show x)) num2PValue (D x) = PString (T.pack (show x)) toNumber :: PValue -> Either PValue Number toNumber p@(PString x) = case parseOnly number x of Right y -> Right y _ -> Left p toNumber p = Left p _PString :: Prism' PValue T.Text _PString = prism PString $ \x -> case x of PString s -> Right s n -> Left n _PInteger :: Prism' PValue Integer _PInteger = prism (PString . T.pack . show) $ \x -> case x ^? pvnum of Just (I z) -> Right z _ -> Left x resolveVariable :: T.Text -> InterpreterMonad PValue resolveVariable fullvar = do scps <- use scopes scp <- getScope case getVariable scps scp fullvar of Left rr -> throwPosError rr Right x -> return x isNativeType :: T.Text -> InterpreterMonad Bool isNativeType t = view (nativeTypes . contains t) getVariable :: Container ScopeInformation -> T.Text -> T.Text -> Either Doc PValue getVariable scps scp fullvar = do (varscope, varname) <- case T.splitOn "::" fullvar of [] -> throwError "This doesn't make any sense in resolveVariable" [vn] -> return (scp, vn) -- Non qualified variables rst -> return (T.intercalate "::" (filter (not . T.null) (init rst)), last rst) -- qualified variables let extractVariable (varval :!: _ :!: _) = return varval case scps ^? ix varscope . scopeVariables . ix varname of Just pp -> extractVariable pp Nothing -> -- check top level scope case scps ^? ix "::" . scopeVariables . ix varname of Just pp -> extractVariable pp Nothing -> throwError ("Could not resolve variable" <+> pretty (UVariableReference fullvar) <+> "in context" <+> ttext varscope <+> "or root") numberCompare :: Expression -> Expression -> (Integer -> Integer -> Bool) -> (Double -> Double -> Bool) -> InterpreterMonad PValue numberCompare a b compi compd = do ra <- resolveExpression a rb <- resolveExpression b case toNumbers ra rb of S.Nothing -> throwPosError ("Comparison functions expect numbers, not:" <+> pretty ra <+> comma <+> pretty rb) S.Just (S.Right (na :!: nb)) -> return (PBoolean (compd na nb)) S.Just (S.Left (na :!: nb)) -> return (PBoolean (compi na nb)) puppetEquality :: PValue -> PValue -> Bool puppetEquality ra rb = case toNumbers ra rb of (S.Just (S.Right (na :!: nb))) -> na == nb (S.Just (S.Left (na :!: nb))) -> na == nb _ -> case (ra, rb) of (PUndef , PBoolean x) -> not x (PString "true", PBoolean x) -> x (PString "false", PBoolean x) -> not x (PBoolean x, PString "true") -> x (PBoolean x, PString "false") -> not x (PString sa, PString sb) -> mk sa == mk sb -- TODO, check if array / hash equality should be recursed -- for case insensitive matching _ -> ra == rb 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) rb <- fmap pValue2Bool (resolveExpression b) return (PBoolean (ra && rb)) resolveExpression (Or a b) = do ra <- fmap pValue2Bool (resolveExpression a) 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 (PValue ur@(URegexp _ rv))) = do ra <- fmap T.encodeUtf8 (resolveExpressionString a) liftIO (execute rv ra) >>= \case Left rr -> throwPosError ("Regexp matching critical failure" <+> text (show rr) <+> parens ("Regexp was" <+> pretty ur)) Right Nothing -> return (PBoolean False) Right _ -> 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 ^? pvnum of Just (I 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 ur@(URegexp _ rg) :!: ce) : xs) = do rs <- fmap T.encodeUtf8 (resolvePValueString rese) liftIO (execute rg rs) >>= \case Left rr -> throwPosError ("Regexp matching critical failure" <+> text (show rr) <+> parens ("Regexp was" <+> pretty ur)) Right Nothing -> checkCond xs Right _ -> resolveExpression ce checkCond ((SelectorValue uv :!: ce) : xs) = do rv <- resolveValue uv if puppetEquality rese rv then resolveExpression ce else checkCond xs checkCond (V.toList conds) resolveExpression (Addition a b) = binaryOperation a b (+) (+) resolveExpression (Substraction a b) = binaryOperation a b (-) (-) resolveExpression (Division a b) = binaryOperation a b div (/) resolveExpression (Multiplication a b) = binaryOperation a b (*) (*) resolveExpression (Modulo a b) = integerOperation a b mod resolveExpression (RightShift a b) = integerOperation a b (\x -> shiftR x . fromIntegral) resolveExpression (LeftShift a b) = integerOperation a b (\x -> shiftL x . fromIntegral) resolveExpression a@(FunctionApplication e (PValue (UHFunctionCall hf))) = do unless (S.isNothing (hf ^. hfexpr)) (throwPosError ("You can't combine chains of higher order functions (with .) and giving them parameters, in:" <+> pretty a)) resolveValue (UHFunctionCall (hf & hfexpr .~ S.Just e)) resolveExpression (FunctionApplication _ x) = throwPosError ("Expected function application here, not" <+> pretty x) resolveExpression x = throwPosError ("Don't know how to resolve this expression:" <$> pretty x) resolveValue :: UValue -> InterpreterMonad PValue resolveValue n@(URegexp _ _) = throwPosError ("Regular expressions are not allowed in this context: " <+> pretty n) resolveValue (UBoolean x) = return (PBoolean x) resolveValue (UString x) = return (PString x) resolveValue UUndef = return PUndef resolveValue (UInterpolable vals) = fmap (PString . mconcat) (mapM resolveValueString (V.toList vals)) resolveValue (UResourceReference t e) = PResourceReference `fmap` pure t <*> resolveExpressionString e 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 resolveValueString :: UValue -> InterpreterMonad T.Text resolveValueString = resolveValue >=> resolvePValueString resolvePValueString :: PValue -> InterpreterMonad T.Text resolvePValueString (PString x) = return x resolvePValueString (PBoolean True) = return "true" resolvePValueString (PBoolean False) = return "false" resolvePValueString x = throwPosError ("Don't know how to convert this to a string:" <$> pretty x) resolveExpressionString :: Expression -> InterpreterMonad T.Text resolveExpressionString = resolveExpression >=> resolvePValueString 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 ^? pvnum of Just (I 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 (pvnum # I val) resolveFunction fname args = mapM resolveExpression (V.toList args) >>= resolveFunction' fname resolveFunction' :: T.Text -> [PValue] -> InterpreterMonad PValue resolveFunction' "defined" [PResourceReference rt rn] = fmap PBoolean (use (definedResources . contains (RIdentifier rt rn))) resolveFunction' "defined" [ut] = do t <- resolvePValueString ut -- case 1, netsted thingie nestedStuff <- use nestedDeclarations if (nestedStuff ^. contains (TopDefine, t)) || (nestedStuff ^. contains (TopClass, t)) then return (PBoolean True) else do -- case 2, loadeded class lc <- use loadedClasses if lc ^. contains t then return (PBoolean True) else fmap PBoolean (isNativeType t) resolveFunction' "defined" x = throwPosError ("defined(): expects a single resource reference, type or class name, and not" <+> pretty x) resolveFunction' "fail" x = throwPosError ("fail:" <+> pretty x) resolveFunction' "inline_template" [templatename] = calcTemplate Left templatename resolveFunction' "inline_template" _ = throwPosError "inline_template(): Expects a single argument" resolveFunction' "md5" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . MD5.hash . T.encodeUtf8) (resolvePValueString pstr) resolveFunction' "md5" _ = throwPosError "md5(): Expects a single argument" resolveFunction' "regsubst" [ptarget, pregexp, preplacement] = resolveFunction' "regsubst" [ptarget, pregexp, preplacement, PString "G"] resolveFunction' "regsubst" [ptarget, pregexp, preplacement, pflags] = do -- TODO handle all the flags -- http://docs.puppetlabs.com/references/latest/function.html#regsubst when (pflags /= "G") (throwPosError "regsubst(): Currently only supports a single flag (G)") target <- fmap T.encodeUtf8 (resolvePValueString ptarget) regexp <- fmap T.encodeUtf8 (resolvePValueString pregexp) replacement <- fmap T.encodeUtf8 (resolvePValueString preplacement) liftIO (substituteCompile regexp target replacement) >>= \case Left rr -> throwPosError ("regsubst():" <+> text 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) liftIO (splitCompile splt src) >>= \case Left rr -> throwPosError ("regsubst():" <+> text 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 . interpreterIO . file where file :: [T.Text] -> IO (S.Either Doc T.Text) file [] = return $ S.Left ("No file found in" <+> pretty args) file (x:xs) = fmap S.Right (T.readFile (T.unpack x)) `catch` (\SomeException{} -> file xs) resolveFunction' "tagged" ptags = do tags <- fmap HS.fromList (mapM resolvePValueString ptags) scp <- getScope scpset <- use (scopes . ix scp . scopeExtraTags) return (PBoolean (scpset `HS.intersection` tags == tags)) resolveFunction' "template" [templatename] = calcTemplate Right templatename resolveFunction' "template" _ = throwPosError "template(): Expects a single argument" resolveFunction' "versioncmp" [pa,pb] = do a <- resolvePValueString pa b <- resolvePValueString pb let parser x = case filter (null . Prelude.snd) (readP_to_S parseVersion (T.unpack x)) of ( (v, _) : _ ) -> return v _ -> throwPosError ("Could not parse this string as a version:" <+> ttext x) va <- parser a vb <- parser b return $ PString $ case compare va vb of EQ -> "0" LT -> "-1" GT -> "1" resolveFunction' "versioncmp" _ = throwPosError "versioncmp(): Expects two arguments" -- some custom functions resolveFunction' "pdbresourcequery" [q] = pdbresourcequery q Nothing resolveFunction' "pdbresourcequery" [q,k] = fmap Just (resolvePValueString k) >>= pdbresourcequery q resolveFunction' "pdbresourcequery" _ = throwPosError "pdbresourcequery(): Expects one or two arguments" -- user functions resolveFunction' fname args = do external <- view externalFunctions case external ^. at fname of Just f -> f args Nothing -> throwPosError ("Unknown function" <+> dullred (ttext fname)) pdbresourcequery :: PValue -> Maybe T.Text -> InterpreterMonad PValue pdbresourcequery q key = do pdb <- view pdbAPI rrv <- case fromJSON (toJSON q) of Success rq -> interpreterIO (getResources pdb 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 key 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 scps <- use scopes scp <- getScope computeFunc <- view computeTemplateFunction liftIO (computeFunc (templatetype fname) scp scps) >>= \case S.Left rr -> throwPosError ("template error for" <+> ttext fname <+> ":" <$> rr) S.Right r -> return (PString r) 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 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 {--------------------------------------- - Higher order functions part ----------------------------------------} -- | Generates associations for evaluation of blocks hfGenerateAssociations :: HFunctionCall -> InterpreterMonad [[(T.Text, PValue)]] hfGenerateAssociations hf = do sourceexpression <- case hf ^. hfexpr of S.Just x -> return x S.Nothing -> throwPosError ("No expression to run the function on" <+> pretty hf) sourcevalue <- resolveExpression sourceexpression case (sourcevalue, hf ^. hfparams) of (PArray pr, BPSingle varname) -> return (map (\x -> [(varname, x)]) (V.toList pr)) (PArray pr, BPPair idx var) -> return $ do (i,v) <- Prelude.zip ([0..] :: [Int]) (V.toList pr) return [(idx,PString (T.pack (show i))),(var,v)] (PHash hh, BPSingle varname) -> return $ do (k,v) <- HM.toList hh return [(varname, PArray (V.fromList [PString k,v]))] (PHash hh, BPPair idx var) -> return $ do (k,v) <- HM.toList hh return [(idx,PString k),(var,v)] (invalid, _) -> throwPosError ("Can't iterate on this data type:" <+> pretty invalid) -- | Sets the proper variables, and returns the scope variables the way -- they were before being modified. hfSetvars :: [(T.Text, PValue)] -> InterpreterMonad (Container (Pair (Pair PValue PPosition) CurContainerDesc)) hfSetvars vals = do scp <- getScope 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 allocation. hfRestorevars :: Container (Pair (Pair PValue PPosition) CurContainerDesc) -> InterpreterMonad () hfRestorevars save = do scp <- getScope scopes . ix scp . scopeVariables .= save -- | Evaluates a statement in "pure" mode. evalPureStatement :: Statement -> InterpreterMonad () evalPureStatement = undefined -- | All the "higher order function" stuff, for "value" mode. In this case -- we are in "pure" mode, and only a few statements are allowed. evaluateHFCPure :: HFunctionCall -> InterpreterMonad PValue evaluateHFCPure hf = do varassocs <- hfGenerateAssociations hf finalexpression <- case hf ^. hfexpression of S.Just x -> return x S.Nothing -> throwPosError ("The statement block must end with an expression" <+> pretty 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)