{-# LANGUAGE LambdaCase #-}
-- | This module is all about converting and resolving foreign data into
-- the fully exploitable corresponding data type. The main use case is the
-- conversion of 'Expression' to 'PValue'.
module Puppet.Interpreter.Resolve
    ( -- * Pure resolution functions
      getVariable,
      pValue2Bool,
      -- * Monadic resolution functions
      resolveVariable,
      resolveExpression,
      resolveValue,
      resolvePValueString,
      resolveExpressionString,
      resolveExpressionStrings,
      resolveArgument,
      runHiera,
      isNativeType,
      -- * Search expression management
      resolveSearchExpression,
      checkSearchExpression,
      searchExpressionToPuppetDB,
      -- * Higher order puppet functions handling
      hfGenerateAssociations,
      hfSetvars,
      hfRestorevars,
      toNumbers
    ) where

import Puppet.PP
import Puppet.Interpreter.Types
import Puppet.Parser.Types
import Puppet.Interpreter.PrettyPrinter()
import Puppet.Parser.PrettyPrinter(showPos)
import Puppet.Interpreter.RubyRandom

import Data.Version (parseVersion)
import Text.ParserCombinators.ReadP (readP_to_S)

import Data.Maybe (fromMaybe)
import Data.Aeson hiding ((.=))
import Data.CaseInsensitive  ( mk )
import qualified Data.Vector as V
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Monoid
import Control.Applicative hiding ((<$>))
import Control.Monad
import Control.Monad.Error
import Data.Tuple.Strict as S
import Control.Lens
import Data.Maybe (mapMaybe)
import Data.Aeson.Lens hiding (key)
import Data.Attoparsec.Number
import qualified Data.Either.Strict as S
import qualified Data.Maybe.Strict as S
import qualified Data.ByteString as BS
import qualified Crypto.Hash.MD5 as MD5
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Data.ByteString.Base16 as B16
import Data.Bits
import Control.Monad.Writer (tell)
import Control.Monad.Operational (singleton)
import Text.Regex.PCRE.ByteString.Utils

-- | A useful type that is used when trying to perform arithmetic on Puppet
-- numbers.
type NumberPair = S.Either (Pair Integer Integer) (Pair Double Double)

-- | A hiera helper function, that will throw all Hiera errors and log
-- messages to the main monad.
runHiera :: T.Text -> HieraQueryType -> InterpreterMonad (S.Maybe PValue)
runHiera q t = do
    -- We need to merge the current scope with the top level scope
    scps <- use scopes
    ctx  <- getScopeName
    let getV scp = mapMaybe toStr $ HM.toList $ fmap (view (_1 . _1)) (scps ^. ix scp . scopeVariables)
        -- we can't use _PString, because of dependency cycles
        toStr (k,v) = case v of
                          PString x -> Just (k,x)
                          _ -> Nothing
        toplevels = map (_1 %~ ("::" <>)) $ getV "::"
        locals = getV ctx
        vars = HM.fromList (toplevels <> locals)
    (w :!: o) <- singleton (HieraQuery vars q t)
    tell w
    return o

-- | The implementation of all hiera_* functions
hieraCall :: HieraQueryType -> PValue -> (Maybe PValue) -> (Maybe PValue) -> InterpreterMonad PValue
hieraCall _ _ _ (Just _) = throwPosError "Overriding the hierarchy is not yet supported"
hieraCall qt q df _ = do
    qs <- resolvePValueString q
    o <- runHiera qs qt
    case o of
        S.Just p  -> return p
        S.Nothing -> case df of
                         Just d -> return d
                         Nothing -> throwPosError ("Lookup for " <> ttext qs <> " failed")

-- | Tries to convert a pair of 'PValue's into 'Number's, as defined in
-- attoparsec. If the two values can be converted, it will convert them so
-- that they are of the same type
toNumbers :: PValue -> PValue -> S.Maybe NumberPair
toNumbers (PString a) (PString b) =
    let t2s = fmap scientific2Number . text2Scientific
    in  case t2s a :!: t2s b of
            (Just (I x) :!: Just (I y)) -> S.Just (S.Left (x :!: y))
            (Just (D x) :!: Just (D y)) -> S.Just (S.Right (x :!: y))
            (Just (I x) :!: Just (D y)) -> S.Just (S.Right (fromIntegral x :!: y))
            (Just (D x) :!: Just (I y)) -> S.Just (S.Right (x :!: fromIntegral y))
            _ -> S.Nothing
toNumbers _ _ = S.Nothing

-- | This tries to run a numerical binary operation on two puppet
-- expressions. It will try to resolve them, then convert them to numbers
-- (using 'toNumbners'), and will finally apply the correct operation.
binaryOperation :: Expression -- ^ left operand
                -> Expression -- ^ right operand
                -> (Integer -> Integer -> Integer) -- ^ operation in case those are integers
                -> (Double -> Double -> Double) -- ^ operation in case those are doubles
                -> InterpreterMonad PValue
binaryOperation a b opi opd = do
    ra <- resolveExpression a
    rb <- resolveExpression b
    case toNumbers ra rb of
        S.Nothing -> throwPosError ("Expected numbers, not" <+> pretty ra <+> "or" <+> pretty rb)
        S.Just (S.Right (na :!: nb)) -> return (_Double  # opd na nb)
        S.Just (S.Left (na :!: nb))  -> return (_Integer # opi na nb)

-- | Just like 'binaryOperation', but for operations that only work on
-- integers.
integerOperation :: Expression -> Expression -> (Integer -> Integer -> Integer) -> InterpreterMonad PValue
integerOperation a b opr = do
    ra <- resolveExpression a
    rb <- resolveExpression b
    case toNumbers ra rb of
        S.Nothing -> throwPosError ("Expected numbers, not" <+> pretty ra <+> "or" <+> pretty rb)
        S.Just (S.Right _) -> throwPosError ("Expected integer values, not" <+> pretty ra <+> "or" <+> pretty rb)
        S.Just (S.Left (na :!: nb))  -> return (_Integer # opr na nb)

-- | Resolves a variable, or throws an error if it can't.
resolveVariable :: T.Text -> InterpreterMonad PValue
resolveVariable fullvar = do
    scps <- use scopes
    scp <- getScopeName
    case getVariable scps scp fullvar of
        Left rr -> throwPosError rr
        Right x -> return x

-- | A simple helper that checks if a given type is native or a define.
isNativeType :: T.Text -> InterpreterMonad Bool
isNativeType t = has (ix t) `fmap` (singleton GetNativeTypes)

-- | A pure function for resolving variables.
getVariable :: Container ScopeInformation -- ^ The whole scope data.
            -> T.Text -- ^ Current scope name.
            -> T.Text -- ^ Full variable name.
            -> Either Doc PValue
getVariable scps scp fullvar = do
    (varscope, varname) <- case T.splitOn "::" fullvar of
                               [] -> throwError "This doesn't make any sense in resolveVariable"
                               [vn] -> return (scp, vn) -- Non qualified variables
                               rst -> return (T.intercalate "::" (filter (not . T.null) (init rst)), last rst) -- qualified variables
    let extractVariable (varval :!: _ :!: _) = return varval
    case scps ^? ix varscope . scopeVariables . ix varname of
        Just pp -> extractVariable pp
        Nothing -> -- check top level scope
            case scps ^? ix "::" . scopeVariables . ix varname of
                Just pp -> extractVariable pp
                Nothing -> throwError ("Could not resolve variable" <+> pretty (UVariableReference fullvar) <+> "in context" <+> ttext varscope <+> "or root")

-- | A helper for numerical comparison functions.
numberCompare :: Expression -> Expression -> (Integer -> Integer -> Bool) -> (Double -> Double -> Bool) -> InterpreterMonad PValue
numberCompare a b compi compd = do
    ra <- resolveExpression a
    rb <- resolveExpression b
    case toNumbers ra rb of
        S.Nothing -> throwPosError ("Comparison functions expect numbers, not:" <+> pretty ra <+> comma <+> pretty rb)
        S.Just (S.Right (na :!: nb)) -> return (PBoolean (compd na nb))
        S.Just (S.Left  (na :!: nb)) -> return (PBoolean (compi na nb))

-- | Handles the wonders of puppet equality checks.
puppetEquality :: PValue -> PValue -> Bool
puppetEquality ra rb =
    case toNumbers ra rb of
        (S.Just (S.Right (na :!: nb))) -> na == nb
        (S.Just (S.Left (na :!: nb))) -> na == nb
        _ -> case (ra, rb) of
                 (PUndef , PBoolean x)         -> not x
                 (PString "true", PBoolean x)  -> x
                 (PString "false", PBoolean x) -> not x
                 (PBoolean x, PString "true")  -> x
                 (PBoolean x, PString "false") -> not x
                 (PString sa, PString sb)      -> mk sa == mk sb
                 -- TODO, check if array / hash equality should be recursed
                 -- for case insensitive matching
                 _ -> ra == rb

-- | The main resolution function : turns an 'Expression' into a 'PValue',
-- if possible.
resolveExpression :: Expression -> InterpreterMonad PValue
resolveExpression (PValue v) = resolveValue v
resolveExpression (Not e) = fmap (PBoolean . not . pValue2Bool) (resolveExpression e)
resolveExpression (And a b) = do
    ra <- fmap pValue2Bool (resolveExpression a)
    if ra
        then do
            rb <- fmap pValue2Bool (resolveExpression b)
            return (PBoolean (ra && rb))
        else return (PBoolean False)
resolveExpression (Or a b) = do
    ra <- fmap pValue2Bool (resolveExpression a)
    if ra
        then return (PBoolean True)
        else do
            rb <- fmap pValue2Bool (resolveExpression b)
            return (PBoolean (ra || rb))
resolveExpression (LessThan a b) = numberCompare a b (<) (<)
resolveExpression (MoreThan a b) = numberCompare a b (>) (>)
resolveExpression (LessEqualThan a b) = numberCompare a b (<=) (<=)
resolveExpression (MoreEqualThan a b) = numberCompare a b (>=) (>=)
resolveExpression (RegexMatch a v@(PValue (URegexp _ rv))) = do
    ra <- fmap T.encodeUtf8 (resolveExpressionString a)
    case execute' rv ra of
        Left (_,rr)    -> throwPosError ("Error when evaluating" <+> pretty v <+> ":" <+> string rr)
        Right Nothing  -> return $ PBoolean False
        Right (Just _) -> return $ PBoolean True
resolveExpression (RegexMatch _ t) = throwPosError ("The regexp matching operator expects a regular expression, not" <+> pretty t)
resolveExpression (NotRegexMatch a v) = resolveExpression (Not (RegexMatch a v))
resolveExpression (Equal a b) = do
    ra <- resolveExpression a
    rb <- resolveExpression b
    return $ PBoolean $ puppetEquality ra rb
resolveExpression (Different a b) = resolveExpression (Not (Equal a b))
resolveExpression (Contains idx a) =
    resolveExpression a >>= \case
        PHash h -> do
            ridx <- resolveExpressionString idx
            case h ^. at ridx of
                Just _ -> return (PBoolean True)
                Nothing -> return (PBoolean False)
        PArray ar -> do
            ridx <- resolveExpression idx
            return (PBoolean (ridx `V.elem` ar))
        PString st -> do
            ridx <- resolveExpressionString idx
            return (PBoolean (ridx `T.isInfixOf` st))
        src -> throwPosError ("Can't use the 'in' operator with" <+> pretty src)
resolveExpression (Lookup a idx) =
    resolveExpression a >>= \case
        PHash h -> do
            ridx <- resolveExpressionString idx
            case h ^. at ridx of
                Just v -> return v
                Nothing -> throwPosError ("Can't find index '" <> ttext ridx <> "' in" <+> pretty (PHash h))
        PArray ar -> do
            ridx <- resolveExpression idx
            i <- case ridx ^? _Integer of
                     Just n -> return (fromIntegral n)
                     _ -> throwPosError ("Need an integral number for indexing an array, not" <+> pretty ridx)
            let arl = V.length ar
            if arl <= i
                then throwPosError ("Out of bound indexing, array size is" <+> int arl <+> "index is" <+> int i)
                else return (ar V.! i)
        src -> throwPosError ("This data can't be indexed:" <+> pretty src)
resolveExpression stmt@(ConditionalValue e conds) = do
    rese <- resolveExpression e
    let checkCond [] = throwPosError ("The selector didn't match anything for input" <+> pretty rese </> pretty stmt)
        checkCond ((SelectorDefault :!: ce) : _) = resolveExpression ce
        checkCond ((SelectorValue v@(URegexp _ rg) :!: ce) : xs) = do
            rs <- fmap T.encodeUtf8 (resolvePValueString rese)
            case execute' rg rs of
                Left (_,rr)    -> throwPosError ("Could not match" <+> pretty v <+> ":" <+> string rr)
                Right Nothing  -> checkCond xs
                Right (Just _) -> resolveExpression ce
        checkCond ((SelectorValue uv :!: ce) : xs) = do
            rv <- resolveValue uv
            if puppetEquality rese rv
                then resolveExpression ce
                else checkCond xs
    checkCond (V.toList conds)
resolveExpression (Addition a b)       = binaryOperation a b (+) (+)
resolveExpression (Substraction a b)   = binaryOperation a b (-) (-)
resolveExpression (Division a b)       = binaryOperation a b div (/)
resolveExpression (Multiplication a b) = binaryOperation a b (*) (*)
resolveExpression (Modulo a b)         = integerOperation a b mod
resolveExpression (RightShift a b)     = integerOperation a b (\x -> shiftR x . fromIntegral)
resolveExpression (LeftShift a b)      = integerOperation a b (\x -> shiftL x . fromIntegral)
resolveExpression a@(FunctionApplication e (PValue (UHFunctionCall hf))) = do
    unless (S.isNothing (hf ^. hfexpr)) (throwPosError ("You can't combine chains of higher order functions (with .) and giving them parameters, in:" <+> pretty a))
    resolveValue (UHFunctionCall (hf & hfexpr .~ S.Just e))
resolveExpression (FunctionApplication _ x) = throwPosError ("Expected function application here, not" <+> pretty x)
resolveExpression x = throwPosError ("Don't know how to resolve this expression:" <$> pretty x)

-- | Resolves an 'UValue' (terminal for the 'Expression' data type) into
-- a 'PValue'
resolveValue :: UValue -> InterpreterMonad PValue
resolveValue n@(URegexp _ _) = throwPosError ("Regular expressions are not allowed in this context: " <+> pretty n)
resolveValue (UBoolean x) = return (PBoolean x)
resolveValue (UString x) = return (PString x)
resolveValue UUndef = return PUndef
resolveValue (UInterpolable vals) = fmap (PString . mconcat) (mapM resolveValueString (V.toList vals))
resolveValue (UResourceReference t e) = do
    r <- resolveExpressionStrings e
    case r of
        [s] -> return (PResourceReference t s)
        _   -> return (PArray (V.fromList (map (\s -> PResourceReference t s) r)))
resolveValue (UArray a) = fmap PArray (V.mapM resolveExpression a)
resolveValue (UHash a) = fmap (PHash . HM.fromList) (mapM resPair (V.toList a))
    where
        resPair (k :!: v) = (,) `fmap` resolveExpressionString k <*> resolveExpression v
resolveValue (UVariableReference v) = resolveVariable v
resolveValue (UFunctionCall fname args) = resolveFunction fname args
resolveValue (UHFunctionCall hf) = evaluateHFCPure hf

-- | Turns strings and booleans into 'T.Text', or throws an error.
resolvePValueString :: PValue -> InterpreterMonad T.Text
resolvePValueString (PString x) = return x
resolvePValueString (PBoolean True) = return "true"
resolvePValueString (PBoolean False) = return "false"
resolvePValueString x = throwPosError ("Don't know how to convert this to a string:" <$> pretty x)

-- | > resolveValueString = resolveValue >=> resolvePValueString
resolveValueString :: UValue -> InterpreterMonad T.Text
resolveValueString = resolveValue >=> resolvePValueString

-- | > resolveExpressionString = resolveExpression >=> resolvePValueString
resolveExpressionString :: Expression -> InterpreterMonad T.Text
resolveExpressionString = resolveExpression >=> resolvePValueString

-- | Just like 'resolveExpressionString', but accepts arrays.
resolveExpressionStrings :: Expression -> InterpreterMonad [T.Text]
resolveExpressionStrings x =
    resolveExpression x >>= \case
        PArray a -> mapM resolvePValueString (V.toList a)
        y -> fmap return (resolvePValueString y)

-- | A special helper function for argument like argument like pairs.
resolveArgument :: Pair T.Text Expression -> InterpreterMonad (Pair T.Text PValue)
resolveArgument (argname :!: argval) = (:!:) `fmap` pure argname <*> resolveExpression argval

-- | Turns a 'PValue' into a 'Bool', as explained in the reference
-- documentation.
pValue2Bool :: PValue -> Bool
pValue2Bool PUndef = False
pValue2Bool (PString "") = False
pValue2Bool (PBoolean x) = x
pValue2Bool _ = True

-- | This resolve function calls at the expression level.
resolveFunction :: T.Text -> V.Vector Expression -> InterpreterMonad PValue
resolveFunction "fqdn_rand" args = do
    let nbargs = V.length args
    when (nbargs < 1 || nbargs > 2) (throwPosError "fqdn_rand(): Expects one or two arguments")
    fqdn <- resolveVariable "::fqdn" >>= resolvePValueString
    (mx:targs) <- mapM resolveExpressionString (V.toList args)
    curmax <- case PString mx ^? _Integer of
                  Just x -> return x
                  _ -> throwPosError ("fqdn_rand(): the first argument must be an integer, not" <+> ttext mx)
    let rargs = if null targs
                 then [fqdn, ""]
                 else fqdn : targs
        val = fromIntegral (Prelude.fst (limitedRand (randInit myhash) (fromIntegral curmax)))
        myhash = toint (MD5.hash (T.encodeUtf8 fullstring)) :: Integer
        toint = BS.foldl' (\c nx -> c*256 + fromIntegral nx) 0
        fullstring = T.intercalate ":" rargs
    return (_Integer # val)
resolveFunction fname args = mapM resolveExpression (V.toList args) >>= resolveFunction' fname . map undefEmptyString
    where
        undefEmptyString PUndef = PString ""
        undefEmptyString x = x

resolveFunction' :: T.Text -> [PValue] -> InterpreterMonad PValue
resolveFunction' "defined" [PResourceReference rt rn] = fmap (PBoolean . has (ix (RIdentifier rt rn))) (use definedResources)
resolveFunction' "defined" [ut] = do
    t <- resolvePValueString ut
    -- case 1, netsted thingie
    nestedStuff <- use nestedDeclarations
    if (has (ix (TopDefine, t)) nestedStuff) || (has (ix (TopClass, t)) nestedStuff)
        then return (PBoolean True)
        else do -- case 2, loadeded class
            lc <- use loadedClasses
            if has (ix t) lc
                then return (PBoolean True)
                else fmap PBoolean (isNativeType t)
resolveFunction' "defined" x = throwPosError ("defined(): expects a single resource reference, type or class name, and not" <+> pretty x)
resolveFunction' "fail" x = throwPosError ("fail:" <+> pretty x)
resolveFunction' "inline_template" [templatename] = calcTemplate Left templatename
resolveFunction' "inline_template" _ = throwPosError "inline_template(): Expects a single argument"
resolveFunction' "md5" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . MD5.hash  . T.encodeUtf8) (resolvePValueString pstr)
resolveFunction' "md5" _ = throwPosError "md5(): Expects a single argument"
resolveFunction' "regsubst" [ptarget, pregexp, preplacement] = resolveFunction' "regsubst" [ptarget, pregexp, preplacement, PString "G"]
resolveFunction' "regsubst" [ptarget, pregexp, preplacement, pflags] = do
    -- TODO handle all the flags
    -- http://docs.puppetlabs.com/references/latest/function.html#regsubst
    when (pflags /= "G") (use curPos >>= \p -> warn ("regsubst(): Currently only supports a single flag (G) " <> showPos (S.fst p)))
    target      <- fmap T.encodeUtf8 (resolvePValueString ptarget)
    regexp      <- fmap T.encodeUtf8 (resolvePValueString pregexp)
    replacement <- fmap T.encodeUtf8 (resolvePValueString preplacement)
    case substituteCompile' regexp target replacement of
        Left rr -> throwPosError ("regsubst():" <+> string rr)
        Right x -> fmap PString (safeDecodeUtf8 x)
resolveFunction' "regsubst" _ = throwPosError "regsubst(): Expects 3 or 4 arguments"
resolveFunction' "split" [psrc, psplt] = do
    src  <- fmap T.encodeUtf8 (resolvePValueString psrc)
    splt <- fmap T.encodeUtf8 (resolvePValueString psplt)
    case splitCompile' splt src of
        Left rr -> throwPosError ("splitCompile():" <+> string rr)
        Right x -> fmap (PArray . V.fromList) (mapM (fmap PString . safeDecodeUtf8) x)
resolveFunction' "sha1" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . SHA1.hash  . T.encodeUtf8) (resolvePValueString pstr)
resolveFunction' "sha1" _ = throwPosError "sha1(): Expects a single argument"
resolveFunction' "mysql_password" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . SHA1.hash . SHA1.hash  . T.encodeUtf8) (resolvePValueString pstr)
resolveFunction' "mysql_password" _ = throwPosError "mysql_password(): Expects a single argument"
resolveFunction' "file" args = mapM resolvePValueString args >>= fmap PString . singleton . ReadFile
resolveFunction' "tagged" ptags = do
    tags <- fmap HS.fromList (mapM resolvePValueString ptags)
    scp <- getScopeName
    scpset <- use (scopes . ix scp . scopeExtraTags)
    return (PBoolean (scpset `HS.intersection` tags == tags))
resolveFunction' "template" [templatename] = calcTemplate Right templatename
resolveFunction' "template" _ = throwPosError "template(): Expects a single argument"
resolveFunction' "versioncmp" [pa,pb] = do
    a <- resolvePValueString pa
    b <- resolvePValueString pb
    let parser x = case filter (null . Prelude.snd) (readP_to_S parseVersion (T.unpack x)) of
                       ( (v, _) : _ ) -> return v
                       _ -> throwPosError ("Could not parse this string as a version:" <+> ttext x)
    va <- parser a
    vb <- parser b
    return $ PString $ case compare va vb of
                           EQ -> "0"
                           LT -> "-1"
                           GT -> "1"
resolveFunction' "versioncmp" _ = throwPosError "versioncmp(): Expects two arguments"
-- some custom functions
resolveFunction' "pdbresourcequery" [q] = pdbresourcequery q Nothing
resolveFunction' "pdbresourcequery" [q,k] = fmap Just (resolvePValueString k) >>= pdbresourcequery q
resolveFunction' "pdbresourcequery" _ = throwPosError "pdbresourcequery(): Expects one or two arguments"
resolveFunction' "hiera"       [q]     = hieraCall Priority   q Nothing  Nothing
resolveFunction' "hiera"       [q,d]   = hieraCall Priority   q (Just d) Nothing
resolveFunction' "hiera"       [q,d,o] = hieraCall Priority   q (Just d) (Just o)
resolveFunction' "hiera_array" [q]     = hieraCall ArrayMerge q Nothing  Nothing
resolveFunction' "hiera_array" [q,d]   = hieraCall ArrayMerge q (Just d) Nothing
resolveFunction' "hiera_array" [q,d,o] = hieraCall ArrayMerge q (Just d) (Just o)
resolveFunction' "hiera_hash"  [q]     = hieraCall HashMerge  q Nothing  Nothing
resolveFunction' "hiera_hash"  [q,d]   = hieraCall HashMerge  q (Just d) Nothing
resolveFunction' "hiera_hash"  [q,d,o] = hieraCall HashMerge  q (Just d) (Just o)
resolveFunction' "hiera" _ = throwPosError "hiera(): Expects one, two or three arguments"

-- user functions
resolveFunction' fname args = singleton (ExternalFunction fname args)

pdbresourcequery :: PValue -> Maybe T.Text -> InterpreterMonad PValue
pdbresourcequery q mkey = do
    rrv <- case fromJSON (toJSON q) of
               Success rq -> singleton (PDBGetResources rq)
               Error rr   -> throwPosError ("Invalid resource query:" <+> Puppet.PP.string rr)
    rv <- case fromJSON (toJSON rrv) of
              Success x -> return x
              Error rr -> throwPosError ("For some reason we could not convert a resource list to Puppet internal values!!" <+> Puppet.PP.string rr <+> pretty rrv)
    let extractSubHash :: T.Text -> PValue -> InterpreterMonad PValue
        extractSubHash ky (PHash h) = case h ^. at ky of
                                         Just val -> return val
                                         Nothing -> throwPosError ("pdbresourcequery strange error, could not find key" <+> ttext ky <+> "in" <+> pretty (PHash h))
        extractSubHash _ x = throwPosError ("pdbresourcequery strange error, expected a hash, had" <+> pretty x)
    case mkey of
        Nothing -> return (PArray rv)
        (Just k) -> fmap PArray (V.mapM (extractSubHash k) rv)

calcTemplate :: (T.Text -> Either T.Text T.Text) -> PValue -> InterpreterMonad PValue
calcTemplate templatetype templatename = do
    fname       <- resolvePValueString templatename
    classes     <- (PArray . V.fromList . map PString . HM.keys) `fmap` use loadedClasses
    scp         <- getScopeName
    scps        <- use scopes
    -- inject the special template variables (just classes for now)
    let cd = fromMaybe ContRoot (scps ^? ix scp . scopeContainer . cctype) -- get the current containder description
        -- Inject the classes variable. Note that we are relying on the
        -- invariant that the scope is already entered, and hence present
        -- in the scps container.
        cscps = scps & ix scp . scopeVariables . at "classes" ?~ ( classes :!: initialPPos "dummy" :!: cd )
    PString `fmap` singleton (ComputeTemplate (templatetype fname) scp cscps)

resolveExpressionSE :: Expression -> InterpreterMonad PValue
resolveExpressionSE e = resolveExpression e >>=
    \case
        PArray _ -> throwPosError "The use of an array in a search expression is undefined"
        PHash _  -> throwPosError "The use of an array in a search expression is undefined"
        resolved -> return resolved

-- | Turns an unresolved 'SearchExpression' from the parser into a fully
-- resolved 'RSearchExpression'.
resolveSearchExpression :: SearchExpression -> InterpreterMonad RSearchExpression
resolveSearchExpression AlwaysTrue = return RAlwaysTrue
resolveSearchExpression (EqualitySearch a e) = REqualitySearch `fmap` pure a <*> resolveExpressionSE e
resolveSearchExpression (NonEqualitySearch a e) = RNonEqualitySearch `fmap` pure a <*> resolveExpressionSE e
resolveSearchExpression (AndSearch e1 e2) = RAndSearch `fmap` resolveSearchExpression e1 <*> resolveSearchExpression e2
resolveSearchExpression (OrSearch e1 e2) = ROrSearch `fmap` resolveSearchExpression e1 <*> resolveSearchExpression e2

-- | Turns a resource type and 'RSearchExpression' into something that can
-- be used in a PuppetDB query.
searchExpressionToPuppetDB :: T.Text -> RSearchExpression -> Query ResourceField
searchExpressionToPuppetDB rtype res = QAnd ( QEqual RType (capitalizeRT rtype) : mkSE res )
    where
        mkSE (RAndSearch a b) = [QAnd (mkSE a ++ mkSE b)]
        mkSE (ROrSearch a b) = [QOr (mkSE a ++ mkSE b)]
        mkSE (RNonEqualitySearch a b) = fmap QNot (mkSE (REqualitySearch a b))
        mkSE (REqualitySearch a (PString b)) = [QEqual (mkFld a) b]
        mkSE _ = []
        mkFld "tag" = RTag
        mkFld "title" = RTitle
        mkFld z = RParameter z

-- | Checks whether a given 'Resource' matches a 'RSearchExpression'. Note
-- that the expression doesn't check for type, so you must filter the
-- resources by type beforehand, if needs be.
checkSearchExpression :: RSearchExpression -> Resource -> Bool
checkSearchExpression RAlwaysTrue _ = True
checkSearchExpression (RAndSearch a b) r = checkSearchExpression a r && checkSearchExpression b r
checkSearchExpression (ROrSearch a b) r = checkSearchExpression a r || checkSearchExpression b r
checkSearchExpression (RNonEqualitySearch a b) r = not (checkSearchExpression (REqualitySearch a b) r)
checkSearchExpression (REqualitySearch "tag" (PString s)) r = r ^. rtags . contains s
checkSearchExpression (REqualitySearch "tag" _) _ = False
checkSearchExpression (REqualitySearch "title" v) r =
    let nameequal = puppetEquality v (PString (r ^. rid . iname))
        aliasequal = case r ^. rattributes . at "alias" of
                         Just a -> puppetEquality v a
                         Nothing -> False
    in nameequal || aliasequal
checkSearchExpression (REqualitySearch attributename v) r = case r ^. rattributes . at attributename of
                                                                Nothing -> False
                                                                Just x -> puppetEquality x v

-- | Generates variable associations for evaluation of blocks. Each item
-- corresponds to an iteration in the calling block.
hfGenerateAssociations :: HFunctionCall -> InterpreterMonad [[(T.Text, PValue)]]
hfGenerateAssociations hf = do
    sourceexpression <- case hf ^. hfexpr of
                            S.Just x -> return x
                            S.Nothing -> throwPosError ("No expression to run the function on" <+> pretty hf)
    sourcevalue <- resolveExpression sourceexpression
    case (sourcevalue, hf ^. hfparams) of
         (PArray pr, BPSingle varname) -> return (map (\x -> [(varname, x)]) (V.toList pr))
         (PArray pr, BPPair idx var) -> return $ do
             (i,v) <- Prelude.zip ([0..] :: [Int]) (V.toList pr)
             return [(idx,PString (T.pack (show i))),(var,v)]
         (PHash hh, BPSingle varname) -> return $ do
             (k,v) <- HM.toList hh
             return [(varname, PArray (V.fromList [PString k,v]))]
         (PHash hh, BPPair idx var) -> return $ do
             (k,v) <- HM.toList hh
             return [(idx,PString k),(var,v)]
         (invalid, _) -> throwPosError ("Can't iterate on this data type:" <+> pretty invalid)

-- | Sets the proper variables, and returns the scope variables the way
-- they were before being modified. This is a hack that ensures that
-- variables are local to the new scope.
--
-- It doesn't work at all like other Puppet parts, but consistency isn't
-- really expected here ...
hfSetvars :: [(T.Text, PValue)] -> InterpreterMonad (Container (Pair (Pair PValue PPosition) CurContainerDesc))
hfSetvars vals =
    do
        scp <- getScopeName
        p <- use curPos
        container <- getCurContainer
        save <- use (scopes . ix scp . scopeVariables)
        let hfSetvar (varname, varval) = scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: (container ^. cctype))
        mapM_ hfSetvar vals
        return save

-- | Restores what needs restoring. This will erase all allocations.
hfRestorevars :: Container (Pair (Pair PValue PPosition) CurContainerDesc) -> InterpreterMonad ()
hfRestorevars save =
    do
        scp <- getScopeName
        scopes . ix scp . scopeVariables .= save

-- | Evaluates a statement in "pure" mode. TODO
evalPureStatement :: Statement -> InterpreterMonad ()
evalPureStatement _ = throwPosError "So called 'pure' statements are not yet supported"

-- | This extracts the final expression from an HFunctionCall.
-- When it does not exists, it checks if the last statement is in fact
-- a function call
transformPureHf :: HFunctionCall -> InterpreterMonad (HFunctionCall, Expression)
transformPureHf hf =
        case hf ^. hfexpression of
            S.Just x -> return (hf, x)
            S.Nothing -> do
                let statements = hf ^. hfstatements
                if V.null statements
                    then throwPosError ("The statement block must not be empty" <+> pretty hf)
                    else case V.last statements of
                             (MainFunctionCall fn args _) ->
                                let expr = PValue (UFunctionCall fn args)
                                in  return (hf & hfstatements %~ V.init
                                               & hfexpression .~ S.Just expr
                                           , expr)
                             _ -> throwPosError ("The statement block must end with an expression" <+> pretty hf)

-- | All the "higher order function" stuff, for "value" mode. In this case
-- we are in "pure" mode, and only a few statements are allowed.
evaluateHFCPure :: HFunctionCall -> InterpreterMonad PValue
evaluateHFCPure hf' = do
    (hf, finalexpression) <- transformPureHf hf'
    varassocs <- hfGenerateAssociations hf
    let runblock :: [(T.Text, PValue)] -> InterpreterMonad PValue
        runblock assocs = do
            saved <- hfSetvars assocs
            V.mapM_ evalPureStatement (hf ^. hfstatements)
            r <- resolveExpression finalexpression
            hfRestorevars  saved
            return r
    case hf ^. hftype of
        HFEach -> throwPosError "The 'each' function can't be used at the value level in language-puppet. Please use map."
        HFMap -> fmap (PArray . V.fromList) (mapM runblock varassocs)
        HFFilter -> do
            res <- mapM (fmap pValue2Bool . runblock) varassocs
            sourcevalue <- case hf ^. hfexpr of
                               S.Just x -> resolveExpression x
                               S.Nothing -> throwPosError "Internal error evaluateHFCPure 1"
            case sourcevalue of
                PArray ar -> return $ PArray             $ V.map Prelude.fst $ V.filter Prelude.snd       $ V.zip ar             (V.fromList res)
                PHash  hh -> return $ PHash  $ HM.fromList $ map Prelude.fst   $ filter Prelude.snd $ Prelude.zip (HM.toList hh) res
                x -> throwPosError ("Can't iterate on this data type:" <+> pretty x)
        x -> throwPosError ("This type of function is not supported yet by language-puppet!" <+> pretty x)