module Puppet.Interpreter where
import Puppet.Interpreter.Types
import Puppet.Interpreter.PrettyPrinter(containerComma)
import Puppet.Interpreter.Resolve
import Puppet.Parser.Types
import Puppet.Lens
import Puppet.Parser.PrettyPrinter
import Puppet.PP hiding ((<$>))
import Puppet.NativeTypes
import Prelude hiding (mapM)
import Puppet.Utils
import System.Log.Logger
import Data.Maybe
import Data.List (nubBy)
import qualified Data.Text as T
import Data.Tuple.Strict (Pair(..))
import qualified Data.Tuple.Strict as S
import qualified Data.Either.Strict as S
import qualified Data.HashSet as HS
import qualified Data.HashMap.Strict as HM
import Control.Monad.Error hiding (mapM,forM)
import Control.Lens
import qualified Data.Maybe.Strict as S
import qualified Data.Graph as G
import qualified Data.Tree as T
import Data.Foldable (toList,foldl',Foldable,foldlM)
import Data.Traversable (mapM)
import Control.Monad.Operational hiding (view)
import Control.Applicative
vmapM :: (Monad m, Foldable t) => (a -> m b) -> t a -> m [b]
vmapM f = mapM f . toList
getModulename :: RIdentifier -> T.Text
getModulename (RIdentifier t n) =
let gm x = case T.splitOn "::" x of
[] -> x
(y:_) -> y
in case t of
"class" -> gm n
_ -> gm t
getCatalog :: Monad m
=> (forall a. InterpreterReader m -> InterpreterState -> InterpreterMonad a -> m (Either PrettyError a, InterpreterState, InterpreterWriter))
-> ( TopLevelType -> T.Text -> m (S.Either PrettyError Statement) )
-> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> m (S.Either PrettyError T.Text))
-> PuppetDBAPI m
-> T.Text
-> Facts
-> Container NativeTypeMethods
-> Container ( [PValue] -> InterpreterMonad PValue )
-> HieraQueryFunc m
-> ImpureMethods m
-> HS.HashSet T.Text
-> m (Pair (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Priority Doc])
getCatalog convertMonad gtStatement gtTemplate pdbQuery ndename facts nTypes extfuncs hquery im ignord = do
let rdr = InterpreterReader nTypes gtStatement gtTemplate pdbQuery extfuncs ndename hquery im ignord
stt = initialState facts
(output, _, warnings) <- convertMonad rdr stt (computeCatalog ndename)
return (strictifyEither output :!: warnings)
isParent :: T.Text -> CurContainerDesc -> InterpreterMonad Bool
isParent cur (ContClass possibleparent) = preuse (scopes . ix cur . scopeParent) >>= \case
Nothing -> throwPosError ("Internal error: could not find scope" <+> ttext cur <+> "possible parent" <+> ttext possibleparent)
Just S.Nothing -> return False
Just (S.Just p) -> if p == possibleparent
then return True
else isParent p (ContClass possibleparent)
isParent _ _ = return False
finalize :: [Resource] -> InterpreterMonad [Resource]
finalize rlist = do
scp <- getScopeName
defs <- use (scopes . ix scp . scopeDefaults)
let getOver = use (scopes . ix scp . scopeOverrides)
addDefaults r = ifoldlM (addAttribute CantReplace) r thisresdefaults
where thisresdefaults = defs ^. ix (r ^. rid . itype) . defValues
addOverrides r = getOver >>= foldlM addOverrides' r
addOverrides' r (ResRefOverride _ prms p) = do
scopes . ix scp . scopeOverrides . at (r ^. rid) .= Nothing
let forb = throwPosError ("Override of parameters of the following resource is forbidden in the current context:" </> pretty r <+> showPPos p)
s <- getScope
overrideType <- case r ^. rscope of
[] -> forb
(x:_) -> if x == s
then return CantOverride
else isParent (scopeName s) x >>= \i ->
if i
then return Replace
else forb
ifoldlM (addAttribute overrideType) r prms
withDefaults <- mapM (addOverrides >=> addDefaults) rlist
let keepforlater (ResRefOverride resid resprms ropos) = resMod %= (appended : )
where
appended = ResourceModifier (resid ^. itype) ModifierMustMatch DontRealize (REqualitySearch "title" (PString (resid ^. iname))) overrider ropos
overrider r = do
let canOverride = CantOverride
ifoldlM (addAttribute canOverride) r resprms
void $ getOver >>= mapM keepforlater
let expandableDefine r = do
n <- isNativeType (r ^. rid . itype)
if n
then return [r]
else expandDefine r
join <$> mapM expandableDefine withDefaults
popScope :: InterpreterMonad ()
popScope = curScope %= tail
pushScope :: CurContainerDesc -> InterpreterMonad ()
pushScope s = curScope %= (s :)
evalTopLevel :: Statement -> InterpreterMonad ([Resource], Statement)
evalTopLevel (TopContainer tops s) = do
pushScope ContRoot
r <- vmapM evaluateStatement tops >>= finalize . concat
(nr, ns) <- evalTopLevel s
popScope
return (r <> nr, ns)
evalTopLevel x = return ([], x)
getstt :: TopLevelType -> T.Text -> InterpreterMonad ([Resource], Statement)
getstt topleveltype toplevelname =
use (nestedDeclarations . at (topleveltype, toplevelname)) >>= \case
Just x -> return ([], x)
Nothing -> singleton (GetStatement topleveltype toplevelname) >>= evalTopLevel
extractPrism :: Prism' a b -> Doc -> a -> InterpreterMonad b
extractPrism p t a = case preview p a of
Just b -> return b
Nothing -> throwPosError ("Could not extract prism in " <> t)
computeCatalog :: T.Text -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource])
computeCatalog ndename = do
(restop, node') <- getstt TopNode ndename
node <- extractPrism _Node' "computeCatalog" node'
let finalStep [] = return []
finalStep allres = do
(realized :!: modified) <- realize allres
refinalized <- finalize (toList modified) >>= finalStep
let res = foldl' (\curm e -> curm & at (e ^. rid) ?~ e) realized refinalized
return (toList res)
mainstage = Resource (RIdentifier "stage" "main") mempty mempty mempty [ContRoot] Normal mempty dummypos ndename
resnode <- evaluateNode node >>= finalStep . (++ (mainstage : restop))
let (real :!: exported) = foldl' classify (mempty :!: mempty) resnode
classify :: Pair (HM.HashMap RIdentifier Resource) (HM.HashMap RIdentifier Resource)
-> Resource
-> Pair (HM.HashMap RIdentifier Resource) (HM.HashMap RIdentifier Resource)
classify (curr :!: cure) r =
let i curm = curm & at (r ^. rid) ?~ r
in case r ^. rvirtuality of
Normal -> i curr :!: cure
Exported -> curr :!: i cure
ExportedRealized -> i curr :!: i cure
_ -> curr :!: cure
verified <- ifromList . map (\r -> (r ^. rid, r)) <$> mapM validateNativeType (toList real)
mp <- makeEdgeMap verified
definedRes <- use definedResources
return (verified, mp, exported, HM.elems definedRes)
makeEdgeMap :: FinalCatalog -> InterpreterMonad EdgeMap
makeEdgeMap ct = do
defs' <- HM.map _rpos <$> use definedResources
clss' <- use loadedClasses
let defs = defs' <> classes' <> aliases' <> names'
names' = HM.map _rpos ct
aliases' = ifromList $ do
r <- ct ^.. traversed :: [Resource]
extraAliases <- r ^.. ralias . folded . filtered (/= r ^. rid . iname) :: [T.Text]
return (r ^. rid & iname .~ extraAliases, r ^. rpos)
classes' = ifromList $ do
(cn, _ :!: cp) <- itoList clss'
return (RIdentifier "class" cn, cp)
let reorderlink :: (RIdentifier, RIdentifier, LinkType) -> (RIdentifier, RIdentifier, LinkType)
reorderlink (s, d, RRequire) = (d, s, RBefore)
reorderlink (s, d, RSubscribe) = (d, s, RNotify)
reorderlink x = x
addRR curmap r = iunionWith (<>) curmap newmap
where
newmap = ifromListWith (<>) resresources
resid = r ^. rid
respos = r ^. rpos
resresources = do
(rawdst, lts) <- itoList (r ^. rrelations)
lt <- toList lts
let (nsrc, ndst, nlt) = reorderlink (resid, rawdst, lt)
return (nsrc, [LinkInformation nsrc ndst nlt respos])
step1 = foldl' addRR mempty ct
let realign (LinkInformation s d t p) =
let (ns, nd, nt) = reorderlink (s, d, t)
in (ns, [LinkInformation ns nd nt p])
rels <- map realign <$> use extraRelations
let step2 = iunionWith (<>) step1 (ifromList rels)
let checkResDef :: (RIdentifier, [LinkInformation]) -> InterpreterMonad (RIdentifier, RIdentifier, [RIdentifier])
checkResDef (ri, lifs) = do
let checkExists r msg = do
let modulename = getModulename r
ign <- singleton (IsIgnoredModule modulename)
unless ((defs & has (ix r)) || ign) (throwPosError msg)
errmsg = "Unknown resource" <+> pretty ri <+> "used in the following relationships:" <+> vcat (map pretty lifs)
checkExists ri errmsg
let genlnk :: LinkInformation -> InterpreterMonad RIdentifier
genlnk lif = do
let d = lif ^. linkdst
checkExists d ("Unknown resource" <+> pretty d <+> "used in a relation at" <+> showPPos (lif ^. linkPos))
return d
ds <- mapM genlnk lifs
return (ri, ri, ds)
edgeList <- mapM checkResDef (itoList step2)
let (graph, gresolver) = G.graphFromEdges' edgeList
let sccs = filter ((>1) . length . T.flatten) (G.scc graph)
unless (null sccs) $ do
let trees = vcat (map showtree sccs)
showtree = indent 2 . vcat . map (mkp . gresolver) . T.flatten
mkp (a,_,links) = resdesc <+> lnks
where
resdesc = case ct ^. at a of
Just r -> pretty r
_ -> pretty a
lnks = pretty links
throwPosError $ "Dependency error, the following resources are strongly connected!" </> trees
return step2
realize :: [Resource] -> InterpreterMonad (Pair FinalCatalog FinalCatalog)
realize rs = do
let rma = ifromList (map (\r -> (r ^. rid, r)) rs)
mutate :: Pair FinalCatalog FinalCatalog -> ResourceModifier -> InterpreterMonad (Pair FinalCatalog FinalCatalog)
mutate (curmap :!: modified) rmod = do
let filtrd = curmap ^.. folded . filtered fmod
vcheck f r = f (r ^. rvirtuality)
(isGoodvirtuality, alterVirtuality) = case rmod ^. rmType of
RealizeVirtual -> (vcheck (/= Exported), \r -> return (r & rvirtuality .~ Normal))
RealizeCollected -> (vcheck (`elem` [Exported, ExportedRealized]), \r -> return (r & rvirtuality .~ ExportedRealized))
DontRealize -> (vcheck (`elem` [Normal, ExportedRealized]), return)
fmod r = (r ^. rid . itype == rmod ^. rmResType) && checkSearchExpression (rmod ^. rmSearch) r && isGoodvirtuality r
mutation = alterVirtuality >=> rmod ^. rmMutation
applyModification :: Pair (Pair FinalCatalog FinalCatalog) Bool -> Resource -> InterpreterMonad (Pair (Pair FinalCatalog FinalCatalog) Bool)
applyModification (cma :!: cmo :!: matched) r = do
nr <- mutation r
let i m = m & at (nr ^. rid) ?~ nr
return $ if nr /= r
then i cma :!: i cmo :!: True
else cma :!: cmo :!: matched
(result :!: mtch) <- foldM applyModification (curmap :!: modified :!: False) filtrd
when (rmod ^. rmModifierType == ModifierMustMatch && not mtch) (throwError (PrettyError ("Could not apply this resource override :" <+> pretty rmod)))
return result
equalModifier (ResourceModifier a1 b1 c1 d1 _ e1) (ResourceModifier a2 b2 c2 d2 _ e2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2
result <- use resMod >>= foldM mutate (rma :!: mempty) . nubBy equalModifier
resMod .= []
return result
evaluateNode :: Nd -> InterpreterMonad [Resource]
evaluateNode (Nd _ stmts inheritance p) = do
curPos .= p
pushScope ContRoot
unless (S.isNothing inheritance) $ throwPosError "Node inheritance is not handled yet, and will probably never be"
vmapM evaluateStatement stmts >>= finalize . concat
evaluateStatementsVector :: Foldable f => f Statement -> InterpreterMonad [Resource]
evaluateStatementsVector = fmap concat . vmapM evaluateStatement
fromArgumentList :: [Pair T.Text a] -> InterpreterMonad (Container a)
fromArgumentList = foldM insertArgument mempty
where
insertArgument curmap (k :!: v) =
case curmap ^. at k of
Just _ -> throwPosError ("Parameter" <+> dullyellow (ttext k) <+> "already defined!")
Nothing -> return (curmap & at k ?~ v)
evaluateStatement :: Statement -> InterpreterMonad [Resource]
evaluateStatement r@(ClassDeclaration (ClassDecl cname _ _ _ _)) =
if "::" `T.isInfixOf` cname
then nestedDeclarations . at (TopClass, cname) ?= r >> return []
else do
scp <- getScopeName
let rcname = if scp == "::"
then cname
else scp <> "::" <> cname
nestedDeclarations . at (TopClass, rcname) ?= r
return []
evaluateStatement r@(DefineDeclaration (DefineDec dname _ _ _)) =
if "::" `T.isInfixOf` dname
then nestedDeclarations . at (TopDefine, dname) ?= r >> return []
else do
scp <- getScopeName
if scp == "::"
then nestedDeclarations . at (TopDefine, dname) ?= r >> return []
else nestedDeclarations . at (TopDefine, scp <> "::" <> dname) ?= r >> return []
evaluateStatement r@(ResourceCollection (RColl e resType searchExp mods p)) = do
curPos .= p
unless (fnull mods || e == Collector) (throwPosError ("It doesnt seem possible to amend attributes with an exported resource collector:" </> pretty r))
rsearch <- resolveSearchExpression searchExp
let et = case e of
Collector -> RealizeVirtual
ExportedCollector -> RealizeCollected
resMod %= (ResourceModifier resType ModifierCollector et rsearch return p : )
if et == RealizeCollected
then do
let q = searchExpressionToPuppetDB resType rsearch
fqdn <- singleton GetNodeName
res <- ( map (rvirtuality .~ Normal)
. filter ((/= fqdn) . _rnode)
) <$> singleton (PDBGetResources q)
scpdesc <- ContImported <$> getScope
void $ enterScope SENormal scpdesc "importing" p
pushScope scpdesc
o <- finalize res
popScope
return o
else return []
evaluateStatement (Dependency (Dep (t1 :!: n1) (t2 :!: n2) lt p)) = do
curPos .= p
rn1 <- map (fixResourceName t1) <$> resolveExpressionStrings n1
rn2 <- map (fixResourceName t2) <$> resolveExpressionStrings n2
extraRelations <>= [ LinkInformation (RIdentifier t1 an1) (RIdentifier t2 an2) lt p | an1 <- rn1, an2 <- rn2 ]
return []
evaluateStatement (ResourceDeclaration (ResDec rt ern eargs virt p)) = do
curPos .= p
resnames <- resolveExpressionStrings ern
args <- vmapM resolveArgument eargs >>= fromArgumentList
concat <$> mapM (\n -> registerResource rt n args virt p) resnames
evaluateStatement (MainFunctionCall (MFC funcname funcargs p)) = do
curPos .= p
vmapM resolveExpression funcargs >>= mainFunctionCall funcname
evaluateStatement (VariableAssignment (VarAss varname varexpr p)) = do
curPos .= p
varval <- resolveExpression varexpr
loadVariable varname varval
return []
evaluateStatement (ConditionalStatement (CondStatement conds p)) = do
curPos .= p
let checkCond [] = return []
checkCond ((e :!: stmts) : xs) = do
result <- pValue2Bool <$> resolveExpression e
if result
then evaluateStatementsVector stmts
else checkCond xs
checkCond (toList conds)
evaluateStatement (DefaultDeclaration (DefaultDec resType decls p)) = do
curPos .= p
let resolveDefaultValue (prm :!: v) = (prm :!:) <$> resolveExpression v
rdecls <- vmapM resolveDefaultValue decls >>= fromArgumentList
scp <- getScopeName
let newDefaults = ResDefaults resType scp rdecls p
addDefaults x = scopes . ix scp . scopeDefaults . at resType ?= x
mergedDefaults curdef = newDefaults & defValues .~ (rdecls <> (curdef ^. defValues))
preuse (scopes . ix scp . scopeDefaults . ix resType) >>= \case
Nothing -> addDefaults newDefaults
Just de -> if de ^. defSrcScope == scp
then throwPosError ("Defaults for resource" <+> ttext resType <+> "already declared at" <+> showPPos (de ^. defPos))
else addDefaults (mergedDefaults de)
return []
evaluateStatement (ResourceOverride (ResOver rt urn eargs p)) = do
curPos .= p
raassignements <- vmapM resolveArgument eargs >>= fromArgumentList
rn <- resolveExpressionString urn
scp <- getScopeName
curoverrides <- use (scopes . ix scp . scopeOverrides)
let rident = RIdentifier rt rn
withAssignements <- case curoverrides ^. at rident of
Just (ResRefOverride _ prevass prevpos) -> do
let cm = prevass `HM.intersection` raassignements
unless (fnull cm) (throwPosError ("The following parameters were already overriden at" <+> showPPos prevpos <+> ":" <+> containerComma cm))
return (prevass <> raassignements)
Nothing -> return raassignements
scopes . ix scp . scopeOverrides . at rident ?= ResRefOverride rident withAssignements p
return []
evaluateStatement (SHFunctionCall (SFC c p)) = curPos .= p >> evaluateHFC c
evaluateStatement r = throwError (PrettyError ("Do not know how to evaluate this statement:" </> pretty r))
loadVariable :: T.Text -> PValue -> InterpreterMonad ()
loadVariable varname varval = do
curcont <- getCurContainer
scp <- getScopeName
p <- use curPos
scopeDefined <- has (ix scp) <$> use scopes
variableDefined <- preuse (scopes . ix scp . scopeVariables . ix varname)
case (scopeDefined, variableDefined) of
(False, _) -> throwPosError ("Internal error: trying to save a variable in unknown scope" <+> ttext scp)
(_, Just (_ :!: pp :!: ctx)) -> isParent scp (curcont ^. cctype) >>= \case
True -> do
debug("The variable"
<+> pretty (UVariableReference varname)
<+> "had been overriden because of some arbitrary inheritance rule that was set up to emulate puppet behaviour. It was defined at"
<+> showPPos pp
)
scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype)
False -> throwPosError ("Variable" <+> pretty (UVariableReference varname) <+> "already defined at" <+> showPPos pp
</> "Context:" <+> pretty ctx
</> "Value:" <+> pretty varval
</> "Current scope:" <+> ttext scp
)
_ -> scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype)
loadParameters :: Foldable f => Container PValue -> f (Pair T.Text (S.Maybe Expression)) -> PPosition -> S.Maybe T.Text -> InterpreterMonad ()
loadParameters params classParams defaultPos wHiera = do
params' <- case wHiera of
S.Just classname -> do
let !classParamSet = HS.fromList (S.fst <$> classParams ^.. folded)
!definedParamSet = ikeys params
!unsetParams = classParamSet `HS.difference` definedParamSet
loadHieraParam curprms paramname = do
v <- runHiera (classname <> "::" <> paramname) Priority
case v of
S.Nothing -> return curprms
S.Just vl -> return (curprms & at paramname ?~ vl)
foldM loadHieraParam params (toList unsetParams)
S.Nothing -> return params
let !classParamSet = HS.fromList (map S.fst (toList classParams))
!mandatoryParamSet = HS.fromList (map S.fst (classParams ^.. folded . filtered (S.isNothing . S.snd)))
!definedParamSet = ikeys params'
!unsetParams = mandatoryParamSet `HS.difference` definedParamSet
!spuriousParams = definedParamSet `HS.difference` classParamSet
mclassdesc = S.maybe mempty ((\x -> mempty <+> "when including class" <+> x) . ttext) wHiera
unless (fnull unsetParams) $ throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ttext $ toList unsetParams) <> mclassdesc)
unless (fnull spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ttext) $ toList spuriousParams) <> mclassdesc)
let isDefault = not . flip HS.member definedParamSet . S.fst
mapM_ (uncurry loadVariable) (itoList params')
curPos .= defaultPos
forM_ (filter isDefault (toList classParams)) $ \(k :!: v) -> do
rv <- case v of
S.Nothing -> throwPosError "Internal error: invalid invariant at loadParameters"
S.Just e -> resolveExpression e
loadVariable k rv
data ScopeEnteringContext = SENormal
| SEChild !T.Text
| SEParent !T.Text
enterScope :: ScopeEnteringContext
-> CurContainerDesc
-> T.Text
-> PPosition
-> InterpreterMonad T.Text
enterScope secontext cont modulename p = do
let scopename = scopeName cont
curcaller <- case secontext of
SEParent l -> return (PString $ T.takeWhile (/=':') l)
_ -> resolveVariable "module_name"
scopeAlreadyDefined <- has (ix scopename) <$> use scopes
let isImported = case cont of
ContImported _ -> True
_ -> False
unless (scopeAlreadyDefined && isImported) $ do
when scopeAlreadyDefined (throwPosError ("Internal error: scope" <+> brackets (ttext scopename) <+> "already defined when loading scope for" <+> pretty cont))
scp <- getScopeName
basescope <- case secontext of
SEChild prt -> do
parentscope <- use (scopes . at prt)
when (isNothing parentscope) (throwPosError ("Internal error: could not find parent scope" <+> ttext prt))
let Just psc = parentscope
return (psc & scopeParent .~ S.Just prt)
_ -> do
curdefs <- use (scopes . ix scp . scopeDefaults)
return $ ScopeInformation mempty curdefs mempty (CurContainer cont mempty) mempty S.Nothing
scopes . at scopename ?= basescope
scopes . ix scopename . scopeVariables . at "caller_module_name" ?= (curcaller :!: p :!: cont)
scopes . ix "::" . scopeVariables . at "calling_module" ?= (curcaller :!: p :!: cont)
scopes . ix scopename . scopeVariables . at "module_name" ?= (PString modulename :!: p :!: cont)
debug ("enterScope, scopename=" <> ttext scopename <+> "caller_module_name=" <> pretty curcaller <+> "module_name=" <> ttext modulename)
return scopename
dropInitialColons :: T.Text -> T.Text
dropInitialColons t = fromMaybe t (T.stripPrefix "::" t)
expandDefine :: Resource -> InterpreterMonad [Resource]
expandDefine r = do
let deftype = dropInitialColons (r ^. rid . itype)
defname = r ^. rid . iname
modulename = getModulename (r ^. rid)
let curContType = ContDefine deftype defname (r ^. rpos)
p <- use curPos
let extr = do
(dstid, linkset) <- itoList (r ^. rrelations)
link <- toList linkset
return (LinkInformation (r ^. rid) dstid link p)
extraRelations <>= extr
void $ enterScope SENormal curContType modulename p
(spurious, dls') <- getstt TopDefine deftype
dls <- extractPrism _DefineDeclaration' "expandDefine" dls'
let isImported (ContImported _) = True
isImported _ = False
isImportedDefine <- isImported <$> getScope
case dls of
(DefineDec _ defineParams stmts cp) -> do
curPos .= r ^. rpos
curscp <- getScope
when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp ))
pushScope curContType
imods <- singleton (IsIgnoredModule modulename)
out <- if imods
then return mempty
else do
loadVariable "title" (PString defname)
loadVariable "name" (PString defname)
loadParameters (r ^. rattributes) defineParams cp S.Nothing
curPos .= cp
res <- evaluateStatementsVector stmts
finalize (spurious ++ res)
when isImportedDefine popScope
popScope
return out
loadClass :: T.Text
-> S.Maybe T.Text
-> Container PValue
-> ClassIncludeType
-> InterpreterMonad [Resource]
loadClass rclassname loadedfrom params cincludetype = do
let classname = dropInitialColons rclassname
ndn <- singleton GetNodeName
singleton (TraceEvent ('[' : T.unpack ndn ++ "] loadClass " ++ T.unpack classname))
p <- use curPos
use (loadedClasses . at classname) >>= \case
Just (prv :!: pp) -> do
when ( (cincludetype == IncludeResource)
|| (prv == IncludeResource)
)
(throwPosError ("Can't include class" <+> ttext classname <+> "twice when using the resource-like syntax (first occurence at" <+> showPPos pp <> ")"))
return []
Nothing -> do
loadedClasses . at classname ?= (cincludetype :!: p)
(spurious, cls') <- getstt TopClass classname
cls <- extractPrism _ClassDeclaration' "loadClass" cls'
case cls of
(ClassDecl _ classParams inh stmts cp) -> do
inhstmts <- case inh of
S.Nothing -> return []
S.Just ihname -> loadClass ihname (S.Just classname) mempty IncludeStandard
let !scopedesc = ContClass classname
modulename = getModulename (RIdentifier "class" classname)
secontext = case (inh, loadedfrom) of
(S.Just x,_) -> SEChild (dropInitialColons x)
(_,S.Just x) -> SEParent (dropInitialColons x)
_ -> SENormal
void $ enterScope secontext scopedesc modulename p
classresource <- if cincludetype == IncludeStandard
then do
scp <- use curScope
fqdn <- singleton GetNodeName
return [Resource (RIdentifier "class" classname) (HS.singleton classname) mempty mempty scp Normal mempty p fqdn]
else return []
pushScope scopedesc
imods <- singleton (IsIgnoredModule modulename)
out <- if imods
then return mempty
else do
loadVariable "title" (PString classname)
loadVariable "name" (PString classname)
loadParameters params classParams cp (S.Just classname)
curPos .= cp
res <- evaluateStatementsVector stmts
finalize (classresource ++ spurious ++ inhstmts ++ res)
popScope
return out
addRelationship :: LinkType -> PValue -> Resource -> InterpreterMonad Resource
addRelationship lt (PResourceReference dt dn) r = return (r & rrelations %~ insertLt)
where
insertLt = iinsertWith (<>) (RIdentifier dt dn) (HS.singleton lt)
addRelationship lt (PArray vals) r = foldlM (flip (addRelationship lt)) r vals
addRelationship _ PUndef r = return r
addRelationship _ notrr _ = throwPosError ("Expected a resource reference, not:" <+> pretty notrr)
addTagResource :: Resource -> T.Text -> Resource
addTagResource r rv = r & rtags . contains rv .~ True
addAttribute :: OverrideType -> T.Text -> Resource -> PValue -> InterpreterMonad Resource
addAttribute _ "alias" r v = (\rv -> r & ralias . contains rv .~ True) <$> resolvePValueString v
addAttribute _ "audit" r _ = use curPos >>= \p -> warn ("Metaparameter audit ignored at" <+> showPPos p) >> return r
addAttribute _ "noop" r _ = use curPos >>= \p -> warn ("Metaparameter noop ignored at" <+> showPPos p) >> return r
addAttribute _ "loglevel" r _ = use curPos >>= \p -> warn ("Metaparameter loglevel ignored at" <+> showPPos p) >> return r
addAttribute _ "schedule" r _ = use curPos >>= \p -> warn ("Metaparameter schedule ignored at" <+> showPPos p) >> return r
addAttribute _ "stage" r _ = use curPos >>= \p -> warn ("Metaparameter stage ignored at" <+> showPPos p) >> return r
addAttribute _ "tag" r (PArray v) = foldM (\cr cv -> addTagResource cr <$> resolvePValueString cv) r (toList v)
addAttribute _ "tag" r v = addTagResource r <$> resolvePValueString v
addAttribute _ "before" r d = addRelationship RBefore d r
addAttribute _ "notify" r d = addRelationship RNotify d r
addAttribute _ "require" r d = addRelationship RRequire d r
addAttribute _ "subscribe" r d = addRelationship RSubscribe d r
addAttribute b t r v = case (r ^. rattributes . at t, b) of
(_, Replace) -> return (r & rattributes . at t ?~ v)
(Nothing, _) -> return (r & rattributes . at t ?~ v)
(_, CantReplace) -> return r
_ -> do
curscope <- getScopeName
i <- isParent curscope (rcurcontainer r)
if i
then return (r & rattributes . at t ?~ v)
else throwPosError ("Attribute" <+> dullmagenta (ttext t) <+> "defined multiple times for" <+> pretty (r ^. rid) <+> showPPos (r ^. rpos))
registerResource :: T.Text -> T.Text -> Container PValue -> Virtuality -> PPosition -> InterpreterMonad [Resource]
registerResource "class" _ _ Virtual p = curPos .= p >> throwPosError "Cannot declare a virtual class (or perhaps you can, but I do not know what this means)"
registerResource "class" _ _ Exported p = curPos .= p >> throwPosError "Cannot declare an exported class (or perhaps you can, but I do not know what this means)"
registerResource rt rn arg vrt p = do
curPos .= p
CurContainer cnt tgs <- getCurContainer
let !defaulttags = HS.fromList (rt : classtags) <> tgs
allsegs x = x : T.splitOn "::" x
(!classtags, !defaultLink) = getClassTags cnt
getClassTags (ContClass cn ) = (allsegs cn,RIdentifier "class" cn)
getClassTags (ContDefine dt dn _) = (allsegs dt,RIdentifier dt dn)
getClassTags (ContRoot ) = ([],RIdentifier "class" "::")
getClassTags (ContImported _ ) = ([],RIdentifier "class" "::")
getClassTags (ContImport _ _ ) = ([],RIdentifier "class" "::")
defaultRelation = HM.singleton defaultLink (HS.singleton RRequire)
allScope <- use curScope
fqdn <- singleton GetNodeName
let baseresource = Resource (RIdentifier rt rn) (HS.singleton rn) mempty defaultRelation allScope vrt defaulttags p fqdn
r <- ifoldlM (addAttribute CantOverride) baseresource arg
let resid = RIdentifier rt rn
case rt of
"class" -> do
definedResources . at resid ?= r
let attrs = r ^. rattributes
fmap (r:) $ loadClass rn S.Nothing attrs $ if HM.null attrs
then IncludeStandard
else IncludeResource
_ ->
use (definedResources . at resid) >>= \case
Just otheres -> throwPosError ("Resource" <+> pretty resid <+> "already defined:" </>
pretty r </>
pretty otheres
)
Nothing -> do
definedResources . at resid ?= r
return [r]
logWithModifier :: Priority -> (Doc -> Doc) -> [PValue] -> InterpreterMonad [Resource]
logWithModifier prio m [t] = do
p <- use curPos
rt <- resolvePValueString t
logWriter prio (m (ttext rt) <+> showPPos p)
return []
logWithModifier _ _ _ = throwPosError "This function takes a single argument"
mainFunctionCall :: T.Text -> [PValue] -> InterpreterMonad [Resource]
mainFunctionCall "showscope" _ = use curScope >>= warn . pretty >> return []
mainFunctionCall "alert" a = logWithModifier ALERT red a
mainFunctionCall "crit" a = logWithModifier CRITICAL red a
mainFunctionCall "debug" a = logWithModifier DEBUG dullwhite a
mainFunctionCall "emerg" a = logWithModifier EMERGENCY red a
mainFunctionCall "err" a = logWithModifier ERROR dullred a
mainFunctionCall "info" a = logWithModifier INFO green a
mainFunctionCall "notice" a = logWithModifier NOTICE white a
mainFunctionCall "warning" a = logWithModifier WARNING dullyellow a
mainFunctionCall "include" includes = concat <$> mapM doInclude includes
where doInclude e = do
classname <- resolvePValueString e
loadClass classname S.Nothing mempty IncludeStandard
mainFunctionCall "create_resources" [rtype, hs] = mainFunctionCall "create_resources" [rtype, hs, PHash mempty]
mainFunctionCall "create_resources" [PString rtype, PHash hs, PHash defs] = do
p <- use curPos
let genRes rname (PHash rargs) = registerResource rtype rname (rargs <> defs) Normal p
genRes rname x = throwPosError ("create_resource(): the value corresponding to key" <+> ttext rname <+> "should be a hash, not" <+> pretty x)
concat . HM.elems <$> itraverse genRes hs
mainFunctionCall "create_resources" args = throwPosError ("create_resource(): expects between two and three arguments, of type [string,hash,hash], and not:" <+> pretty args)
mainFunctionCall "realize" args = do
p <- use curPos
let realiz (PResourceReference rt rn) = resMod %= (ResourceModifier rt ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) return p : )
realiz x = throwPosError ("realize(): all arguments must be resource references, not" <+> pretty x)
mapM_ realiz args
return []
mainFunctionCall "tag" args = do
scp <- getScopeName
let addTag x = scopes . ix scp . scopeExtraTags . contains x .= True
mapM_ (resolvePValueString >=> addTag) args
return []
mainFunctionCall "fail" [x] = ("fail:" <+>) . dullred . ttext <$> resolvePValueString x >>= throwPosError
mainFunctionCall "fail" _ = throwPosError "fail(): This function takes a single argument"
mainFunctionCall "hiera_include" [x] = do
ndname <- resolvePValueString x
classes <- toListOf (traverse . _PArray . traverse) <$> runHiera ndname ArrayMerge
p <- use curPos
curPos . _1 . lSourceName <>= " [hiera_include call]"
o <- mainFunctionCall "include" classes
curPos .= p
return o
mainFunctionCall "hiera_include" _ = throwPosError "hiera_include(): This function takes a single argument"
mainFunctionCall fname args = do
p <- use curPos
let representation = MainFunctionCall (MFC fname mempty p)
rs <- singleton (ExternalFunction fname args)
unless (rs == PUndef) $ throwPosError ("This function call should return" <+> pretty PUndef <+> "and not" <+> pretty rs </> pretty representation)
return []
evaluateHFC :: HFunctionCall -> InterpreterMonad [Resource]
evaluateHFC hf = do
varassocs <- hfGenerateAssociations hf
let runblock :: [(T.Text, PValue)] -> InterpreterMonad [Resource]
runblock assocs = do
saved <- hfSetvars assocs
res <- evaluateStatementsVector (hf ^. hfstatements)
hfRestorevars saved
return res
results <- mapM runblock varassocs
return (concat results)