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 Puppet.Utils
import qualified Data.Aeson as JSON
import System.IO.Unsafe
import Control.Arrow (first,(***))
import Data.List
import Data.Char (isAlpha, isAlphaNum)
import Data.Maybe (isJust, fromJust, catMaybes, isNothing, mapMaybe)
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
import qualified Data.Traversable as DT
import qualified Data.Graph as Graph
import qualified Data.Tree as Tree
import qualified Data.Text as T
qualified :: T.Text -> Bool
qualified = T.isInfixOf "::"
readint :: T.Text -> CatalogMonad Integer
readint x = case readDecimal x of
Right y -> return y
Left _ -> throwPosError $ "Expected an integer instead of '" <> x
getCatalog :: (TopLevelType -> T.Text -> IO (Either String Statement))
-> (Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> IO (Either String T.Text))
-> (T.Text -> PDB.Query -> IO (Either String JSON.Value))
-> T.Text
-> Facts
-> Maybe T.Text
-> Map.Map PuppetTypeName PuppetTypeMethods
-> IO (Either String (FinalCatalog, EdgeMap, FinalCatalog), [T.Text])
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 (first Just) (initLua m)
Nothing -> return (Nothing, [])
(!output, !finalstate) <- runStateT ( runErrorT ( computeCatalog getstatements nodename ) )
ScopeState
{ curScope = [["::"]]
, curVariables = convertedfacts
, curClasses = Map.empty
, curDefaults = Map.empty
, 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
, definedResources = Map.singleton ("node",nodename) (newPos "site.pp" 0 0)
, currentDependencyStack = [("node",nodename)]
}
case luastate of
Just l -> closeLua l
Nothing -> return ()
case output of
Left x -> return (Left (T.unpack x), getWarnings finalstate)
Right x -> return (Right x, getWarnings finalstate)
computeCatalog :: (TopLevelType -> T.Text -> IO (Either String Statement)) -> T.Text -> CatalogMonad (FinalCatalog, EdgeMap, FinalCatalog)
computeCatalog getstatements nodename = do
nodestatements <- liftIO $ getstatements TopNode nodename
case nodestatements of
Left x -> throwError (T.pack x)
Right nodestmts -> evaluateStatements nodestmts >>= finalResolution
resolveResource :: CResource -> CatalogMonad (ResIdentifier, RResource)
resolveResource cr@(CResource cid cname ctype cparams _ scopes cpos) = do
setPos cpos
rname <- resolveGeneralString cname
rparams <- mapM (\(a,b) -> do { ra <- resolveGeneralString a; rb <- resolveGeneralValue b; return (ra,rb); }) (Map.toList cparams)
nparams <- processOverride cr (Map.fromList rparams)
let mrrelations = []
prefinalresource = RResource cid rname ctype nparams mrrelations scopes cpos
return ((ctype, rname), prefinalresource)
finalizeResource :: CResource -> CatalogMonad (ResIdentifier, RResource)
finalizeResource cr = do
((_, rname), prefinalresource) <- extractRelations cr >>= resolveResource
let ctype = rrtype prefinalresource
cpos = rrpos prefinalresource
saveAlias :: ResolvedValue -> CatalogMonad ()
saveAlias (ResolvedString al) | al == rname = return ()
| otherwise = addDefinedResource (ctype, al) cpos
saveAlias x = throwPosError ("This alias is not a string:" <> tshow x)
setPos cpos
ntypes <- fmap nativeTypes get
unless (Map.member ctype ntypes) $ throwPosError $ "Can't find native type " <> ctype
let validatefunction = puppetvalidate (ntypes Map.! ctype)
validated = validatefunction prefinalresource
case validated of
Left err -> throwPosError (T.pack err <> " for resource " <> ctype <> "[" <> rname <> "]")
Right finalresource -> do
case Map.findWithDefault (ResolvedArray []) "alias" (rrparams finalresource) of
(ResolvedArray aliases) -> mapM_ saveAlias aliases
s@(ResolvedString _) -> saveAlias s
x -> throwPosError ("Aliases should be arrays of strings, not " <> tshow x)
return ((ctype, rname), finalresource)
collectionChecks :: CResource -> CatalogMonad [CResource]
collectionChecks res =
if crvirtuality res == Normal
then return [res]
else do
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 T.Text ResolvedValue -> CatalogMonad (Map.Map T.Text ResolvedValue)
processOverride cr prms =
let applyOverride :: CResource -> Map.Map T.Text ResolvedValue -> (CResource -> CatalogMonad Bool, Map.Map GeneralString GeneralValue, Maybe PDB.Query) -> CatalogMonad (Map.Map T.Text ResolvedValue)
applyOverride c prm (func, overs, _) = do
check <- func c
if check
then foldM tryReplace prm (Map.toList overs)
else return prm
tryReplace :: Map.Map T.Text ResolvedValue -> (GeneralString, GeneralValue) -> CatalogMonad (Map.Map T.Text ResolvedValue)
tryReplace curmap (gs, gv) = do
rs <- resolveGeneralString gs
rv <- resolveGeneralValue gv
return $ Map.insert rs rv curmap
in liftM (filter (\(_, x, _) -> not $ Map.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
case res of
Right h -> return h
Left err -> throwError $ "PuppetDB error: " <> T.pack err
extractRelations :: CResource -> CatalogMonad CResource
extractRelations cr = do
setPos (pos cr)
(params, relations) <- partitionParamsRelations (crparams cr)
addUnresRel (relations, (crtype cr, crname cr), UNormal, pos cr, crscope cr)
return cr { crparams = params }
resolveRelationship :: ([(LinkType, GeneralValue, GeneralValue)], (T.Text, GeneralString), RelUpdateType, SourcePos, [[ScopeName]])
-> CatalogMonad ([(LinkType, ResIdentifier)], ResIdentifier, RelUpdateType, SourcePos, [[ScopeName]])
resolveRelationship (udsts, (stype, usname), uptype, spos, scop) = do
let resolveSrcRel (ltype, udtype, udname) = do
dtype <- resolveGeneralValue udtype >>= rstring
resolveGeneralValue udname >>= rstrings >>= mapM (\dname -> return (ltype, (dtype, dname)))
dsts <- fmap concat (mapM resolveSrcRel udsts)
sname <- resolveGeneralString usname
return (dsts, (stype, sname), uptype, spos, scop)
finalizeRelations :: FinalCatalog -> FinalCatalog -> CatalogMonad (FinalCatalog, EdgeMap)
finalizeRelations exported cat = do
grels <- fmap unresolvedRels get >>= mapM resolveRelationship
drs <- fmap definedResources get
let extr :: ([(LinkType, ResIdentifier)], ResIdentifier, RelUpdateType, SourcePos, [[ScopeName]])
-> [(ResIdentifier, ResIdentifier, LinkInfo)]
extr (dsts, src, rutype, spos, scp) = do
(ltype, dst) <- dsts
return (dst, src, (ltype, rutype, spos, scp))
!rels = concatMap extr grels :: [(ResIdentifier, ResIdentifier, LinkInfo)]
checkRelationExists :: (ResIdentifier, ResIdentifier, LinkInfo) -> CatalogMonad (Maybe (ResIdentifier, ResIdentifier, LinkInfo))
checkRelationExists !o@(!src, !dst, (!ltype,!lutype,!lpos,!lscope)) =
case (Map.member src drs, Map.member dst drs, Map.member src exported, Map.member dst exported) of
(_, _, _, True) -> return Nothing
(True, True,_ , _) -> case ltype of
RNotify -> return $ Just (dst, src, (RSubscribe, lutype,lpos,lscope))
RBefore -> return $ Just (dst, src, (RRequire , lutype,lpos,lscope))
_ -> return (Just o)
(False, _, _, _) -> throwError $ "Unknown resources " <> tshow src <> " used as source (destination: " <> tshow dst <> ") in a relation at " <> tshow lpos <> " debug: " <> tshow (Map.member src drs, Map.member dst drs, Map.member src exported, Map.member dst exported) <> " " <> showScope lscope
(_, False, _, _) -> throwError $ "Unknown resources " <> tshow dst <> " used as destination (source: " <> tshow src <> ") in a relation at " <> tshow lpos <> " debug: " <> tshow (Map.member src drs, Map.member dst drs, Map.member src exported, Map.member dst exported) <> " " <> showScope lscope
checkedrels <- fmap catMaybes $ mapM checkRelationExists rels
let !edgeMap = Map.fromList (map (\(d,s,i) -> ((s,d),i)) checkedrels) :: EdgeMap
!nodeRel = Map.fromListWith (++) (map (\(d,s,_) -> (s,[d])) checkedrels) :: Map.Map ResIdentifier [ResIdentifier]
!(relgraph,qfunc) = Graph.graphFromEdges' $ map (\(a,b) -> (a,a,b)) $ Map.toList nodeRel
!cycles = map (map ((\(a,_,_) -> a) . qfunc) . Tree.flatten) $ filter (not . null . Tree.subForest) $ Graph.scc relgraph :: [[ResIdentifier]]
describe :: [ResIdentifier] -> T.Text
describe [] = "[]"
describe x = let rx = map (\i -> (i, drs Map.! i)) x
in T.intercalate "\n\t\t" (showRRef (head x) : zipWith describe' x (tail rx))
describe' :: ResIdentifier -> (ResIdentifier, SourcePos) -> T.Text
describe' src (dst,dpos) = " -> " <> showRRef dst <> " [" <> tshow dpos <> "] link is " <> tshow (Map.lookup (src,dst) edgeMap)
if null cycles
then return (cat, edgeMap)
else throwError $ "The following cycles have been found:\n\t" <> T.intercalate "\n\t" (map describe cycles)
finalResolution :: Catalog -> CatalogMonad (FinalCatalog, EdgeMap, FinalCatalog)
finalResolution cat = do
pdbfunction <- fmap puppetDBFunction get
fqdnr <- getVariable "::fqdn"
collectedRemote <- do
fqdn <- case fqdnr of
Just (Right (ResolvedString f'), _) -> return f'
_ -> throwError "Could not get FQDN during final resolution"
remoteCollects <- fmap (mapMaybe (\(_,_,x) -> x) . curCollect) get
let
isNotLocal :: CResource -> Bool
isNotLocal cr = case Map.lookup (Right "EXPORTEDSOURCE") (crparams cr) of
Just (Right (ResolvedString x)) -> x /= fqdn
_ -> True
toCR :: Either String JSON.Value -> Either String [CResource]
toCR (Left r) = Left r
toCR (Right x) = case json2puppet x of
Left rr -> Left rr
Right s -> Right $ filter isNotLocal s
fmap concat (mapM (retrieveRemoteResources (fmap toCR . pdbfunction "resources")) remoteCollects)
let
addCollectedDefines cr = do
let rtype = crtype cr
rname <- resolveGeneralString (crname cr)
isdef <- checkDefine rtype
case isdef of
Just _ -> addDefinedResource (rtype, rname) (pos cr)
Nothing -> return ()
collectedRemote' <- mapM extractRelations collectedRemote
mapM_ addCollectedDefines collectedRemote'
collectedLocal <- fmap concat $ mapM collectionChecks cat
collectedLocalD <- fmap concat $ mapM evaluateDefine collectedLocal
collectedRemoteD <- fmap concat $ mapM evaluateDefine collectedRemote'
let addCollectedRemoteResource :: CResource -> CatalogMonad ()
addCollectedRemoteResource (CResource _ (Right cn) ct prms _ _ cp) = do
addDefinedResource (ct, cn) cp
case Map.lookup (Right "alias") prms of
Just (Right (ResolvedString s)) -> addDefinedResource (ct, s) cp
Just x -> throwPosError ("Alias must be a single string, not " <> tshow x)
_ -> return ()
addCollectedRemoteResource x = throwPosError $ "finalResolution/addCollectedRemoteResource the remote resource name was not properly defined: " <> tshow (crname x)
mapM_ addCollectedRemoteResource collectedRemoteD
let collected = collectedLocalD ++ collectedRemoteD
(real, allvirtual) = partition (\x -> crvirtuality x == Normal) collected
(_, exported) = partition (\x -> crvirtuality x == Virtual) allvirtual
rexported <- mapM resolveResource exported
let !exportMap = Map.fromList rexported
(fc, em) <- mapM finalizeResource real >>= createResourceMap >>= finalizeRelations exportMap
return (fc, em, exportMap)
createResourceMap :: [(ResIdentifier, RResource)] -> CatalogMonad FinalCatalog
createResourceMap = foldM insertres Map.empty
where
insertres :: FinalCatalog -> (ResIdentifier, RResource) -> CatalogMonad FinalCatalog
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 " <> tshow (rrpos r) <> " " <> showScope (rrscope r)
<> "\n\t" <> rrtype res <> "[" <> rrname res <> "] at " <> tshow (rrpos res) <> " " <> showScope (rrscope res) :: T.Text)
(_, Nothing) -> return newmap
getstatement :: TopLevelType -> T.Text -> CatalogMonad Statement
getstatement qtype name = do
curcontext <- get
let stmtsfunc = getStatementsFunction curcontext
estatement <- liftIO $ stmtsfunc qtype name
case estatement of
Left x -> throwPosError (T.pack x)
Right y -> return y
pushDefaults :: ResDefaults -> CatalogMonad ()
pushDefaults d = do
curstate <- get
let curscope = (head . curScope) curstate
curdefaults = curDefaults curstate
newdefaults = Map.insertWith (++) curscope [d] curdefaults
put (curstate { curDefaults = newdefaults })
emptyDefaults :: CatalogMonad ()
emptyDefaults = do
curstate <- get
let curscope = (head . curScope) curstate
curdefaults = curDefaults curstate
newdefaults = Map.delete curscope curdefaults
put (curstate { curDefaults = newdefaults })
getCurDefaults :: CatalogMonad [ResDefaults]
getCurDefaults = do
curstate <- get
let curscope = (head . curScope) curstate
curdefaults = curDefaults curstate
case Map.lookup curscope curdefaults of
Nothing -> return []
Just x -> return x
pushDependency :: ResIdentifier -> CatalogMonad ()
pushDependency = modify . modifyDeps . (:)
popDependency :: CatalogMonad ()
popDependency = modify (modifyDeps tail)
pushScope :: [ScopeName] -> CatalogMonad ()
pushScope = modify . modifyScope . (:)
popScope :: CatalogMonad ()
popScope = modify (modifyScope tail)
getScope :: CatalogMonad [T.Text]
getScope = do
scope <- liftM curScope get
if null scope
then throwError "empty scope, shouldn't happen"
else return $ head scope
addLoaded :: T.Text -> SourcePos -> CatalogMonad ()
addLoaded name = modify . modifyClasses . Map.insert name
getNextId = do
curscope <- get
put $ incrementResId curscope
return (curResId curscope)
setPos = modify . setStatePos
qualify k cs | qualified k || (cs == "::") = cs <> k
| otherwise = cs <> "::" <> k
putVariable k v = getScope >>= mapM_ (\x -> modify (modifyVariables (Map.insert (qualify k x) v)))
setModuleName :: T.Text -> CatalogMonad ()
setModuleName str = do
let (amodulename, remain) = T.break (==':') str
modulename = if T.null remain
then "topmodule"
else amodulename
cpos <- getPos
vars <- fmap curVariables get
let nvars = Map.insert "::caller_module_name" (Right (ResolvedString modulename), cpos) vars
saveVariables nvars
getVariable vname = liftM (Map.lookup vname . curVariables) get
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 :: T.Text -> CatalogMonad ()
addWarning = modify . pushWarning
addCollect ((func, query), overrides) = modify $ pushCollect (func, overrides, query)
addUnresRel :: ([(LinkType, GeneralValue, GeneralValue)], (T.Text, GeneralString), RelUpdateType, SourcePos, [[ScopeName]]) -> CatalogMonad ()
addUnresRel ncol@(rels, _, _, _, _) = unless (null rels) (modify (pushUnresRel ncol))
checkDefine :: T.Text -> 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 = " <> T.pack err)
Right s -> return $ Just s
partitionParamsRelations :: Map.Map GeneralString GeneralValue -> CatalogMonad (Map.Map GeneralString GeneralValue, [(LinkType, GeneralValue, GeneralValue)])
partitionParamsRelations rparameters = do
let realparams = filteredparams :: Map.Map GeneralString GeneralValue
convertrelation :: (GeneralString, GeneralValue) -> CatalogMonad [(LinkType, GeneralValue, GeneralValue)]
convertrelation (_, Right ResolvedUndefined) = return []
convertrelation (reltype, Right (ResolvedArray rs)) = fmap concat $ mapM (\x -> convertrelation (reltype, Right x)) rs
convertrelation (reltype, Right (ResolvedRReference rt rv)) = return [(fromJust $ getRelationParameterType reltype, Right $ ResolvedString rt, Right rv)]
convertrelation (reltype, Right (ResolvedString "undef")) = return [(fromJust $ getRelationParameterType reltype, Right $ ResolvedString "undef", Right $ ResolvedString "undef")]
convertrelation (reltype, Right (ResolvedString x)) = case parseResourceReference x of
Just rr -> convertrelation (reltype, Right rr)
Nothing -> throwPosError ("partitionParamsRelations unknown string error : " <> tshow x)
convertrelation (_, Left x) = throwPosError ("partitionParamsRelations unresolved : " <> tshow x)
convertrelation x = throwPosError ("partitionParamsRelations error : " <> tshow x)
(filteredrelations, filteredparams) = Map.partitionWithKey (const . isJust . getRelationParameterType) rparameters
relations <- fmap concat (mapM convertrelation (Map.toList filteredrelations)) :: CatalogMonad [(LinkType, GeneralValue, GeneralValue)]
return (realparams, relations)
checkLoaded :: T.Text -> CatalogMonad Bool
checkLoaded name = do
curscope <- get
case Map.lookup name (curClasses curscope) of
Nothing -> return False
Just _ -> return True
resolveParams :: (Expression, Expression) -> CatalogMonad (GeneralString, GeneralValue)
resolveParams (a,b) = do
ra <- tryResolveExpressionString a
rb <- tryResolveExpression b
return (ra, rb)
addParameters :: Map.Map GeneralString GeneralValue -> [(Expression, Expression)] -> CatalogMonad (Map.Map GeneralString GeneralValue)
addParameters = foldM rp
where
rp :: Map.Map GeneralString GeneralValue -> (Expression, Expression) -> CatalogMonad (Map.Map GeneralString GeneralValue)
rp curmap prm = do
(k, v) <- resolveParams prm
case Map.lookup k curmap of
Just _ -> throwPosError $ "Parameter " <> tshow k <> " had been declared twice!"
Nothing -> return (Map.insert k v curmap)
applyDefaults :: CResource -> CatalogMonad CResource
applyDefaults res = getCurDefaults >>= foldM applyDefaults' res
applyDefaults' :: CResource -> ResDefaults -> CatalogMonad CResource
applyDefaults' r@(CResource i rname rtype rparams rvirtuality scopes rpos) (RDefaults dtype rdefs _) =
let nparams = mergeParams rparams rdefs False
in return $ if dtype == rtype
then CResource i rname rtype nparams rvirtuality scopes rpos
else r
applyDefaults' r@(CResource i rname rtype rparams rvirtuality scopes rpos) (ROverride dtype dname rdefs _) = do
srname <- resolveGeneralString rname
sdname <- resolveGeneralString dname
let nparams = mergeParams rparams rdefs True
return $ if (dtype == rtype) && (srname == sdname)
then CResource i rname rtype nparams rvirtuality scopes rpos
else r
mergeParams :: Map.Map GeneralString GeneralValue -> Map.Map GeneralString GeneralValue -> Bool -> Map.Map GeneralString GeneralValue
mergeParams srcprm defs override = if override
then defs `Map.union` srcprm
else srcprm `Map.union` defs
evaluateDefine :: CResource -> CatalogMonad [CResource]
evaluateDefine r@(CResource _ rname rtype rparams rvirtuality _ rpos) = let
evaluateDefineDeclaration dtype args dstmts dpos = do
rexpr <- resolveGeneralString rname
pushScope ["#DEFINE#" <> dtype <> "/" <> rexpr]
pushDependency (dtype, rexpr)
mparams <- fmap Map.fromList $ mapM (\(gs, gv) -> do { rgs <- resolveGeneralString gs; rgv <- tryResolveGeneralValue gv; return (rgs, (rgv, dpos)); }) (Map.toList rparams)
let expr = Right (ResolvedString rexpr)
defineparamset = Set.fromList $ map fst args
mandatoryparams = Set.fromList $ map fst $ filter (isNothing . snd) args
resourceparamset = Map.keysSet mparams
extraparams = Set.difference resourceparamset (defineparamset `Set.union` metaparameters)
unsetparams = Set.difference mandatoryparams resourceparamset
unless (Set.null extraparams) $ throwPosError $ "Spurious parameters set for " <> dtype <> ": " <> T.intercalate ", " (Set.toList extraparams)
unless (Set.null unsetparams) $ throwPosError $ "Unset parameters set for " <> dtype <> ": " <> T.intercalate ", " (Set.toList unsetparams)
putVariable "title" (expr, rpos)
putVariable "name" (expr, rpos)
mapM_ (loadClassVariable rpos mparams) args
setPos dpos
setModuleName dtype
res <- mapM evaluateStatements dstmts
nres <- handleDelayedActions (concat res)
popDependency
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]
handleDelayedActions :: Catalog -> CatalogMonad Catalog
handleDelayedActions res = do
dres <- liftM concat (mapM applyDefaults res >>= mapM evaluateDefine)
emptyDefaults
return dres
addResource :: T.Text -> [(Expression, Expression)] -> Virtuality -> SourcePos -> GeneralValue -> CatalogMonad [CResource]
addResource rtype parameters virtuality position grname = do
resid <- getNextId
rparameters <- addParameters Map.empty parameters
case grname of
Right e -> do
rse <- rstring e
curpos <- getPos
addDefinedResource (rtype, rse) curpos
case Map.lookup (Right "alias") rparameters of
Just (Right (ResolvedString s)) -> addDefinedResource (rtype, s) curpos
Just x -> throwPosError ("Alias must be a single string, not " <> tshow x)
_ -> return ()
(curdeptype, curdepname) <- fmap (head . currentDependencyStack) get
let defaultdependency = (RRequire, Right (ResolvedString curdeptype), Right (ResolvedString curdepname))
scopes <- fmap curScope get
addUnresRel ([defaultdependency], (rtype, Right rse), UNormal, position, scopes)
return [CResource resid (Right rse) rtype rparameters virtuality scopes position]
Left r -> throwPosError ("Could not determine the current resource name: " <> tshow r)
evaluateStatements :: Statement -> CatalogMonad Catalog
evaluateStatements (Node _ stmts position) = do
setPos position
res <- mapM evaluateStatements stmts
handleDelayedActions (concat res)
evaluateStatements (Include includename position) = setPos position >> resolveExpressionString includename >>= getstatement TopClass >>= \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
"class" -> do
rparameters <- fmap Map.fromList $ mapM (\(a,b) -> do { pa <- resolveExpressionString a; pb <- tryResolveExpression b; return (pa, pb) } ) parameters
classname <- resolveExpressionString rname
topstatement <- getstatement TopClass classname
let classparameters = Map.map (\pvalue -> (pvalue, position)) rparameters :: Map.Map T.Text (GeneralValue, SourcePos)
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 <- addParameters Map.empty rdparams
pushDefaults $ RDefaults rdtype rrdparams rdpos
return []
evaluateStatements (ResourceOverride rotype roname roparams ropos) = do
rroname <- tryResolveExpressionString roname
rroparams <- addParameters Map.empty roparams
pushDefaults $ ROverride rotype rroname rroparams ropos
return []
evaluateStatements (DependenceChain (srctype, srcname) (dsttype, dstname) position) = do
setPos position
gdstname <- tryResolveExpression dstname
gsrcname <- tryResolveExpressionString srcname
scp <- fmap curScope get
addUnresRel ( [(RRequire, Right $ ResolvedString dsttype, gdstname)], (srctype, gsrcname), UPlus, position, scp)
return []
evaluateStatements (ResourceCollection rtype expr overrides position) = do
setPos position
unless (null overrides) $ throwPosError "Amending attributes with a Collector only works with <| |>, not <<| |>>."
func <- collectionFunction Exported rtype expr
addCollect (func, Map.empty)
return []
evaluateStatements (VirtualResourceCollection rtype expr overrides position) = do
setPos position
func <- collectionFunction Virtual rtype expr
prms <- addParameters Map.empty 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 " <> tshow x)
loadClassVariable :: SourcePos -> Map.Map T.Text (GeneralValue, SourcePos) -> (T.Text, Maybe Expression) -> CatalogMonad (T.Text, GeneralValue)
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 " <> tshow position
rv <- tryResolveGeneralValue v
putVariable paramname (rv, vpos)
return (paramname, rv)
evaluateClass :: Statement -> Map.Map T.Text (GeneralValue, SourcePos) -> Maybe T.Text -> 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
oldpos <- getPos
addDefinedResource ("class", classname) oldpos
let classparamset = Set.fromList $ map fst parameters
inputparamset = Set.filter (isNothing . getRelationParameterType . Right) $ Map.keysSet inputparams
overparams = Set.difference inputparamset (Set.union metaparameters classparamset)
unless (Set.null overparams) (throwError $ "Spurious parameters " <> T.intercalate ", " (Set.toList overparams) <> " at " <> tshow position)
resid <- getNextId
case actualname of
Nothing -> pushScope [classname]
Just ac -> pushScope [classname, ac]
mparameters <- mapM (loadClassVariable position inputparams) parameters
setPos position
pushDependency ("class", classname)
setModuleName classname
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
res <- mapM evaluateStatements statements
nres <- handleDelayedActions (concat res)
mapM_ (addClassDependency classname) nres
scopes <- fmap curScope get
popScope
popDependency
return $
[CResource resid (Right classname) "class" (Map.fromList $ map (first Right) mparameters) Normal scopes 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 " <> tshow x)
addClassDependency :: T.Text -> CResource -> CatalogMonad ()
addClassDependency cname (CResource _ rname rtype _ _ scp position) =
addUnresRel (
[(RRequire, Right $ ResolvedString "class", Right $ ResolvedString cname)]
, (rtype, rname)
, UPlus
, position
, scp
)
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 (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 " <> tshow 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 " <> tshow reg <> ": " <> T.pack err
(Right x, _) -> throwPosError $ "Was expecting a string to match to a regexp, not " <> tshow x
(_, Right x) -> throwPosError $ "Was expecting a regexp, not " <> tshow 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 <> " " <> tshow 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 " <> tshow x)
(_, Left y) -> throwPosError ("Could not resolve index " <> tshow y)
(Left x, _) -> throwPosError ("Could not resolve lookup " <> tshow x)
(Right x, _) -> throwPosError ("Could not resolve something that is not an array nor a hash, but " <> tshow x)
tryResolveGeneralValue o@(Left (IsElementOperation b a)) = do
ra <- tryResolveExpression a
rb <- tryResolveExpressionString b
case (ra, rb) of
(Right (ResolvedArray ar), Right idx) ->
let filtered = filter (compareRValues (ResolvedString idx)) ar
in return $! Right $! ResolvedBool $! not $! null filtered
(Right (ResolvedHash h), Right idx) ->
let filtered = filter (\(fa,_) -> fa == idx) h
in return $! Right $! ResolvedBool $! not $! null filtered
(Right (ResolvedString _), Right _) -> throwPosError "in operator not yet implemented for substrings"
(Right ba, Right bb) -> throwPosError $ "Expected a string and a hash, array or string for the in operator, not " <> tshow (ba,bb)
_ -> return o
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 " <> tshow e)
resolveGeneralValue :: GeneralValue -> CatalogMonad ResolvedValue
resolveGeneralValue e = do
x <- tryResolveGeneralValue e
case x of
Left n -> throwPosError ("Could not resolveGeneralValue " <> tshow 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 T.Text
rstring resolved = case resolved of
ResolvedString s -> return s
ResolvedInt i -> return (tshow i)
e -> throwPosError ("'" <> tshow e <> "' will not resolve to a string")
rstrings :: ResolvedValue -> CatalogMonad [T.Text]
rstrings resolved = case resolved of
ResolvedString s -> return [s]
ResolvedInt i -> return [tshow i]
ResolvedArray xs -> mapM rstring xs
e -> throwPosError ("'" <> tshow e <> "' will not resolve to a string")
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 '" <> tshow x <> "' at " <> tshow p <> " was '" <> tshow e <> "'")
resolveExpressionString :: Expression -> CatalogMonad T.Text
resolveExpressionString x = do
resolved <- resolveExpression x
case resolved of
ResolvedString s -> return s
ResolvedInt i -> return (tshow i)
e -> do
p <- getPos
throwError ("Can't resolve expression '" <> tshow e <> "' to a string at " <> tshow 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 (PuppetBool x) = return $ Right $ ResolvedBool x
tryResolveValue n@(ResourceReference rtype vals) = do
rvals <- tryResolveExpression vals
case rvals of
Right resolved -> return $ Right $ ResolvedRReference rtype resolved
_ -> return $ Left $ Value n
tryResolveValue (VariableReference "module_name") = liftM (\x ->
let headname = T.takeWhile (/= ':') (head x)
in Right $ ResolvedString $ if T.isPrefixOf "#DEFINE#" headname
then T.drop 8 headname
else headname
) getScope
tryResolveValue (VariableReference vname) = do
curscp <- getScope
let gvarnm sc | qualified vname = vname : remtopscope vname
| sc == "::" = ["::" <> vname]
| otherwise = [sc <> "::" <> vname, "::" <> vname]
varnames = concatMap gvarnm curscp
remtopscope x | T.isPrefixOf "::" x = [T.drop 2 x]
| otherwise = []
matching <- liftM catMaybes (mapM getVariable varnames)
if null matching
then do
position <- getPos
addWarning ("Could not resolveValue variables " <> tshow varnames <> " at " <> tshow 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 $ T.concat $ rights resolved
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
return $ if null (lefts resolvedKeys) && null (lefts resolvedValues)
then Right $ ResolvedHash $ zip (rights resolvedKeys) (rights resolvedValues)
else Left $ Value n
tryResolveValue n@(PuppetArray expressions) = do
resolvedExpressions <- mapM tryResolveExpression expressions
return $ if null $ lefts resolvedExpressions
then Right $ ResolvedArray $ rights resolvedExpressions
else 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 <> " (" <> tshow cmdargs <> ") failed"
tryResolveValue n@(FunctionCall "pdbresourcequery" (query:xs)) = do
let
rvalue2query :: ResolvedValue -> Either String PDB.Query
rvalue2query (ResolvedArray (ResolvedString o : nxs)) = case PDB.getOperator o of
Just PDB.OAnd -> fmap (PDB.Query PDB.OAnd) (mapM rvalue2query nxs)
Just PDB.OOr -> fmap (PDB.Query PDB.OOr) (mapM rvalue2query nxs)
Just PDB.ONot -> fmap (PDB.Query PDB.ONot) (mapM rvalue2query nxs)
Just op -> fmap (PDB.Query op) (mapM rvalue2query' nxs)
Nothing -> Left $ "Can't resolve operator " ++ T.unpack o
rvalue2query x = Left $ "Don't know what to do with " ++ T.unpack (showValue x)
rvalue2query' :: ResolvedValue -> Either String PDB.Query
rvalue2query' (ResolvedArray x) = fmap PDB.Terms (mapM rvalue2string x)
rvalue2query' x = fmap PDB.Term (rvalue2string x)
rvalue2string :: ResolvedValue -> Either String T.Text
rvalue2string (ResolvedString s) = Right s
rvalue2string (ResolvedBool True) = Right "true"
rvalue2string (ResolvedBool False) = Right "false"
rvalue2string x = Left $ "Don't know why we had " ++ T.unpack (showValue x)
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) -> case rvalue2query a of
Right q -> fmap Right (pdbresourcequery q keyname)
Left rr -> throwPosError ("Could not transform " <> showValue a <> " to a PuppetDB query: " <> T.pack rr)
(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 = T.length gs < 64 && not (T.null gs) && isAlpha (T.head gs) && (T.all (\gx -> gx == '-' || isAlphaNum gx) gs)
badparts "" = False
badparts str =
let (b,e) = T.break (=='.') str
in case (goodpart b, e) of
(True , "") -> False
(True , y) -> badparts (T.tail y)
(False, _) -> True
bad = T.null s || T.length s > 255 || badparts s
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)
hostname <- getVariable "::fqdn" >>= \x -> case x of
Just (Right (ResolvedString g),_) -> return g
_ -> throwPosError "Can't get fqdn in fqdn_rand?"
let targs = tail nargs
rargs = if null targs
then [hostname, ""]
else hostname : targs
liftM (Right . ResolvedInt) (fqdn_rand curmax rargs)
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 " <> tshow x
Right filename -> do
vars <- fmap curVariables get >>= DT.mapM (\(v,p) -> fmap (\x -> (x,p)) (tryResolveGeneralValue v))
saveVariables vars
scp <- liftM head getScope
templatefunc <- liftM computeTemplateFunction get
out <- liftIO (templatefunc (Right filename) scp (Map.map fst vars))
case out of
Right x -> return $ Right $ ResolvedString x
Left err -> throwPosError (T.pack err)
tryResolveValue (FunctionCall "inline_template" [cnt]) = do
rcnt <- tryResolveExpressionString cnt
case rcnt of
Left x -> throwPosError $ "Can't resolve inline_template content " <> tshow x
Right content -> do
vars <- fmap curVariables get >>= DT.mapM (\(v,p) -> fmap (\x -> (x,p)) (tryResolveGeneralValue v))
saveVariables vars
scp <- liftM head getScope
templatefunc <- liftM computeTemplateFunction get
out <- liftIO (templatefunc (Left content) scp (Map.map fst vars))
case out of
Right x -> return $ Right $ ResolvedString x
Left err -> throwPosError (T.pack err)
tryResolveValue (FunctionCall "defined" [v]) = do
rv <- tryResolveExpression v
case rv of
Left n -> return $ Left n
Right (ResolvedString typeorclass) -> do
ntypes <- fmap nativeTypes get
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 rtype (ResolvedString rname)) -> do
defset <- fmap definedResources get
return $ Right $ ResolvedBool (Map.member (rtype, rname) defset)
Right x -> throwPosError $ "Can't know if this could be defined : " <> tshow 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 " <> tshow args)
tryResolveValue n@(FunctionCall "chomp" [str]) = do
let mmychomp (ResolvedString s) = return $ ResolvedString (T.stripEnd s)
mmychomp r = throwPosError $ "The chomp function expects strings or arrays of strings, not this: " <> tshow 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: " <> tshow r
_ -> return $ Left $ Value n
tryResolveValue (FunctionCall "split" _) = throwPosError "Bad argument count for function split"
tryResolveValue n@(FunctionCall "upcase" args) = stringTransform args n T.toUpper
tryResolveValue n@(FunctionCall "lowcase" args) = stringTransform args n T.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
rfilelist <- mapM tryResolveExpressionString filelist
let (lf, rf) = partitionEithers rfilelist
if null lf
then do
content <- liftIO $ file rf
case content of
Nothing -> throwPosError $ "Files " <> tshow rf <> " could not be found"
Just x -> return $ Right $ ResolvedString x
else return $ Left $ Value n
tryResolveValue n@(FunctionCall "getvar" [varinfo]) = do
varname <- tryResolveExpressionString varinfo
case varname of
Right s -> tryResolveValue (VariableReference s)
Left _ -> return $ Left $ Value n
tryResolveValue (FunctionCall "getvar" nn) = throwPosError $ "getvar expects a single argument, not " <> tshow (length nn)
tryResolveValue n@(FunctionCall "is_string" [varinfo]) = do
varname <- tryResolveExpression varinfo
case varname of
Right (ResolvedString _) -> return $ Right $ ResolvedBool True
Right _ -> return $ Right $ ResolvedBool False
Left _ -> 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 " <> tshow 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 (tshow i)
Right (ResolvedDouble i) -> return $ Right (tshow i)
Right (ResolvedBool True) -> return $ Right "True"
Right (ResolvedBool False) -> return $ Right "False"
Right v -> throwPosError ("Can't resolve valuestring for " <> tshow 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
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) , Map.empty)
return ()
pushRealize (ResolvedRReference _ x) = throwPosError (tshow x <> " was not resolved to a string")
pushRealize x = throwPosError ("A reference was expected instead of " <> tshow x)
executeFunction :: T.Text -> [ResolvedValue] -> CatalogMonad Catalog
executeFunction "fail" [ResolvedString errmsg] = throwPosError ("Error: " <> errmsg)
executeFunction "fail" args = throwPosError ("Error: " <> tshow args)
executeFunction "realize" rlist = mapM_ pushRealize rlist >> return []
executeFunction "dumpvariables" _ = do
vars <- fmap curVariables get
mapM_ (liftIO . print) (Map.toList vars)
return []
executeFunction "create_resources" (mrtype:rdefs:rest) = do
mrrtype <- case mrtype of
ResolvedString x -> return x
_ -> throwPosError $ "Resource type must be a string and not " <> tshow mrtype
arghash <- case rdefs of
ResolvedHash x -> return x
_ -> throwPosError $ "Resource definition must be a hash, and not " <> tshow rdefs
position <- getPos
defaults <- case rest of
[ResolvedHash h] -> return $ RDefaults mrrtype (Map.fromList $ map (Right *** Right) h) position
[] -> return $ RDefaults mrrtype Map.empty position
_ -> throwPosError ("Bad many arguments to create_resources: " <> tshow rest)
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) >>= mapM (\r -> applyDefaults' r defaults)
executeFunction "create_resources" x = throwPosError ("Bad arguments to create_resources: " <> tshow x)
executeFunction "validate_array" [x] = case x of
ResolvedArray _ -> return []
y -> throwPosError $ tshow y <> " is not an array"
executeFunction "validate_hash" [x] = case x of
ResolvedHash _ -> return []
y -> throwPosError $ tshow y <> " is not a hash"
executeFunction "validate_string" [x] = case x of
ResolvedString _ -> return []
y -> throwPosError $ tshow 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 $ tshow x <> " does not match the regexp " <> tshow rre
Left err -> throwPosError $ "Error with regexp " <> tshow rre <> ": " <> T.pack err
(y,z) -> throwPosError $ "Can't compare " <> tshow y <> " to regexp " <> tshow z
executeFunction "validate_bool" [x] = case x of
ResolvedBool _ -> return []
y -> throwPosError $ tshow y <> " is not a boolean"
executeFunction fname args = do
ufunctions <- fmap userFunctions get
l <- fmap luaState get
case (l, Set.member fname ufunctions) of
(Just ls, True) -> do
o <- puppetFunc ls fname args
case o of
ResolvedBool True -> return []
ResolvedBool False -> throwPosError ("Function " <> fname <> "(" <> tshow args <> ") returned false")
x -> throwPosError ("Function " <> fname <> "(" <> tshow args <> ") did not return a bool: " <> tshow x)
_ -> do
position <- getPos
addWarning $ "Function " <> fname <> "(" <> tshow args <> ") not handled at " <> tshow 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 (ResolvedString s) (ResolvedBool b) = case (s,b) of
("true", True) -> EQ
("false", False) -> EQ
_ -> LT
compareValues a@(ResolvedBool _) b@(ResolvedString _) = compareValues b a
compareValues a@(ResolvedString _) b@(ResolvedInt _) = compareValues b a
compareValues (ResolvedInt a) (ResolvedString b) = case readDecimal b of
Right bi -> compare a bi
_ -> LT
compareValues (ResolvedString a) (ResolvedRegexp b) = case unsafePerformIO (regmatch a b) of
Right True -> EQ
_ -> LT
compareValues (ResolvedString a) (ResolvedString b) = comparing T.toCaseFold a b
compareValues x y = compare x y
compareRValues :: ResolvedValue -> ResolvedValue -> Bool
compareRValues a b = compareValues a b == EQ
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
Left (EqualOperation (Value (VariableReference _)) (Value (Literal "true"))) -> return $ Right $ ResolvedBool False
Left (EqualOperation (Value (VariableReference _)) (Value (Literal "false"))) -> return $ Right $ ResolvedBool True
_ -> 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 " <> tshow n <> "(was " <> tshow rv <> ") as a boolean")
resolveGeneralString :: GeneralString -> CatalogMonad T.Text
resolveGeneralString (Right x) = return x
resolveGeneralString (Left y) = resolveExpressionString y
collectionFunction :: Virtuality -> T.Text -> 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 " <> tshow x
when (Set.notMember paramname paramset && not (Set.member paramname metaparameters)) $
throwPosError $ "Parameter " <> paramname <> " is not a valid parameter. It should be in : " <> tshow (Set.toList paramset)
return (\r ->
case Map.lookup (Right paramname) (crparams r) of
Nothing -> return False
Just prmmatch -> do
cmp <- resolveGeneralValue prmmatch
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 " <> tshow x
return (\res ->
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: " <> tshow 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 -> (T.Text -> T.Text) -> 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."