language-puppet-0.2.0: Puppet/Interpreter/Catalog.hs
{-| This module exports the 'getCatalog' function, that computes catalogs from
parsed manifests. The behaviour of this module is probably non canonical on many
details. The problem is that most of Puppet behaviour is undocumented or
extremely vague. It might be possible to delve into the source code or to write
tests, but ruby is unreadable and tests are boring.
Here is a list of known discrepencies with Puppet :
* Resources references using the \<| |\> syntax are not yet supported.
* Things defined in classes that are not included cannot be accessed. In vanilla
puppet, you can use subclass to classes that are not imported themselves.
* Amending attributes with a reference will not cause an error when done out of
an inherited class.
* Variables $0 to $9, set after regexp matching, are not handled.
* Tags work like regular parameters, and are not automatically populated or inherited.
* Modules, nodes, classes and type names starting with _ are allowed.
* Arrows between resource declarations or collectors are not yet handled.
* Reversed form arrows are not handled.
* Node inheritance is not handled, and class inheritance seems to work well,
but is probably not Puppet-perfect.
-}
module Puppet.Interpreter.Catalog (
getCatalog
) where
import Puppet.DSL.Types
import Puppet.Interpreter.Functions
import Puppet.Interpreter.Types
import Puppet.Printers
import Puppet.Plugins
import qualified PuppetDB.Query as PDB
import System.IO.Unsafe
import Data.List
import Data.Char (isDigit,toLower,toUpper, isAlpha, isAlphaNum, isSpace)
import Data.Maybe (isJust, fromJust, catMaybes, isNothing)
import Data.Either (lefts, rights, partitionEithers)
import Data.Ord (comparing)
import Text.Parsec.Pos
import Control.Monad.State
import Control.Monad.Error
import qualified Data.Map as Map
import qualified Data.Set as Set
-- Utility function used to check if the there are duplicates a in [(a,_)]
checkDuplicateFirst :: (Show a, Eq a) => [(a,b)] -> CatalogMonad ()
checkDuplicateFirst list =
let fsts = ldups (map fst list) []
ldups [] a = a
ldups (x:xs) a | x `elem` xs = x:a
| otherwise = ldups xs a
in unless (null fsts) $ throwPosError $ "Duplicate parameters " ++ show fsts
qualified [] = False
qualified str = isPrefixOf "::" str || qualified (tail str)
-- Int handling stuff
isInt :: String -> Bool
isInt = all isDigit
readint :: String -> CatalogMonad Integer
readint x = if isInt x
then return (read x)
else throwPosError $ "Expected an integer instead of '" ++ x
getCatalog :: (TopLevelType -> String -> IO (Either String Statement))
-- ^ The \"get statements\" function. Given a top level type and its name it
-- should return the corresponding statement.
-> (String -> String -> [(String, GeneralValue)] -> IO (Either String String))
-- ^ The \"get template\" function. Given a file name, a scope name and a
-- list of variables, it should return the computed template.
-> Maybe (String -> PDB.Query -> IO (Either String [CResource]))
-- ^ The \"puppetDB Rest API\" function. Given the machine fqdn, a request
-- type (resources, nodes, facts, ..) and a query, it returns a
-- ResolvedValue, or some error.
-> String -- ^ Name of the node.
-> Facts -- ^ Facts of this node.
-> Maybe String -- ^ Path to the modules, for user plugins. If set to Nothing, plugins are disabled.
-> Map.Map PuppetTypeName PuppetTypeMethods -- ^ The list of native types
-> IO (Either String FinalCatalog, [String])
getCatalog getstatements gettemplate puppetdb nodename facts modules ntypes = do
let convertedfacts = Map.map
(\fval -> (Right fval, initialPos "FACTS"))
facts
(luastate, userfunctions) <- case modules of
Just m -> fmap (\(a,b) -> (Just a, b)) (initLua m)
Nothing -> return (Nothing, [])
(output, finalstate) <- runStateT ( runErrorT ( computeCatalog getstatements nodename ) )
(ScopeState
{ curScope = [["::"]]
, curVariables = convertedfacts
, curClasses = Map.empty
, curDefaults = []
, curResId = 1
, curPos = (initialPos "dummy")
, nestedtoplevels = Map.empty
, getStatementsFunction = getstatements
, getWarnings = []
, curCollect = []
, unresolvedRels = []
, computeTemplateFunction = gettemplate
, puppetDBFunction = puppetdb
, luaState = luastate
, userFunctions = Set.fromList userfunctions
, nativeTypes = ntypes
} )
case luastate of
Just l -> closeLua l
Nothing -> return ()
case output of
Left x -> return (Left x, getWarnings finalstate)
Right _ -> return (output, getWarnings finalstate)
computeCatalog :: (TopLevelType -> String -> IO (Either String Statement)) -> String -> CatalogMonad FinalCatalog
computeCatalog getstatements nodename = do
nodestatements <- liftIO $ getstatements TopNode nodename
case nodestatements of
Left x -> throwError x
Right nodestmts -> evaluateStatements nodestmts >>= finalResolution
-- this validates the resolved resources
-- it should only be called with native types or the validatefunction lookup with abord with an error
finalizeResource :: CResource -> CatalogMonad (ResIdentifier, RResource)
finalizeResource cr@(CResource cid cname ctype cparams _ cpos) = do
setPos cpos
rname <- resolveGeneralString cname
rparams <- mapM (\(a,b) -> do { ra <- resolveGeneralString a; rb <- resolveGeneralValue b; return (ra,rb); }) cparams
checkDuplicateFirst rparams
-- add collected relations
-- TODO
ntypes <- fmap nativeTypes get
unless (Map.member ctype ntypes) $ throwPosError $ "Can't find native type " ++ ctype
-- now run the collection checks for overrides
nparams <- processOverride cr (Map.fromList rparams)
let mrrelations = []
prefinalresource = RResource cid rname ctype nparams mrrelations cpos
validatefunction = puppetvalidate (ntypes Map.! ctype)
validated = validatefunction prefinalresource
case validated of
Left err -> throwError (err ++ " for resource " ++ ctype ++ "[" ++ rname ++ "] at " ++ show cpos)
Right finalresource -> return ((ctype, rname), finalresource)
-- This checks if a resource is to be collected.
-- This returns a list as it can either return the original
-- resource, the resource with a "normal" virtuality, or both,
-- for exported resources (so that they can still be found as collected)
collectionChecks :: CResource -> CatalogMonad [CResource]
collectionChecks res =
if crvirtuality res == Normal
then return [res]
else do
-- Note that amending attributes with a collector does collect virtual
-- values. Hence no filtering on the collectors is done here.
isCollected <- liftM curCollect get >>= mapM (\(x, _, _) -> x res)
case (or isCollected, crvirtuality res) of
(True, Exported) -> return [res { crvirtuality = Normal }, res]
(True, _) -> return [res { crvirtuality = Normal } ]
(False, _) -> return [res ]
processOverride :: CResource -> Map.Map String ResolvedValue -> CatalogMonad (Map.Map String ResolvedValue)
processOverride cr prms =
let applyOverride :: CResource -> Map.Map String ResolvedValue -> (CResource -> CatalogMonad Bool, [(GeneralString, GeneralValue)], Maybe PDB.Query) -> CatalogMonad (Map.Map String ResolvedValue)
-- this checks if the collection function matches
applyOverride c prm (func, overs, _) = do
check <- func c
if check
then foldM tryReplace prm overs
else return prm
tryReplace :: Map.Map String ResolvedValue -> (GeneralString, GeneralValue) -> CatalogMonad (Map.Map String ResolvedValue)
-- if it does, this resolves the override and applies it
-- this is obviously wasteful
tryReplace curmap (gs, gv) = do
rs <- resolveGeneralString gs
rv <- resolveGeneralValue gv
return $ Map.insert rs rv curmap
-- Collectors are filtered so that only those with overrides are passed to the fold.
in liftM (filter (\(_, x, _) -> not $ null x) . curCollect) get >>= foldM (applyOverride cr) prms
retrieveRemoteResources :: (PDB.Query -> IO (Either String [CResource])) -> PDB.Query -> CatalogMonad [CResource]
retrieveRemoteResources f q = do
res <- liftIO $ f q
hashes <- case res of
Right h -> return h
Left err -> throwError $ "PuppetDB error: " ++ err
return hashes
extractRelations :: CResource -> CatalogMonad CResource
extractRelations cr = do
let (params, rels) = partitionParamsRelations (crparams cr)
-- TODO export relations
return cr { crparams = params }
finalResolution :: Catalog -> CatalogMonad FinalCatalog
finalResolution cat = do
pdbfunction <- fmap puppetDBFunction get
fqdnr <- getVariable "::fqdn"
collectedRemote <- case pdbfunction of
Just f -> do
fqdn <- case fqdnr of
Just (Right (ResolvedString f'), _) -> return f'
_ -> throwError "Could not get FQDN during final resolution"
remoteCollects <- fmap (catMaybes . map (\(_,_,x) -> x) . curCollect) get
fmap concat (mapM (retrieveRemoteResources (f fqdn)) remoteCollects)
Nothing -> return []
collectedRemote' <- mapM extractRelations collectedRemote
collectedLocal <- fmap concat (mapM collectionChecks cat)
collected <- mapM evaluateDefine (collectedLocal ++ collectedRemote')
let (real, allvirtual) = partition (\x -> crvirtuality x == Normal) (concat collected)
(_, exported) = partition (\x -> crvirtuality x == Virtual) allvirtual
-- TODO
--export stuff
--liftIO $ putStrLn "EXPORTED:"
--liftIO $ mapM print exported
--get >>= return . unresolvedRels >>= liftIO . (mapM print)
mapM finalizeResource real >>= createResourceMap
createResourceMap :: [(ResIdentifier, RResource)] -> CatalogMonad FinalCatalog
createResourceMap = foldM insertres Map.empty
where
insertres curmap (resid, res) = let
oldres = Map.lookup resid curmap
newmap = Map.insert resid res curmap
in case (rrtype res, oldres) of
("class", _) -> return newmap
(_, Just r ) -> throwError $ "Resource already defined:"
++ "\n\t" ++ rrtype r ++ "[" ++ rrname r ++ "] at " ++ show (rrpos r)
++ "\n\t" ++ rrtype res ++ "[" ++ rrname res ++ "] at " ++ show (rrpos res)
(_, Nothing) -> return newmap
getstatement :: TopLevelType -> String -> CatalogMonad Statement
getstatement qtype name = do
curcontext <- get
let stmtsfunc = getStatementsFunction curcontext
estatement <- liftIO $ stmtsfunc qtype name
case estatement of
Left x -> throwPosError x
Right y -> return y
-- State alteration functions
pushScope = modify . modifyScope . (:)
pushDefaults = modify . modifyDefaults . (:)
popScope = modify (modifyScope tail)
getScope = do
scope <- liftM curScope get
if null scope
then throwError "empty scope, shouldn't happen"
else return $ head scope
addLoaded name = modify . modifyClasses . Map.insert name
getNextId = do
curscope <- get
put $ incrementResId curscope
return (curResId curscope)
setPos = modify . setStatePos
-- qualifies a variable k depending on the context cs
qualify k cs | qualified k || (cs == "::") = cs ++ k
| otherwise = cs ++ "::" ++ k
-- This is a bit convoluted and misses a critical feature.
-- It adds the variable to all the scopes that are currently active.
-- BUG TODO : check that a variable is not already defined.
putVariable k v = getScope >>= mapM_ (\x -> modify (modifyVariables (Map.insert (qualify k x) v)))
getVariable vname = liftM (Map.lookup vname . curVariables) get
-- BUG TODO : top levels are qualified only with the head of the scopes
addNestedTopLevel rtype rname rstatement = do
curstate <- get
let ctop = nestedtoplevels curstate
curscope = head $ head (curScope curstate)
nname = qualify rname curscope
nstatement = case rstatement of
DefineDeclaration _ prms stms cpos -> DefineDeclaration nname prms stms cpos
ClassDeclaration _ inhe prms stms cpos -> ClassDeclaration nname inhe prms stms cpos
x -> x
ntop = Map.insert (rtype, nname) nstatement ctop
nstate = curstate { nestedtoplevels = ntop }
put nstate
addWarning = modify . pushWarning
addCollect ((func, query), overrides) = modify $ pushCollect (func, overrides, query)
-- this pushes the relations only if they exist
-- the parameter is of the form
-- ( [dstrelations], srcresource, type, pos )
addUnresRel ncol@(rels, _, _, _) = unless (null rels) (modify (pushUnresRel ncol))
-- finds out if a resource name refers to a define
checkDefine :: String -> CatalogMonad (Maybe Statement)
checkDefine dname = fmap nativeTypes get >>= \nt -> if Map.member dname nt
then return Nothing
else do
curstate <- get
let ntop = nestedtoplevels curstate
getsmts = getStatementsFunction curstate
check = Map.lookup (TopDefine, dname) ntop
case check of
Just x -> return $ Just x
Nothing -> do
def1 <- liftIO $ getsmts TopDefine dname
case def1 of
Left err -> throwPosError ("Could not find the definition of " ++ dname ++ " err = " ++ err)
Right s -> return $ Just s
{-
Partition parameters between those that are actual parameters and those that define relationships.
Those that define relationship must be properly resolved or hell will break loose. This is a BUG.
-}
partitionParamsRelations :: [(GeneralString, GeneralValue)] -> ([(GeneralString, GeneralValue)], [(LinkType, GeneralValue, GeneralValue)])
partitionParamsRelations rparameters = (realparams, relations)
where realparams = filteredparams
relations = concatMap convertrelation filteredrelations
convertrelation :: (GeneralString, GeneralValue) -> [(LinkType, GeneralValue, GeneralValue)]
convertrelation (_, Right ResolvedUndefined) = []
convertrelation (reltype, Right (ResolvedArray rs)) = concatMap (\x -> convertrelation (reltype, Right x)) rs
convertrelation (reltype, Right (ResolvedRReference rt rv)) = [(fromJust $ getRelationParameterType reltype, Right $ ResolvedString rt, Right rv)]
convertrelation (reltype, Right (ResolvedString "undef")) = [(fromJust $ getRelationParameterType reltype, Right $ ResolvedString "undef", Right $ ResolvedString "undef")]
convertrelation (_, Left x) = error ("partitionParamsRelations unresolved : " ++ show x)
convertrelation x = error ("partitionParamsRelations error : " ++ show x)
(filteredrelations, filteredparams) = partition (isJust . getRelationParameterType . fst) rparameters -- filters relations with actual parameters
-- TODO check whether parameters changed
checkLoaded name = do
curscope <- get
case Map.lookup name (curClasses curscope) of
Nothing -> return False
Just _ -> return True
-- function that takes a pair of Expressions and try to resolve the first as a string, the second as a generalvalue
resolveParams :: (Expression, Expression) -> CatalogMonad (GeneralString, GeneralValue)
resolveParams (a,b) = do
ra <- tryResolveExpressionString a
rb <- tryResolveExpression b
return (ra, rb)
-- apply default values to a resource
applyDefaults :: CResource -> CatalogMonad CResource
applyDefaults res = liftM curDefaults get >>= foldM applyDefaults' res
applyDefaults' :: CResource -> ResDefaults -> CatalogMonad CResource
applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (RDefaults dtype rdefs dpos) = do
srname <- resolveGeneralString rname
let (nparams, nrelations) = mergeParams rparams rdefs False
if dtype == rtype
then do
addUnresRel (nrelations, (rtype, Right srname), UDefault, dpos)
return $ CResource i rname rtype nparams rvirtuality rpos
else return r
applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (ROverride dtype dname rdefs dpos) = do
srname <- resolveGeneralString rname
sdname <- resolveGeneralString dname
let (nparams, nrelations) = mergeParams rparams rdefs True
if (dtype == rtype) && (srname == sdname)
then do
addUnresRel (nrelations, (rtype, Right srname), UDefault, dpos)
return $ CResource i rname rtype nparams rvirtuality rpos
else return r
-- merge defaults and actual parameters depending on the override flag
mergeParams :: [(GeneralString, GeneralValue)] -> [(GeneralString, GeneralValue)] -> Bool -> ([(GeneralString, GeneralValue)], [(LinkType, GeneralValue, GeneralValue)])
mergeParams srcparams defs override = let
(dstparams, dstrels) = partitionParamsRelations defs
srcprm = Map.fromList srcparams
dstprm = Map.fromList dstparams
prm = if override
then Map.toList $ Map.union dstprm srcprm
else Map.toList $ Map.union srcprm dstprm
in (prm, dstrels)
-- The actual meat
evaluateDefine :: CResource -> CatalogMonad [CResource]
evaluateDefine r@(CResource _ rname rtype rparams rvirtuality rpos) = let
evaluateDefineDeclaration dtype args dstmts dpos = do
--oldpos <- getPos
pushScope ["#DEFINE#" ++ dtype]
-- add variables
mrrparams <- mapM (\(gs, gv) -> do { rgs <- resolveGeneralString gs; rgv <- tryResolveGeneralValue gv; return (rgs, (rgv, dpos)); }) rparams
let expr = gs2gv rname
mparams = Map.fromList mrrparams
defineparamset = Set.fromList $ map fst args
mandatoryparams = Set.fromList $ map fst $ filter (isNothing . snd) args
resourceparamset = Set.fromList $ map fst mrrparams
extraparams = Set.difference resourceparamset (Set.union defineparamset metaparameters)
unsetparams = Set.difference mandatoryparams resourceparamset
unless (Set.null extraparams) $ throwPosError $ "Spurious parameters set for " ++ dtype ++ ": " ++ intercalate ", " (Set.toList extraparams)
unless (Set.null unsetparams) $ throwPosError $ "Unset parameters set for " ++ dtype ++ ": " ++ intercalate ", " (Set.toList unsetparams)
putVariable "title" (expr, rpos)
putVariable "name" (expr, rpos)
mapM_ (loadClassVariable rpos mparams) args
setPos dpos
-- parse statements
res <- mapM evaluateStatements dstmts
nres <- handleDelayedActions (concat res)
popScope
return nres
in do
setPos rpos
isdef <- checkDefine rtype
case (rvirtuality, isdef) of
(Normal, Just (TopContainer topstmts (DefineDeclaration dtype args dstmts dpos))) -> do
mapM_ (\(n,x) -> evaluateClass x Map.empty (Just n)) topstmts
evaluateDefineDeclaration dtype args dstmts dpos
(Normal, Just (DefineDeclaration dtype args dstmts dpos)) -> evaluateDefineDeclaration dtype args dstmts dpos
_ -> return [r]
-- handling delayed actions (such as defaults and define resolution)
handleDelayedActions :: Catalog -> CatalogMonad Catalog
handleDelayedActions res = do
dres <- liftM concat (mapM applyDefaults res >>= mapM evaluateDefine)
modify emptyDefaults
return dres
addResource :: String -> [(Expression, Expression)] -> Virtuality -> SourcePos -> GeneralValue -> CatalogMonad [CResource]
addResource rtype parameters virtuality position grname = do
resid <- getNextId
rparameters <- mapM resolveParams parameters
-- il faut transformer grname qui est une generalvalue en generalstring
srname <- case grname of
Right e -> liftM Right (rstring e)
Left e -> return $ Left e
let (realparams, relations) = partitionParamsRelations rparameters
-- push all the relations
addUnresRel (relations, (rtype, srname), UNormal, position)
return [CResource resid srname rtype realparams virtuality position]
-- node
evaluateStatements :: Statement -> CatalogMonad Catalog
evaluateStatements (Node _ stmts position) = do
setPos position
res <- mapM evaluateStatements stmts
handleDelayedActions (concat res)
-- include
evaluateStatements (Include includename position) = setPos position >> getstatement TopClass includename >>= \st -> evaluateClass st Map.empty Nothing
evaluateStatements x@(ClassDeclaration cname _ _ _ _) = do
addNestedTopLevel TopClass cname x
return []
evaluateStatements n@(DefineDeclaration dtype _ _ _) = do
addNestedTopLevel TopDefine dtype n
return []
evaluateStatements (ConditionalStatement exprs position) = do
setPos position
trues <- filterM (\(expr, _) -> resolveBoolean (Left expr)) exprs
case trues of
((_,stmts):_) -> liftM concat (mapM evaluateStatements stmts)
_ -> return []
evaluateStatements (Resource rtype rname parameters virtuality position) = do
setPos position
case rtype of
-- checks whether we are handling a parametrized class
"class" -> do
rparameters <- mapM (\(a,b) -> do { pa <- resolveExpressionString a; pb <- tryResolveExpression b; return (pa, pb) } ) parameters
checkDuplicateFirst rparameters
classname <- resolveExpressionString rname
topstatement <- getstatement TopClass classname
let classparameters = Map.fromList $ map (\(pname, pvalue) -> (pname, (pvalue, position))) rparameters
evaluateClass topstatement classparameters Nothing
_ -> do
srname <- tryResolveExpression rname
case srname of
(Right (ResolvedArray arr)) -> fmap concat (mapM (addResource rtype parameters virtuality position . Right) arr)
_ -> addResource rtype parameters virtuality position srname
evaluateStatements (ResourceDefault rdtype rdparams rdpos) = do
rrdparams <- mapM resolveParams rdparams
pushDefaults $ RDefaults rdtype rrdparams rdpos
return []
evaluateStatements (ResourceOverride rotype roname roparams ropos) = do
rroname <- tryResolveExpressionString roname
rroparams <- mapM resolveParams roparams
pushDefaults $ ROverride rotype rroname rroparams ropos
return []
evaluateStatements (DependenceChain (srctype, srcname) (dsttype, dstname) position) = do
setPos position
gdstname <- tryResolveExpression dstname
gsrcname <- tryResolveExpressionString srcname
addUnresRel ( [(RRequire, Right $ ResolvedString dsttype, gdstname)], (srctype, gsrcname), UPlus, position )
return []
-- <<| |>>
evaluateStatements (ResourceCollection rtype expr overrides position) = do
setPos position
when (not $ null overrides) $ throwPosError $ "Amending attributes with a Collector only works with <| |>, not <<| |>>."
func <- collectionFunction Exported rtype expr
addCollect (func, [])
return []
-- <| |>
-- TODO : check that this is a native type when overrides are defined.
-- The behaviour is not explained in the documentation, so I won't support it.
evaluateStatements (VirtualResourceCollection rtype expr overrides position) = do
setPos position
func <- collectionFunction Virtual rtype expr
prms <- mapM resolveParams overrides
addCollect (func, prms)
return []
evaluateStatements (VariableAssignment vname vexpr position) = do
setPos position
rvexpr <- tryResolveExpression vexpr
putVariable vname (rvexpr, position)
return []
evaluateStatements (MainFunctionCall fname fargs position) = do
setPos position
rargs <- mapM resolveExpression fargs
executeFunction fname rargs
evaluateStatements (TopContainer toplevels curstatement) = do
mapM_ (\(fname, stmt) -> evaluateClass stmt Map.empty (Just fname)) toplevels
evaluateStatements curstatement
evaluateStatements x = throwError ("Can't evaluate " ++ show x)
-- function used to load defines / class variables into the global context
loadClassVariable :: SourcePos -> Map.Map String (GeneralValue, SourcePos) -> (String, Maybe Expression) -> CatalogMonad ()
loadClassVariable position inputs (paramname, defvalue) = do
let inputvalue = Map.lookup paramname inputs
(v, vpos) <- case (inputvalue, defvalue) of
(Just x , _ ) -> return x
(Nothing, Just y ) -> return (Left y, position)
(Nothing, Nothing) -> throwError $ "Must define parameter " ++ paramname ++ " at " ++ show position
rv <- tryResolveGeneralValue v
putVariable paramname (rv, vpos)
return ()
-- class
-- ClassDeclaration String (Maybe String) [(String, Maybe Expression)] [Statement] SourcePos
-- nom, heritage, parametres, contenu
evaluateClass :: Statement -> Map.Map String (GeneralValue, SourcePos) -> Maybe String -> CatalogMonad Catalog
evaluateClass (ClassDeclaration classname inherits parameters statements position) inputparams actualname = do
isloaded <- case actualname of
Nothing -> checkLoaded classname
Just x -> checkLoaded x
if isloaded
then return []
else do
-- detection of spurious parameters
let classparamset = Set.fromList $ map fst parameters
inputparamset = Set.filter (\x -> getRelationParameterType (Right x) == Nothing) $ Map.keysSet inputparams
overparams = Set.difference inputparamset (Set.union metaparameters classparamset)
unless (Set.null overparams) (throwError $ "Spurious parameters " ++ intercalate ", " (Set.toList overparams) ++ " at " ++ show position)
resid <- getNextId -- get this resource id, for the dummy class that will be used to handle relations
oldpos <- getPos -- saves where we were at class declaration so that we known were the class was included
setPos position
case actualname of
Nothing -> pushScope [classname] -- sets the scope
Just ac -> pushScope [classname, ac]
mapM_ (loadClassVariable position inputparams) parameters -- add variables for parametrized classes
-- load inherited classes
inherited <- case inherits of
Just parentclass -> do
mystatement <- getstatement TopClass parentclass
case mystatement of
ClassDeclaration _ ni np ns no -> evaluateClass (ClassDeclaration classname ni np ns no) Map.empty (Just parentclass)
_ -> throwError "Should not happen : TopClass return something else than a ClassDeclaration in evaluateClass"
Nothing -> return []
case actualname of
Nothing -> addLoaded classname oldpos
Just x -> addLoaded x oldpos
-- parse statements
res <- mapM evaluateStatements statements
nres <- handleDelayedActions (concat res)
mapM_ (addClassDependency classname) nres -- this adds a dummy dependency to this class
-- for all resources that do not already depend on a class
-- this is probably not puppet perfect with resources that
-- depend explicitely on a class
popScope
return $
[CResource resid (Right classname) "class" [] Normal position]
++ inherited
++ nres
evaluateClass (TopContainer topstmts myclass) inputparams actualname = do
mapM_ (\(n,x) -> evaluateClass x Map.empty (Just n)) topstmts
evaluateClass myclass inputparams actualname
evaluateClass x _ _ = throwError ("Someone managed to run evaluateClass against " ++ show x)
addClassDependency :: String -> CResource -> CatalogMonad ()
addClassDependency cname (CResource _ rname rtype _ _ position) = addUnresRel (
[(RRequire, Right $ ResolvedString "class", Right $ ResolvedString cname)]
, (rtype, rname)
, UPlus, position)
tryResolveExpression :: Expression -> CatalogMonad GeneralValue
tryResolveExpression = tryResolveGeneralValue . Left
tryResolveGeneralValue :: GeneralValue -> CatalogMonad GeneralValue
tryResolveGeneralValue n@(Right _) = return n
tryResolveGeneralValue (Left BTrue) = return $ Right $ ResolvedBool True
tryResolveGeneralValue (Left BFalse) = return $ Right $ ResolvedBool False
tryResolveGeneralValue (Left (Value x)) = tryResolveValue x
tryResolveGeneralValue n@(Left (ResolvedResourceReference _ _)) = return n
tryResolveGeneralValue (Left (Error x)) = throwPosError x
tryResolveGeneralValue (Left (ConditionalValue checkedvalue (Value (PuppetHash (Parameters hash))))) = do
rcheck <- resolveExpression checkedvalue
rhash <- mapM (\(vn, vv) -> do { rvn <- resolveExpression vn; return (rvn, vv) }) hash
case filter (\(a,_) -> (a == ResolvedString "default") || compareRValues a rcheck) rhash of
[] -> throwPosError ("No value could be selected when comparing to " ++ show rcheck)
((_,x):_) -> tryResolveExpression x
tryResolveGeneralValue n@(Left (EqualOperation a b)) = compareGeneralValue n a b [EQ]
tryResolveGeneralValue n@(Left (AboveEqualOperation a b)) = compareGeneralValue n a b [GT,EQ]
tryResolveGeneralValue n@(Left (AboveOperation a b)) = compareGeneralValue n a b [GT]
tryResolveGeneralValue n@(Left (UnderEqualOperation a b)) = compareGeneralValue n a b [LT,EQ]
tryResolveGeneralValue n@(Left (UnderOperation a b)) = compareGeneralValue n a b [LT]
tryResolveGeneralValue n@(Left (DifferentOperation a b)) = compareGeneralValue n a b [LT,GT]
tryResolveGeneralValue n@(Left (RegexpOperation a b)) = do
ra <- tryResolveExpression a
rb <- tryResolveExpression b
case (ra, rb) of
(Right (ResolvedString src), Right (ResolvedRegexp reg)) -> do
m <- liftIO $ regmatch src reg
case m of
Right x -> return $ Right $ ResolvedBool x
Left err -> throwPosError $ "Error with regexp " ++ show reg ++ ": " ++ err
(Right x, _) -> throwPosError $ "Was expecting a string to match to a regexp, not " ++ show x
(_, Right x) -> throwPosError $ "Was expecting a regexp, not " ++ show x
_ -> return n
tryResolveGeneralValue n@(Left (OrOperation a b)) = do
ra <- tryResolveBoolean $ Left a
if( ra == Right (ResolvedBool True) )
then return $ Right $ ResolvedBool True
else do
rb <- tryResolveBoolean $ Left b
case (ra, rb) of
(_, Right (ResolvedBool True)) -> return $ Right $ ResolvedBool True
(Right (ResolvedBool rra), Right (ResolvedBool rrb)) -> return $ Right $ ResolvedBool $ rra || rrb
_ -> return n
tryResolveGeneralValue n@(Left (AndOperation a b)) = do
ra <- tryResolveBoolean $ Left a
if( ra == Right (ResolvedBool False) )
then return $ Right $ ResolvedBool False
else do
rb <- tryResolveBoolean $ Left b
case (ra, rb) of
(_, Right (ResolvedBool False)) -> return $ Right $ ResolvedBool False
(Right (ResolvedBool rra), Right (ResolvedBool rrb)) -> return $ Right $ ResolvedBool $ rra && rrb
_ -> return n
tryResolveGeneralValue (Left (NotOperation x)) = do
rx <- tryResolveBoolean $ Left x
case rx of
Right (ResolvedBool b) -> return $ Right $ ResolvedBool $ not b
_ -> return rx
tryResolveGeneralValue (Left (LookupOperation a b)) = do
ra <- tryResolveExpression a
rb <- tryResolveExpressionString b
case (ra, rb) of
(Right (ResolvedArray ar), Right num) -> do
bnum <- readint num
let nnum = fromIntegral bnum
if length ar <= nnum
then throwPosError ("Invalid array index " ++ num ++ " " ++ show ar)
else return $ Right (ar !! nnum)
(Right (ResolvedHash ar), Right idx) -> do
let filtered = filter (\(x,_) -> x == idx) ar
case filtered of
[] -> return $ Right ResolvedUndefined
[(_,x)] -> return $ Right x
x -> throwPosError ("Hum, WTF tryResolveGeneralValue " ++ show x)
(_, Left y) -> throwPosError ("Could not resolve index " ++ show y)
(Left x, _) -> throwPosError ("Could not resolve lookup " ++ show x)
(Right x, _) -> throwPosError ("Could not resolve something that is not an array nor a hash, but " ++ show x)
-- TODO : for hashes, checks the keys
-- for strings, substrings
tryResolveGeneralValue o@(Left (IsElementOperation b a)) = do
ra <- tryResolveExpression a
rb <- tryResolveExpressionString b
case (ra, rb) of
(Right (ResolvedArray ar), Right idx) -> do
let filtered = filter (compareRValues (ResolvedString idx)) ar
if null filtered
then return $ Right $ ResolvedBool False
else return $ Right $ ResolvedBool True
_ -> return o
-- horrible hack, because I do not know how to supply a single operator for Int and Float
tryResolveGeneralValue o@(Left (PlusOperation a b)) = arithmeticOperation a b (+) (+) o
tryResolveGeneralValue o@(Left (MinusOperation a b)) = arithmeticOperation a b (-) (-) o
tryResolveGeneralValue o@(Left (DivOperation a b)) = arithmeticOperation a b div (/) o
tryResolveGeneralValue o@(Left (MultiplyOperation a b)) = arithmeticOperation a b (*) (*) o
tryResolveGeneralValue e = throwPosError ("tryResolveGeneralValue not implemented for " ++ show e)
resolveGeneralValue :: GeneralValue -> CatalogMonad ResolvedValue
resolveGeneralValue e = do
x <- tryResolveGeneralValue e
case x of
Left n -> throwPosError ("Could not resolveGeneralValue " ++ show n)
Right p -> return p
tryResolveExpressionString :: Expression -> CatalogMonad GeneralString
tryResolveExpressionString s = do
resolved <- tryResolveExpression s
case resolved of
Right e -> liftM Right (rstring e)
Left e -> return $ Left e
rstring :: ResolvedValue -> CatalogMonad String
rstring resolved = case resolved of
ResolvedString s -> return s
ResolvedInt i -> return (show i)
e -> do
p <- getPos
throwError ("'" ++ show e ++ "' will not resolve to a string at " ++ show p)
resolveExpression :: Expression -> CatalogMonad ResolvedValue
resolveExpression e = do
resolved <- tryResolveExpression e
case resolved of
Right r -> return r
Left x -> do
p <- getPos
throwError ("Can't resolve expression '" ++ show x ++ "' at " ++ show p ++ " was '" ++ show e ++ "'")
resolveExpressionString :: Expression -> CatalogMonad String
resolveExpressionString x = do
resolved <- resolveExpression x
case resolved of
ResolvedString s -> return s
ResolvedInt i -> return (show i)
e -> do
p <- getPos
throwError ("Can't resolve expression '" ++ show e ++ "' to a string at " ++ show p)
tryResolveValue :: Value -> CatalogMonad GeneralValue
tryResolveValue (Literal x) = return $ Right $ ResolvedString x
tryResolveValue (Integer x) = return $ Right $ ResolvedInt x
tryResolveValue (Double x) = return $ Right $ ResolvedDouble x
tryResolveValue n@(ResourceReference rtype vals) = do
rvals <- tryResolveExpression vals
case rvals of
Right resolved -> return $ Right $ ResolvedRReference rtype resolved
_ -> return $ Left $ Value n
-- special variables first
tryResolveValue (VariableReference "module_name") = liftM (\x ->
case (takeWhile (/= ':') . head) x of
'#':'D':'E':'F':'I':'N':'E':'#':xs -> Right $ ResolvedString xs
r -> Right $ ResolvedString r
) getScope
tryResolveValue (VariableReference vname) = do
-- TODO check scopes !!!
curscp <- getScope
let gvarnm sc | qualified vname = vname : remtopscope vname -- scope is explicit
| sc == "::" = ["::" ++ vname] -- we are toplevel
| otherwise = [sc ++ "::" ++ vname, "::" ++ vname] -- check for local scope, then global
varnames = concatMap gvarnm curscp
remtopscope (':':':':xs) = [xs]
remtopscope _ = []
matching <- liftM catMaybes (mapM getVariable varnames)
if null matching
then do
position <- getPos
addWarning ("Could not resolveValue variables " ++ show varnames ++ " at " ++ show position)
return $ Left $ Value $ VariableReference (head varnames)
else return $ case head matching of
(x,_) -> x
tryResolveValue (Interpolable x) = do
resolved <- mapM tryResolveValueString x
if null $ lefts resolved
then return $ Right $ ResolvedString $ concat $ rights resolved
-- if it is not resolved, we will try to store it as resolved as
-- possible, so as not to lose the context
else fmap (Left . Value . Interpolable)
(mapM tryResolveValue x >>= mapM generalValue2Value)
tryResolveValue n@(PuppetHash (Parameters x)) = do
resolvedKeys <- mapM (tryResolveExpressionString . fst) x
resolvedValues <- mapM (tryResolveExpression . snd) x
if null (lefts resolvedKeys) && null (lefts resolvedValues)
then return $ Right $ ResolvedHash $ zip (rights resolvedKeys) (rights resolvedValues)
else return $ Left $ Value n
tryResolveValue n@(PuppetArray expressions) = do
resolvedExpressions <- mapM tryResolveExpression expressions
if null $ lefts resolvedExpressions
then return $ Right $ ResolvedArray $ rights resolvedExpressions
else return $ Left $ Value n
tryResolveValue (FunctionCall "generate" args) = if null args
then throwPosError "Empty argument list in generate"
else do
nargs <- mapM resolveExpressionString args
let cmdname:cmdargs = nargs
gens <- liftIO $ generate cmdname cmdargs
case gens of
Just w -> return $ Right $ ResolvedString w
Nothing -> throwPosError $ "Function call generate for command " ++ cmdname ++ " (" ++ show cmdargs ++ ") failed"
tryResolveValue n@(FunctionCall "pdbresourcequery" (query:xs)) = do
rkey <- case xs of
[key] -> do
r <- tryResolveExpression key
case r of
Right (ResolvedString keyname) -> return $ Right $ Just keyname
Right x -> throwPosError $ "The pdbresourcequery function expects a string as the second argument, not " ++ showValue x
Left y -> return $ Left $ y
[] -> return $ Right Nothing
_ -> throwPosError "Bad number of arguments for function pdbresourcequery"
rquery <- tryResolveExpression query
case (rquery, rkey) of
(Right a@(ResolvedArray _), Right keyname) -> fmap Right (pdbresourcequery (showValue a) keyname)
(Right a, Right _) -> throwPosError $ "The pdbresourcequery function expects an array as the first argument, not " ++ showValue a
_ -> return $ Left $ Value n
tryResolveValue n@(FunctionCall "is_domain_name" [x]) = do
rx <- tryResolveExpressionString x
case rx of
Right s -> let
goodpart gs = (length gs < 64) && (not $ null gs) && (isAlpha $ head gs) && (all (\gx -> (gx=='-') || (isAlphaNum gx)) gs)
badparts "" = False
badparts str =
let (b,e) = break (=='.') str
in case (goodpart b, null e) of
(True, False) -> badparts (tail e)
(True, _) -> False
(False, _) -> True
bad = (null s) || (length s > 255) || (badparts s)
-- TODO check the parts are 63 char long
in return $ Right $ ResolvedBool $ not bad
_ -> return $ Left $ Value n
tryResolveValue (FunctionCall "fqdn_rand" args) = if null args
then throwPosError "Empty argument list in fqdn_rand call"
else do
nargs <- mapM resolveExpressionString args
curmax <- readint (head nargs)
liftM (Right . ResolvedInt) (fqdn_rand curmax (tail nargs))
tryResolveValue (FunctionCall "mysql_password" args) = if length args /= 1
then throwPosError "mysql_password takes a single argument"
else do
es <- tryResolveExpressionString (head args)
case es of
Right s -> liftM (Right . ResolvedString) (mysql_password s)
Left u -> return $ Left u
tryResolveValue (FunctionCall "template" [name]) = do
fname <- tryResolveExpressionString name
case fname of
Left x -> throwPosError $ "Can't resolve template path " ++ show x
Right filename -> do
vars <- get >>= mapM (\(varname, (varval, _)) -> do { rvarval <- tryResolveGeneralValue varval; return (varname, rvarval) }) . Map.toList . curVariables
scp <- liftM head getScope -- TODO check if that sucks
templatefunc <- liftM computeTemplateFunction get
out <- liftIO (templatefunc filename scp vars)
case out of
Right x -> return $ Right $ ResolvedString x
Left err -> throwPosError err
tryResolveValue (FunctionCall "inline_template" _) = return $ Right $ ResolvedString "TODO"
tryResolveValue (FunctionCall "defined" [v]) = do
rv <- tryResolveExpression v
case rv of
Left n -> return $ Left n
-- TODO BUG
Right (ResolvedString typeorclass) -> do
ntypes <- fmap nativeTypes get
-- is it a loaded class or a define ?
if Map.member typeorclass ntypes
then return $ Right $ ResolvedBool True
else do
isdefine <- checkDefine typeorclass
case isdefine of
Just _ -> return $ Right $ ResolvedBool True
Nothing -> liftM (Right . ResolvedBool . Map.member typeorclass . curClasses) get
Right (ResolvedRReference _ (ResolvedString _)) -> do
position <- getPos
addWarning $ "The defined() function is not implemented for resource references. Returning true at " ++ show position
return $ Right $ ResolvedBool True
Right x -> throwPosError $ "Can't know if this could be defined : " ++ show x
tryResolveValue n@(FunctionCall "regsubst" [str, src, dst, flags]) = do
rstr <- tryResolveExpressionString str
rsrc <- tryResolveExpressionString src
rdst <- tryResolveExpressionString dst
rflags <- tryResolveExpressionString flags
case (rstr, rsrc, rdst, rflags) of
(Right sstr, Right ssrc, Right sdst, Right sflags) -> liftM (Right . ResolvedString) (regsubst sstr ssrc sdst sflags)
_ -> return $ Left $ Value n
tryResolveValue (FunctionCall "regsubst" [str, src, dst]) = tryResolveValue (FunctionCall "regsubst" [str, src, dst, Value $ Literal ""])
tryResolveValue (FunctionCall "regsubst" args) = throwPosError ("Bad argument count for regsubst " ++ show args)
tryResolveValue n@(FunctionCall "chomp" [str]) = do
let mychomp = reverse . dropWhile isSpace . reverse
mmychomp (ResolvedString s) = return $ ResolvedString (mychomp s)
mmychomp r = throwPosError $ "The chomp function expects strings or arrays of strings, not this: " ++ show r
rstr <- tryResolveExpression str
case rstr of
Left _ -> return $ Left $ Value n
Right (ResolvedArray arr) -> fmap (Right . ResolvedArray) (mapM mmychomp arr)
Right x -> fmap Right (mmychomp x)
tryResolveValue n@(FunctionCall "split" [str, reg]) = do
rstr <- tryResolveExpressionString str
rreg <- tryResolveExpressionString reg
case (rstr, rreg) of
(Right sstr, Right sreg) -> do
sp <- liftIO $ puppetSplit sstr sreg
case sp of
Right o -> return $ Right $ ResolvedArray $ map ResolvedString o
Left r -> throwPosError $ "split error: " ++ show r
_ -> return $ Left $ Value n
tryResolveValue (FunctionCall "split" _) = throwPosError "Bad argument count for function split"
tryResolveValue n@(FunctionCall "upcase" args) = stringTransform args n (map toUpper)
tryResolveValue n@(FunctionCall "lowcase" args) = stringTransform args n (map toLower)
tryResolveValue n@(FunctionCall "sha1" args) = stringTransform args n puppetSHA1
tryResolveValue n@(FunctionCall "md5" args) = stringTransform args n puppetMD5
tryResolveValue n@(FunctionCall "versioncmp" [a,b]) = do
ra <- tryResolveExpressionString a
rb <- tryResolveExpressionString b
case (ra, rb) of
(Right sa, Right sb) -> return $ Right $ ResolvedInt (versioncmp sa sb)
_ -> return $ Left $ Value n
tryResolveValue n@(FunctionCall "file" filelist) = do
-- resolving the list of file pathes
rfilelist <- mapM tryResolveExpressionString filelist
let (lf, rf) = partitionEithers rfilelist
if null lf
then do
content <- liftIO $ file rf
case content of
Nothing -> throwPosError $ "Files " ++ show rf ++ " could not be found"
Just x -> return $ Right $ ResolvedString x
else return $ Left $ Value n
tryResolveValue n@(FunctionCall fname args) = do
ufunctions <- fmap userFunctions get
l <- fmap luaState get
case (l, Set.member fname ufunctions) of
(Just ls, True) -> do
rargs <- mapM tryResolveExpression args
if null (lefts rargs)
then fmap Right (puppetFunc ls fname (rights rargs))
else return $ Left $ Value n
_ -> throwPosError ("FunctionCall " ++ fname ++ " not implemented")
tryResolveValue Undefined = return $ Right ResolvedUndefined
tryResolveValue (PuppetRegexp x) = return $ Right $ ResolvedRegexp x
tryResolveValue x = throwPosError ("tryResolveValue not implemented for " ++ show x)
tryResolveValueString :: Value -> CatalogMonad GeneralString
tryResolveValueString x = do
r <- tryResolveValue x
case r of
Right (ResolvedString v) -> return $ Right v
Right (ResolvedInt i) -> return $ Right (show i)
Right (ResolvedDouble i) -> return $ Right (show i)
Right v -> throwPosError ("Can't resolve valuestring for " ++ show v)
Left v -> return $ Left v
getRelationParameterType :: GeneralString -> Maybe LinkType
getRelationParameterType (Right "require" ) = Just RRequire
getRelationParameterType (Right "notify" ) = Just RNotify
getRelationParameterType (Right "before" ) = Just RBefore
getRelationParameterType (Right "subscribe") = Just RSubscribe
getRelationParameterType _ = Nothing
-- this function saves a new condition for collection
pushRealize :: ResolvedValue -> CatalogMonad ()
pushRealize (ResolvedRReference rtype (ResolvedString rname)) = do
let myfunction :: CResource -> CatalogMonad Bool
myfunction (CResource _ mcrname mcrtype _ _ _) = do
srname <- resolveGeneralString mcrname
return ((srname == rname) && (mcrtype == rtype))
addCollect ((myfunction, Just $ PDB.queryRealize rtype rname) , [])
return ()
pushRealize (ResolvedRReference _ x) = throwPosError (show x ++ " was not resolved to a string")
pushRealize x = throwPosError ("A reference was expected instead of " ++ show x)
executeFunction :: String -> [ResolvedValue] -> CatalogMonad Catalog
executeFunction "fail" [ResolvedString errmsg] = throwPosError ("Error: " ++ errmsg)
executeFunction "fail" args = throwPosError ("Error: " ++ show args)
executeFunction "realize" rlist = mapM_ pushRealize rlist >> return []
executeFunction "create_resources" [mrtype, rdefs] = do
mrrtype <- case mrtype of
ResolvedString x -> return x
_ -> throwPosError $ "Resource type must be a string and not " ++ show mrtype
arghash <- case rdefs of
ResolvedHash x -> return x
_ -> throwPosError $ "Resource definition must be a hash, and not " ++ show rdefs
position <- getPos
let prestatements = map (\(rname, rargs) -> (Value $ Literal rname, resolved2expression rargs)) arghash
resources <- mapM (\(resname, pval) -> do
realargs <- case pval of
Value (PuppetHash (Parameters h)) -> return h
_ -> throwPosError "This should not happen, create_resources argument is not a hash"
return $ Resource mrrtype resname realargs Normal position
) prestatements
liftM concat (mapM evaluateStatements resources)
executeFunction "create_resources" x = throwPosError ("Bad arguments to create_resources: " ++ show x)
executeFunction "validate_array" [x] = case x of
ResolvedArray _ -> return []
y -> throwPosError $ show y ++ " is not an array"
executeFunction "validate_hash" [x] = case x of
ResolvedHash _ -> return []
y -> throwPosError $ show y ++ " is not a hash"
executeFunction "validate_string" [x] = case x of
ResolvedString _ -> return []
y -> throwPosError $ show y ++ " is not an string"
executeFunction "validate_re" [x,re] = case (x,re) of
(ResolvedString z, ResolvedString rre) -> do
m <- liftIO $ regmatch z rre
case m of
Right True -> return []
Right False -> throwPosError $ show x ++ " does not match the regexp " ++ show rre
Left err -> throwPosError $ "Error with regexp " ++ show rre ++ ": " ++ err
(y,z) -> throwPosError $ "Can't compare " ++ show y ++ " to regexp " ++ show z
executeFunction "validate_bool" [x] = case x of
ResolvedBool _ -> return []
y -> throwPosError $ show y ++ " is not a boolean"
executeFunction a b = do
position <- getPos
addWarning $ "Function " ++ a ++ "(" ++ show b ++ ") not handled at " ++ show position
return []
compareExpression :: Expression -> Expression -> CatalogMonad (Maybe Ordering)
compareExpression a b = do
ra <- tryResolveExpression a
rb <- tryResolveExpression b
case (ra, rb) of
(Right rra, Right rrb) -> return $ Just $ compareValues rra rrb
_ -> return $ compareSemiResolved ra rb
compareSemiResolved :: GeneralValue -> GeneralValue -> Maybe Ordering
compareSemiResolved a@(Right _) b@(Left _) = compareSemiResolved b a
compareSemiResolved (Left (Value (VariableReference _))) (Left (Value (VariableReference _))) = Just EQ
compareSemiResolved (Left (Value (VariableReference _))) (Left (Value (Literal ""))) = Just EQ
compareSemiResolved (Left (Value (VariableReference _))) (Left (Value (Literal "false"))) = Just EQ
compareSemiResolved a b = Just (compare a b)
compareGeneralValue :: GeneralValue -> Expression -> Expression -> [Ordering] -> CatalogMonad GeneralValue
compareGeneralValue n a b acceptable = do
cmp <- compareExpression a b
case cmp of
Nothing -> return n
Just x -> return $ Right $ ResolvedBool (x `elem` acceptable)
compareValues :: ResolvedValue -> ResolvedValue -> Ordering
compareValues a@(ResolvedString _) b@(ResolvedInt _) = compareValues b a
compareValues (ResolvedInt a) (ResolvedString b) | isInt b = compare a (read b)
| otherwise = LT
compareValues (ResolvedString a) (ResolvedRegexp b) = case (unsafePerformIO $ regmatch a b) of
Right True -> EQ
_ -> LT
compareValues (ResolvedString a) (ResolvedString b) = comparing (map toLower) a b
compareValues x y = compare x y
compareRValues :: ResolvedValue -> ResolvedValue -> Bool
compareRValues a b = compareValues a b == EQ
-- used to handle the special cases when we know it is a boolean context
tryResolveBoolean :: GeneralValue -> CatalogMonad GeneralValue
tryResolveBoolean v = do
rv <- tryResolveGeneralValue v
case rv of
Left BFalse -> return $ Right $ ResolvedBool False
Left BTrue -> return $ Right $ ResolvedBool True
Right (ResolvedString "") -> return $ Right $ ResolvedBool False
Right (ResolvedString _) -> return $ Right $ ResolvedBool True
Right (ResolvedInt _) -> return $ Right $ ResolvedBool True
Right ResolvedUndefined -> return $ Right $ ResolvedBool False
Right (ResolvedArray _) -> return $ Right $ ResolvedBool True
Right (ResolvedRReference _ _) -> return $ Right $ ResolvedBool True
Left (Value (VariableReference _)) -> return $ Right $ ResolvedBool False
Left (EqualOperation (Value (VariableReference _)) (Value (Literal ""))) -> return $ Right $ ResolvedBool True -- case where a variable was not resolved and compared to the empty string
Left (EqualOperation (Value (VariableReference _)) (Value (Literal "true"))) -> return $ Right $ ResolvedBool False -- case where a variable was not resolved and compared to the string "true"
Left (EqualOperation (Value (VariableReference _)) (Value (Literal "false"))) -> return $ Right $ ResolvedBool True -- case where a variable was not resolved and compared to the string "false"
_ -> return rv
resolveBoolean :: GeneralValue -> CatalogMonad Bool
resolveBoolean v = do
rv <- tryResolveBoolean v
case rv of
Right (ResolvedBool x) -> return x
n -> throwPosError ("Could not resolve " ++ show n ++ "(was " ++ show rv ++ ") as a boolean")
resolveGeneralString :: GeneralString -> CatalogMonad String
resolveGeneralString (Right x) = return x
resolveGeneralString (Left y) = resolveExpressionString y
gs2gv :: GeneralString -> GeneralValue
gs2gv (Left e) = Left e
gs2gv (Right s) = Right $ ResolvedString s
collectionFunction :: Virtuality -> String -> Expression -> CatalogMonad (CResource -> CatalogMonad Bool, Maybe PDB.Query)
collectionFunction virt mrtype exprs = do
(finalfunc, pdbquery) <- case exprs of
BTrue -> return (\_ -> return True, Just (PDB.collectAll mrtype))
EqualOperation a b -> do
ra <- resolveExpression a
rb <- resolveExpression b
paramname <- case ra of
ResolvedString pname -> return pname
_ -> throwPosError "We only support collection of the form 'parameter == value'"
defstatement <- checkDefine mrtype
paramset <- case defstatement of
Nothing -> fmap nativeTypes get >>= \nt -> case Map.lookup mrtype nt of
Just (PuppetTypeMethods _ ps) -> return ps
Nothing -> throwPosError $ "Unknown type " ++ mrtype ++ " when trying to collect"
Just (DefineDeclaration _ params _ _) -> return $ Set.fromList $ map fst params
Just x -> throwPosError $ "Expected a DefineDeclaration here instead of " ++ show x
when (Set.notMember paramname paramset && (not $ Set.member paramname metaparameters)) $
throwPosError $ "Parameter " ++ paramname ++ " is not a valid parameter. It should be in : " ++ show (Set.toList paramset)
return (\r -> do
let param = filter (\x -> fst x == Right paramname) (crparams r) :: [(GeneralString, GeneralValue)]
if null param
then return False
else do
cmp <- resolveGeneralValue $ snd (head param)
case (paramname, cmp) of
("tag", ResolvedArray xs) ->
let filtered = filter (compareRValues rb) xs
in return $ not $ null filtered
_ -> return $ compareRValues cmp rb
, case (paramname, rb) of
("tag", ResolvedString tagval) -> Just (PDB.collectTag mrtype tagval)
(param, ResolvedString prmval) -> Just (PDB.collectParam mrtype param prmval)
_ -> Nothing
)
x -> throwPosError $ "TODO : implement collection function for " ++ show x
return (\res -> do
-- <| |> matches Normal resources
if (crtype res == mrtype) && ( ((virt == Virtual) && (crvirtuality res == Normal)) || (crvirtuality res == virt))
then finalfunc res
else return False
, if (virt == Exported)
then pdbquery
else Nothing
)
generalValue2Expression :: GeneralValue -> Expression
generalValue2Expression (Left x) = x
generalValue2Expression (Right y) = resolved2expression y
generalValue2Value :: GeneralValue -> CatalogMonad Value
generalValue2Value x = case (generalValue2Expression x) of
(Value z) -> return z
y -> throwPosError $ "Could not downgrade this to a value: " ++ show y
resolved2expression :: ResolvedValue -> Expression
resolved2expression (ResolvedString str) = Value $ Literal str
resolved2expression (ResolvedInt i) = Value $ Integer i
resolved2expression (ResolvedBool True) = BTrue
resolved2expression (ResolvedBool False) = BFalse
resolved2expression (ResolvedRReference mrtype name) = Value $ ResourceReference mrtype (resolved2expression name)
resolved2expression (ResolvedArray vals) = Value $ PuppetArray $ map resolved2expression vals
resolved2expression (ResolvedHash hash) = Value $ PuppetHash $ Parameters $ map (\(s,v) -> (Value $ Literal s, resolved2expression v)) hash
resolved2expression ResolvedUndefined = Value Undefined
resolved2expression (ResolvedRegexp a) = Value $ PuppetRegexp a
resolved2expression (ResolvedDouble d) = Value $ Double d
arithmeticOperation :: Expression -> Expression -> (Integer -> Integer -> Integer) -> (Double -> Double -> Double) -> GeneralValue -> CatalogMonad GeneralValue
arithmeticOperation a b opi opf def = do
ra <- tryResolveExpression a
rb <- tryResolveExpression b
case (ra, rb) of
(Right (ResolvedInt sa) , Right (ResolvedInt sb)) -> return $ Right $ ResolvedInt $ opi sa sb
(Right (ResolvedDouble sa), Right (ResolvedInt sb)) -> return $ Right $ ResolvedDouble $ opf sa (fromIntegral sb)
(Right (ResolvedInt sa) , Right (ResolvedDouble sb)) -> return $ Right $ ResolvedDouble $ opf (fromIntegral sa) sb
(Right (ResolvedDouble sa), Right (ResolvedDouble sb)) -> return $ Right $ ResolvedDouble $ opf sa sb
_ -> return def
stringTransform :: [Expression] -> Value -> (String -> String) -> CatalogMonad GeneralValue
stringTransform [u] n f = do
r <- tryResolveExpressionString u
case r of
Right s -> return $ Right $ ResolvedString $ f s
Left _ -> return $ Left $ Value n
stringTransform _ _ _ = throwPosError "This function takes a single argument."