{-# 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 and prisms
      _PString,
      _PInteger,
      pvnum,
      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,
    ) 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.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.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
import Control.Monad.Writer (tell)

-- | 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
    hquery <- view hieraQuery
    scps <- use scopes
    (w :!: o) <- interpreterIO (hquery scps 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) =
    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

-- | 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 (pvnum # D (opd na nb))
        S.Just (S.Left (na :!: nb))  -> return (pvnum # I (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 (pvnum # I (opr na nb))

-- | A prism between 'PValue' and 'Number'
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

-- | A prism between 'PValue' and 'T.Text'
_PString :: Prism' PValue T.Text
_PString = prism PString $ \x -> case x of
                                     PString s -> Right s
                                     n -> Left n

-- | A prism between 'PValue' and 'Integer'
_PInteger :: Prism' PValue Integer
_PInteger = prism (PString . T.pack . show) $ \x -> case x ^? pvnum of
                                                        Just (I z) -> Right z
                                                        _ -> Left x

-- | 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 = view (nativeTypes . contains t)

-- | 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)
    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)

-- | 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) = 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

-- | 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 ^? 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 <- 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 = 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
    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 )
    computeFunc <- view computeTemplateFunction
    liftIO (computeFunc (templatetype fname) scp cscps)
        >>= \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

-- | 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)