{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
module Puppet.Interpreter
( interpretCatalog
, computeCatalog
, evaluateStatement
, initialState
, extractScope
, containerModName
, askFact
, module Puppet.Interpreter.Types
, module Puppet.Interpreter.Resolve
, module Puppet.Interpreter.IO
) where
import XPrelude.Extra
import XPrelude.PP
import Control.Monad.Operational hiding (view)
import qualified Data.Char as Char
import qualified Data.Graph as Graph
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set
import qualified Data.List as List
import qualified Data.Maybe.Strict as S
import Data.Semigroup (Max (..))
import qualified Data.Text as Text
import qualified Data.Tree as Tree
import qualified Data.Vector as V
import qualified System.Log.Logger as Log
import Facter
import Hiera.Server
import Puppet.Interpreter.Helpers
import Puppet.Interpreter.IO
import Puppet.Interpreter.PrettyPrinter ()
import Puppet.Interpreter.Resolve
import Puppet.Interpreter.Types
import Puppet.Parser
interpretCatalog :: Monad m
=> InterpreterReader m
-> NodeName
-> Facts
-> Container Text
-> m (Pair (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Log.Priority Doc])
interpretCatalog r node facts settings = do
(output, _, warnings) <- interpretMonad r (initialState facts settings) (computeCatalog node)
pure (output :!: warnings)
isParent :: Text -> CurContainerDesc -> InterpreterMonad Bool
isParent cur (ContClass possibleparent) =
preuse (scopes . ix cur . scopeParent) >>= \case
Nothing -> throwPosError ("Internal error: could not find scope" <+> ppline cur <+> "possible parent" <+> ppline possibleparent)
Just S.Nothing -> pure False
Just (S.Just p) -> if p == possibleparent
then pure True
else isParent p (ContClass possibleparent)
isParent _ _ = pure False
finalize :: [Resource] -> InterpreterMonad [Resource]
finalize rx = do
scp <- getScopeName
resdefaults <- use (scopes . ix scp . scopeResDefaults)
let getOver = use (scopes . ix scp . scopeOverrides)
addResDefaults r = ifoldlM (addAttribute CantReplace) r resdefval
where resdefval = resdefaults ^. ix (r ^. rid . itype) . resDefValues
addOverrides r = getOver >>= foldlM addOverrides' r . view (at (r ^. rid))
addOverrides' r (ResRefOverride _ prms p) = do
scopes . ix scp . scopeOverrides . at (r ^. rid) .= Nothing
let forb msg = throwPosError ("Override of parameters ("
<> list (map (ppline . fst) $ itoList prms)
<> ") of the following resource is forbidden in the current context:"
</> pretty r
<+> showPPos p
</> ":"
<+> msg)
s <- getScope
overrideType <- case r ^. rscope of
[] -> forb "Could not find the current resource context"
(x:_) -> if x == s
then pure CantOverride
else isParent (scopeName s) x >>= \i ->
if i || (r ^. rid . itype == "class")
then pure Replace
else forb "Can't override something that was not defined in the parent."
ifoldlM (addAttribute overrideType) r prms
withDefaults <- mapM (addOverrides >=> addResDefaults) rx
let keepforlater (ResRefOverride resid resprms ropos) = resModifiers %= (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
getOver >>= mapM_ keepforlater
let expandableDefine r = do
n <- isNativeType (r ^. rid . itype)
if n || r ^. rvirtuality /= Normal
then pure [r]
else expandDefine r
concat <$> mapM expandableDefine withDefaults
where
expandDefine :: Resource -> InterpreterMonad [Resource]
expandDefine r =
let modulename = getModulename (r ^. rid)
in isIgnoredModule modulename >>= \case
True -> pure mempty
False -> do
let deftype = dropInitialColons (r ^. rid . itype)
defname = r ^. rid . iname
curContType = ContDefine deftype defname (r ^. rpos)
p <- use curPos
let extr = do
(dstid, linkset) <- itoList (r ^. rrelations)
linktype <- toList linkset
pure (LinkInformation (r ^. rid) dstid linktype p)
extraRelations <>= extr
void $ enterScope SENormal curContType modulename p
(spurious, stmt) <- interpretTopLevel TopDefine deftype
DefineDecl _ defineParams stmts cp <- extractPrism "expandDefine" _DefineDecl stmt
let isImported (ContImported _) = True
isImported _ = False
isImportedDefine <- isImported <$> getScope
curPos .= r ^. rpos
curscp <- getScope
when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp ))
pushScope curContType
loadVariable "title" (PString defname)
loadVariable "name" (PString defname)
loadParameters (r ^. rattributes) defineParams cp Nothing
curPos .= cp
res <- evaluateStatementsFoldable stmts
out <- finalize (spurious <> res)
when isImportedDefine popScope
popScope
pure out
interpretTopLevel :: TopLevelType -> Text -> InterpreterMonad ([Resource], Statement)
interpretTopLevel toptype topname =
use (nestedDeclarations . at (toptype, topname)) >>= \case
Just x -> pure ([], x)
Nothing -> singleton (GetStatement toptype topname) >>= evalTopLevel
where
evalTopLevel :: Statement -> InterpreterMonad ([Resource], Statement)
evalTopLevel (TopContainer tops s) = do
pushScope ContRoot
r <- mapM evaluateStatement tops >>= finalize . concat
(nr, ns) <- evalTopLevel s
popScope
pure (r <> nr, ns)
evalTopLevel x = pure ([], x)
computeCatalog :: NodeName -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource])
computeCatalog nodename = do
(topres, stmt) <- interpretTopLevel TopNode nodename
nd <- extractPrism "computeCatalog" _NodeDecl stmt
let finalStep [] = pure []
finalStep allres = do
(realized :!: modified) <- realize allres
refinalized <- finalize (toList modified) >>= finalStep
let res = foldl' (\curm e -> curm & at (e ^. rid) ?~ e) realized refinalized
pure (toList res)
mainstage = Resource (RIdentifier "stage" "main") mempty mempty mempty [ContRoot] Normal mempty (initialPPos mempty) nodename
evaluateNode :: NodeDecl -> InterpreterMonad [Resource]
evaluateNode (NodeDecl _ sx inheritnode p) = do
curPos .= p
pushScope ContRoot
unless (S.isNothing inheritnode) $ throwPosError "Node inheritance is not handled. It is deprecated since puppet v4"
mapM evaluateStatement sx >>= finalize . concat
noderes <- evaluateNode nd >>= finalStep . (++ (mainstage : topres))
let (real :!: exported) = foldl' classify (mempty :!: mempty) noderes
classify :: Pair (HashMap RIdentifier Resource) (HashMap RIdentifier Resource)
-> Resource
-> Pair (HashMap RIdentifier Resource) (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 <- Map.fromList . map (\r -> (r ^. rid, r)) <$> mapM validateNativeType (Map.elems real)
withResourceDependentRelations <- traverse getResourceDependentRelations verified
edgemap <- makeEdgeMap withResourceDependentRelations
definedRes <- use definedResources
pure (withResourceDependentRelations, edgemap, exported, Map.elems definedRes)
getResourceDependentRelations :: Resource -> InterpreterMonad Resource
getResourceDependentRelations res =
extract
$ case res ^. rid . itype of
"file" -> [depOn "user" "owner", depOn "group" "group"]
"cron" -> [depOn "user" "user"]
"exec" -> [depOn "user" "user", depOn "group" "group"]
_ -> []
where
extract actions = do
newrelations <- fmap (foldl' (Map.unionWith (<>)) (res ^. rrelations)) (sequence actions)
pure (res & rrelations .~ newrelations)
depOn :: Text -> Text -> InterpreterMonad (HashMap RIdentifier (HashSet LinkType))
depOn resType attributeName =
case res ^? rattributes . ix attributeName of
Just (PString usr) -> do
let targetResourceId = RIdentifier resType usr
existing <- has (ix targetResourceId) <$> use definedResources
pure $
if existing
then Map.singleton targetResourceId (Set.singleton RRequire)
else Map.empty
_ -> pure Map.empty
makeEdgeMap :: FinalCatalog -> InterpreterMonad EdgeMap
makeEdgeMap ct = do
defs' <- fmap (view rpos) <$> use definedResources
clss' <- use loadedClasses
let defs = defs' <> classes' <> aliases' <> names'
names' = (view rpos) <$> ct
aliases' = ifromList $ do
r <- ct ^.. traversed :: [Resource]
extraAliases <- r ^.. ralias . folded . filtered (/= r ^. rid . iname) :: [Text]
pure (r ^. rid & iname .~ extraAliases, r ^. rpos)
classes' = ifromList $ do
(cn, _ :!: cp) <- itoList clss'
pure (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 :: [(RIdentifier, [LinkInformation])]
resresources = do
(rawdst, lts) <- itoList (r ^. rrelations)
lt <- toList lts
let (nsrc, ndst, nlt) = reorderlink (resid, rawdst, lt)
pure (nsrc, [LinkInformation nsrc ndst nlt respos])
step1 :: HashMap RIdentifier [LinkInformation]
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
is_ignored <- isIgnoredModule modulename
unless (has (ix r) defs || is_ignored) (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))
pure d
ds <- mapM genlnk lifs
pure (ri, ri, ds)
edgeList <- mapM checkResDef (itoList step2)
let (graph, gresolver) = Graph.graphFromEdges' edgeList
let sccs = filter ((>1) . length . Tree.flatten) (Graph.scc graph)
unless (null sccs) $ do
let trees = vcat (map showtree sccs)
showtree = indent 2 . vcat . map (mkp . gresolver) . Tree.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
pure 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 -> pure (r & rvirtuality .~ Normal))
RealizeCollected -> (vcheck (`elem` [Exported, ExportedRealized]), \r -> pure (r & rvirtuality .~ ExportedRealized))
DontRealize -> (vcheck (`elem` [Normal, ExportedRealized]), pure)
fmod r = (r ^. rid . itype == rmod ^. rmResType) && checkSearchExpression (rmod ^. rmSearch) r && isGoodvirtuality r
mutation = alterVirtuality >=> rmod ^. rmMutation
applyModification :: Pair FinalCatalog FinalCatalog -> Resource -> InterpreterMonad (Pair FinalCatalog FinalCatalog)
applyModification (cma :!: cmo) r = do
nr <- mutation r
let i m = m & at (nr ^. rid) ?~ nr
pure $ if nr /= r
then i cma :!: i cmo
else cma :!: cmo
result <- foldM applyModification (curmap :!: modified) filtrd
when (rmod ^. rmModifierType == ModifierMustMatch && null filtrd) (throwError (PrettyError ("Could not apply this resource override :" <+> pretty rmod <> ",no matching resource was found.")))
pure 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 resModifiers >>= foldM mutate (rma :!: mempty) . reverse . List.nubBy equalModifier
resModifiers .= []
pure result
fromAttributeDecls :: Vector AttributeDecl -> InterpreterMonad (Container PValue)
fromAttributeDecls =
foldM resolve mempty
where
resolve acc adcl =
case adcl of
AttributeWildcard v -> do
pv <- resolveExpression v
case pv of
PHash h -> foldM (\curacc (attrname, attrvalue) -> go curacc attrname attrvalue) acc (itoList h)
_ -> throwPosError ("A hash was expected, not" <+> pretty pv)
AttributeDecl k _ v -> resolveExpression v >>= go acc k
go acc k pv =
case acc ^. at k of
Just _ -> throwPosError ("Parameter" <+> dullyellow (ppline k) <+> "already defined!")
Nothing -> pure (acc & at k ?~ pv)
saveCaptureVariables :: InterpreterMonad (HashMap Text (Pair (Pair PValue PPosition) CurContainerDesc))
saveCaptureVariables = do
scp <- getScopeName
vars <- use (scopes . ix scp . scopeVariables)
pure $ Map.filterWithKey (\k _ -> Text.all Char.isDigit k) vars
restoreCaptureVariables :: HashMap Text (Pair (Pair PValue PPosition) CurContainerDesc) -> InterpreterMonad ()
restoreCaptureVariables vars = do
scp <- getScopeName
scopes . ix scp . scopeVariables %= Map.union vars . Map.filterWithKey (\k _ -> not (Text.all Char.isDigit k))
evaluateStatement :: Statement -> InterpreterMonad [Resource]
evaluateStatement r@(ClassDeclaration (ClassDecl cname _ _ _ _)) =
if "::" `Text.isInfixOf` cname
then nestedDeclarations . at (TopClass, cname) ?= r >> pure []
else do
scp <- getScopeName
let rcname = if scp == "::"
then cname
else scp <> "::" <> cname
nestedDeclarations . at (TopClass, rcname) ?= r
pure []
evaluateStatement r@(DefineDeclaration (DefineDecl dname _ _ _)) =
if "::" `Text.isInfixOf` dname
then nestedDeclarations . at (TopDefine, dname) ?= r >> pure []
else do
scp <- getScopeName
if scp == "::"
then nestedDeclarations . at (TopDefine, dname) ?= r >> pure []
else nestedDeclarations . at (TopDefine, scp <> "::" <> dname) ?= r >> pure []
evaluateStatement r@(ResourceCollectionDeclaration (ResCollDecl ct rtype searchexp mods p)) = do
curPos .= p
unless (null mods || ct == Collector)
(throwPosError ("It doesn't seem possible to amend attributes with an exported resource collector:" </> pretty r))
when (rtype == "class") (throwPosError "Classes cannot be collected")
rsearch <- resolveSearchExpression searchexp
let et = case ct of
Collector -> RealizeVirtual
ExportedCollector -> RealizeCollected
resModifiers %= (ResourceModifier rtype ModifierCollector et rsearch (\r' -> foldM modifyCollectedAttribute r' mods) p : )
if et == RealizeCollected
then do
let q = searchExpressionToPuppetDB rtype rsearch
fqdn <- getNodeName
res <- toListOf (folded
. filtered ( hasn't (rnode . only fqdn) )
. to (rvirtuality .~ Normal)
) <$> singleton (PDBGetResources q)
scpdesc <- ContImported <$> getScope
void $ enterScope SENormal scpdesc "importing" p
pushScope scpdesc
o <- finalize res
popScope
pure o
else pure []
evaluateStatement (DependencyDeclaration (DepDecl (t1 :!: n1) (t2 :!: n2) lt p)) = do
curPos .= p
rn1 <- map (fixResourceName t1) <$> resolveExpressionStrings n1
rn2 <- map (fixResourceName t2) <$> resolveExpressionStrings n2
extraRelations <>= [ LinkInformation (normalizeRIdentifier t1 an1) (normalizeRIdentifier t2 an2) lt p | an1 <- rn1, an2 <- rn2 ]
pure []
evaluateStatement (ResourceDeclaration (ResDecl t ern eargs virt p)) = do
curPos .= p
resnames <- resolveExpressionStrings ern
args <- fromAttributeDecls eargs
concat <$> mapM (\n -> registerResource t n args virt p) resnames
evaluateStatement (MainFunctionDeclaration (MainFuncDecl funcname funcargs p)) = do
curPos .= p
mapM resolveExpression (toList funcargs) >>= mainFunctionCall funcname
evaluateStatement (VarAssignmentDeclaration (VarAssignDecl mt varnames varexpr p)) = do
curPos .= p
varval <- resolveExpression varexpr
mapM_ (resolveDataType >=> (`checkMatch` varval)) mt
mapM_ (flip loadVariable varval) varnames
pure []
evaluateStatement (ConditionalDeclaration (ConditionalDecl conds p)) = do
curPos .= p
let checkCond [] = pure []
checkCond ((e :!: stmts) : xs) = do
sv <- saveCaptureVariables
result <- pValue2Bool <$> resolveExpression e
if result
then evaluateStatementsFoldable stmts <* restoreCaptureVariables sv
else restoreCaptureVariables sv *> checkCond xs
checkCond (toList conds)
evaluateStatement (ResourceDefaultDeclaration (ResDefaultDecl rtype decls p)) = do
curPos .= p
rdecls <- fromAttributeDecls decls
scp <- getScopeName
preuse (scopes . ix scp) >>= maybe (throwPosError ("INTERNAL ERROR in evaluateStatement ResourceDefaultDeclaration: scope wasn't created - " <> ppline scp)) (const (pure ()))
let newDefaults = ResDefaults rtype scp rdecls p
addDefaults x = scopes . ix scp . scopeResDefaults . at rtype ?= x
mergedDefaults curdef = newDefaults & resDefValues .~ (rdecls <> (curdef ^. resDefValues))
preuse (scopes . ix scp . scopeResDefaults . ix rtype) >>= \case
Nothing -> addDefaults newDefaults
Just d -> if d ^. resDefSrcScope == scp
then throwPosError ("Defaults for resource" <+> ppline rtype <+> "already declared at" <+> showPPos (d ^. resDefPos))
else addDefaults (mergedDefaults d)
pure []
evaluateStatement (ResourceOverrideDeclaration (ResOverrideDecl t urn eargs p)) = do
curPos .= p
raassignements <- fromAttributeDecls eargs
rn <- resolveExpressionString urn
scp <- getScopeName
curoverrides <- use (scopes . ix scp . scopeOverrides)
let rident = normalizeRIdentifier t rn
withAssignements <- case curoverrides ^. at rident of
Just (ResRefOverride _ prevass prevpos) -> do
let cm = prevass `Map.intersection` raassignements
unless (null cm)
(throwPosError ("The following parameters were already overriden at" <+> showPPos prevpos <+> ":" <+> pretty cm))
pure (prevass <> raassignements)
Nothing -> pure raassignements
scopes . ix scp . scopeOverrides . at rident ?= ResRefOverride rident withAssignements p
pure []
evaluateStatement (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl c p)) =
curPos .= p >> evaluateHFC c
where
evaluateHFC :: HOLambdaCall -> InterpreterMonad [Resource]
evaluateHFC hf =
let runblock :: [(Text, PValue)] -> InterpreterMonad [Resource]
runblock assocs = do
saved <- hfSetvars assocs
res <- evaluateStatementsFoldable (hf ^. hoLambdaStatements)
hfRestorevars saved
pure res
in case hf ^. hoLambdaFunc of
LambdaFunc "each" -> do
varassocs <- hfGenerateAssociations hf
concat <$> mapM runblock varassocs
LambdaFunc "assert_type" ->
case (hf ^.. hoLambdaExpr . folded, hf ^.. hoLambdaParams . folded) of
( [utp, uval], [a, b] ) -> do
let typecheck_lambda (LambdaParam ltype lvar)
= case ltype of
Nothing -> pure lvar
Just udt -> do
dt <- resolveDataType udt
if dt == DTType
then pure lvar
else throwPosError ("The lambda value can only be a type in assert_type, not" <+> pretty dt)
mtp <- resolveExpression utp
val <- resolveExpression uval
varexpected <- typecheck_lambda a
varactual <- typecheck_lambda b
case mtp of
PType expectedType ->
if datatypeMatch expectedType val
then pure []
else runblock [(varexpected, PType expectedType), (varactual, PType (typeOf val))]
_ -> throwPosError ("The first argument to assert_type should be a data type, not" <+> pretty mtp)
_ -> throwPosError "assert_types requires two parameters, and two lambda parameters"
LambdaFunc "with" -> do
let expressions = hf ^. hoLambdaExpr
parameters = hf ^. hoLambdaParams
unless (V.length expressions == V.length parameters)
(throwPosError ("Mismatched number of arguments and lambda parameters in" <> pretty hf))
assocs <- forM (V.zip expressions parameters) $ \(uval, LambdaParam mt name) -> do
val <- resolveExpression uval
forM_ mt $ \ut -> do
t <- resolveDataType ut
checkMatch t val
pure (name, val)
runblock (V.toList assocs)
fn -> throwPosError ("This lambda function is unknown:" </> pretty fn)
evaluateStatement r = throwError (PrettyError ("Do not know how to evaluate this statement:" </> pretty r))
loadVariable :: 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" <+> ppline 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:" <+> ppline scp
)
_ -> scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype)
loadParameters :: Container PValue
-> Parameters
-> PPosition
-> Maybe Text
-> InterpreterMonad ()
loadParameters attrs classParams defaultPos classname = do
p <- use curPos
curPos .= defaultPos
let class_params = Set.fromList (classParams ^.. folded . _1 . _1)
spurious_params = ikeys attrs `Set.difference` class_params
pp_classdesc = maybe mempty (\x -> " when including class" <+> ppline x) classname
check_undef :: S.Maybe UDataType -> Maybe PValue -> ExceptT (Max Bool) InterpreterMonad PValue
check_undef (S.Just (UDTOptional _)) Nothing = throwE (Max True)
check_undef _ Nothing = throwE (Max False)
check_undef _ (Just PUndef) = throwE (Max True)
check_undef _ (Just v) = pure v
check_hiera :: Text -> S.Maybe UDataType -> ExceptT (Max Bool) InterpreterMonad PValue
check_hiera k dt = case classname of
Nothing -> throwE (Max False)
Just n -> lift (runHiera (n <> "::" <> k) QFirst) >>= check_undef dt
check_def :: Text -> ExceptT (Max Bool) InterpreterMonad PValue
check_def k = check_undef S.Nothing (attrs ^. at k)
check_default :: S.Maybe Expression -> ExceptT (Max Bool) InterpreterMonad PValue
check_default S.Nothing = throwE (Max False)
check_default (S.Just expr) = lift (resolveExpression expr)
unless (null spurious_params)
$ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ppline) $ toList spurious_params) <> pp_classdesc)
unset_params <- fmap concat $ for classParams $ \(varname :!: vartype :!: valexpr) ->
runExceptT (check_def varname <|> check_hiera varname vartype <|> check_default valexpr) >>= \case
Right val -> do
forM_ vartype $ \utype -> do
dt <- resolveDataType utype
unless (datatypeMatch dt val)
$ throwPosError ("Expected type" <+> pretty dt <+> "for parameter" <+> ppline varname <+> "but its value was:" <+> pretty val)
loadVariable varname val >> pure []
Left (Max True) -> loadVariable varname PUndef >> pure []
Left (Max False) -> pure [varname]
curPos .= p
unless (null unset_params)
$ throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ppline $ toList unset_params) <> pp_classdesc)
enterScope :: ScopeEnteringContext
-> CurContainerDesc
-> Text
-> PPosition
-> InterpreterMonad Text
enterScope secontext cont modulename p = do
let scopename = scopeName cont
curcaller <- case secontext of
SEParent l -> pure (PString $ Text.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 (ppline 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" <+> ppline prt))
let Just psc = parentscope
pure (psc & scopeParent .~ S.Just prt)
_ -> do
curdefs <- use (scopes . ix scp . scopeResDefaults)
pure $ 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=" <> ppline scopename <+> "caller_module_name=" <> pretty curcaller <+> "module_name=" <> ppline modulename)
pure scopename
loadClass :: Text
-> S.Maybe Text
-> Container PValue
-> ClassIncludeType
-> InterpreterMonad [Resource]
loadClass name loadedfrom attrs incltype = do
let name' = dropInitialColons name
nodename <- getNodeName
singleton (TraceEvent ('[' : toS nodename <> "] loadClass " <> toS name'))
pos <- use curPos
preuse (loadedClasses . ix name' . _2) >>= \case
Just pp -> case incltype of
ClassIncludeLike -> pure []
_ -> throwPosError
$ "Can't include class" <+> ppline name' <+> "twice when using the resource-like syntax (first occurence at"
<+> showPPos pp <> ")"
Nothing -> do
loadedClasses . at name' ?= (incltype :!: pos)
let modulename = getModulename (RIdentifier "class" name')
is_ignored <- isIgnoredModule modulename
if is_ignored
then pure mempty
else do
(spurious, stmt) <- interpretTopLevel TopClass name'
ClassDecl _ params inh stmts curpos <- extractPrism "loadClass" _ClassDecl stmt
inhstmts <- case inh of
S.Nothing -> pure []
S.Just ihname -> loadClass ihname (S.Just name') mempty ClassIncludeLike
let !scopedesc = ContClass name'
secontext = case (inh, loadedfrom) of
(S.Just x,_) -> SEChild (dropInitialColons x)
(_,S.Just x) -> SEParent (dropInitialColons x)
_ -> SENormal
void $ enterScope secontext scopedesc modulename pos
classresource <- if incltype == ClassIncludeLike
then do
scp <- use curScope
fqdn <- getNodeName
pure [Resource (RIdentifier "class" name') (Set.singleton name') mempty mempty scp Normal mempty pos fqdn]
else pure []
pushScope scopedesc
loadVariable "title" (PString name')
loadVariable "name" (PString name')
loadParameters attrs params curpos (Just name')
curPos .= curpos
res <- evaluateStatementsFoldable stmts
out <- finalize (classresource <> spurious <> inhstmts <> res)
popScope
pure out
addRelationship :: LinkType -> PValue -> Resource -> InterpreterMonad Resource
addRelationship lt (PResourceReference dt dn) r = pure (r & rrelations %~ insertLt)
where
insertLt = iinsertWith (<>) (normalizeRIdentifier dt dn) (Set.singleton lt)
addRelationship lt (PArray xs) r = foldlM (flip (addRelationship lt)) r xs
addRelationship _ PUndef r = pure r
addRelationship _ s _ = throwPosError ("Expected a resource reference, not:" <+> pretty s)
addTagResource :: Resource -> Text -> Resource
addTagResource r rv = r & rtags . contains rv .~ True
addAttribute :: OverrideType -> 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) >> pure r
addAttribute _ "loglevel" r _ = use curPos >>= \p -> warn ("Metaparameter loglevel ignored at" <+> showPPos p) >> pure r
addAttribute _ "schedule" r _ = use curPos >>= \p -> warn ("Metaparameter schedule ignored at" <+> showPPos p) >> pure r
addAttribute _ "stage" r _ = use curPos >>= \p -> warn ("Metaparameter stage ignored at" <+> showPPos p) >> pure 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 = go t r v
where
go = case b of
CantOverride -> setAttribute
Replace -> overrideAttribute
CantReplace -> defaultAttribute
AppendAttribute -> appendAttribute
setAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource
setAttribute attributename res value =
case res ^. rattributes . at attributename of
Nothing -> pure (res & rattributes . at attributename ?~ value)
Just curval -> do
curscope <- getScopeName
i <- isParent curscope (rcurcontainer res)
if i
then pure (res & rattributes . at attributename ?~ value)
else do
let errmsg = "Attribute" <+> dullmagenta (ppline attributename) <+> "defined multiple times for" <+> pretty res
if curval == value
then checkStrict errmsg errmsg
else throwPosError errmsg
pure res
overrideAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource
overrideAttribute attributename res value = pure (res & rattributes . at attributename ?~ value)
appendAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource
appendAttribute attributename res value = do
nvalue <- case (res ^. rattributes . at attributename, value) of
(Nothing, _) -> pure value
(Just (PArray a), PArray b) -> pure (PArray (a <> b))
(Just (PArray a), b) -> pure (PArray (V.snoc a b))
(Just a, PArray b) -> pure (PArray (V.cons a b))
(Just a, b) -> pure (PArray (V.fromList [a,b]))
pure (res & rattributes . at attributename ?~ nvalue)
defaultAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource
defaultAttribute attributename res value =
pure $ case res ^. rattributes . at attributename of
Nothing -> res & rattributes . at attributename ?~ value
Just _ -> res
modifyCollectedAttribute :: Resource -> AttributeDecl -> InterpreterMonad Resource
modifyCollectedAttribute res attrdecl =
case attrdecl of
AttributeDecl attributename arrowop expr -> do
value <- resolveExpression expr
let optype = case arrowop of
AppendArrow -> AppendAttribute
AssignArrow -> Replace
addAttribute optype attributename res value
AttributeWildcard expr -> do
resolved <- resolveExpression expr
case resolved of
PHash hash ->
foldM (\curres (attrname, attrval) -> addAttribute Replace attrname curres attrval) res (itoList hash)
_ -> throwPosError ("A hash was expected, not" <+> pretty resolved)
registerResource :: Text -> 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 t rn arg vrt p = do
curPos .= p
CurContainer cnt tgs <- getCurContainer
let !defaulttags = {-# SCC "rrGetTags" #-} Set.fromList (t : classtags) <> tgs
allsegs x = x : Text.splitOn "::" x
(!classtags, !defaultLink) = getClassTags cnt
getClassTags (ContClass cn ) = (allsegs cn,RIdentifier "class" cn)
getClassTags (ContDefine dt dn _) = (allsegs dt,normalizeRIdentifier dt dn)
getClassTags ContRoot = ([],RIdentifier "class" "::")
getClassTags (ContImported _ ) = ([],RIdentifier "class" "::")
getClassTags (ContImport _ _ ) = ([],RIdentifier "class" "::")
defaultRelation = Map.singleton defaultLink (Set.singleton RRequire)
allScope <- use curScope
fqdn <- getNodeName
let baseresource = Resource (normalizeRIdentifier t rn) (Set.singleton rn) mempty defaultRelation allScope vrt defaulttags p fqdn
r <- ifoldlM (addAttribute CantOverride) baseresource arg
let resid = normalizeRIdentifier t rn
case t of
"class" -> {-# SCC "rrClass" #-} do
definedResources . at resid ?= r
(r:) <$> loadClass rn S.Nothing (r^.rattributes) ClassResourceLike
_ -> {-# SCC "rrGeneralCase" #-}
use (definedResources . at resid) >>= \case
Just otheres -> throwPosError
$ "Resource" <+> pretty resid <+> "already defined:"
</> pretty r </> pretty otheres
Nothing -> do
definedResources . at resid ?= r
pure [r]
mainFunctionCall :: Text -> [PValue] -> InterpreterMonad [Resource]
mainFunctionCall "showscope" _ = use curScope >>= warn . pretty >> pure []
mainFunctionCall "alert" a = logWithModifier Log.ALERT red a
mainFunctionCall "crit" a = logWithModifier Log.CRITICAL red a
mainFunctionCall "debug" a = logWithModifier Log.DEBUG dullwhite a
mainFunctionCall "emerg" a = logWithModifier Log.EMERGENCY red a
mainFunctionCall "err" a = logWithModifier Log.ERROR dullred a
mainFunctionCall "info" a = logWithModifier Log.INFO dullgreen a
mainFunctionCall "notice" a = logWithModifier Log.NOTICE white a
mainFunctionCall "warning" a = logWithModifier Log.WARNING dullyellow a
mainFunctionCall "contain" includes =
concat <$> mapM doContain includes
where
doContain e = do
classname <- resolvePValueString e
use (loadedClasses . at classname) >>= \case
Nothing -> loadClass classname S.Nothing mempty ClassIncludeLike
Just _ -> pure []
mainFunctionCall "include" includes =
concat <$> mapM doInclude includes
where
doInclude e = do
classname <- resolvePValueString e
loadClass classname S.Nothing mempty ClassIncludeLike
mainFunctionCall "require" includes = do
checkStrict
"The require function is not supported ! Calling 'include' instead"
"The 'require' function is not supported in strict mode."
mainFunctionCall "include" includes
mainFunctionCall "create_resources" [t, hs] = mainFunctionCall "create_resources" [t, hs, PHash mempty]
mainFunctionCall "create_resources" [PString t, PHash hs, PHash defparams] = do
let (ats, t') = Text.span (== '@') t
virtuality <- case Text.length ats of
0 -> pure Normal
1 -> pure Virtual
2 -> pure Exported
_ -> throwPosError "Too many @'s"
p <- use curPos
let genRes rname (PHash rargs) = registerResource t' rname (rargs <> defparams) virtuality p
genRes rname x = throwPosError ("create_resource(): the value corresponding to key" <+> ppline rname <+> "should be a hash, not" <+> pretty x)
concat . Map.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 "ensure_packages" args = ensurePackages args
mainFunctionCall "ensure_resource" args = ensureResource args
mainFunctionCall "realize" args = do
pos <- use curPos
let updateMod (PResourceReference t rn) =
resModifiers %= (ResourceModifier t ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) pure pos : )
updateMod x = throwPosError ("realize(): all arguments must be resource references, not" <+> pretty x)
mapM_ updateMod args
pure []
mainFunctionCall "tag" args = do
scp <- getScopeName
let addTag x = scopes . ix scp . scopeExtraTags . contains x .= True
mapM_ (resolvePValueString >=> addTag) args
pure []
mainFunctionCall "fail" [x] = ("fail:" <+>) . dullred . ppline <$> 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 QUnique
p <- use curPos
curPos . _1 . _sourceName <>= " [hiera_include call]"
o <- mainFunctionCall "include" classes
curPos .= p
pure o
mainFunctionCall "hiera_include" _ = throwPosError "hiera_include(): This function takes a single argument"
mainFunctionCall "dumpinfos" _ = do
let prntline = logWriter Log.ALERT
indentln = (<>) " "
prntline "Scope stack :"
scps <- use curScope
mapM_ (prntline . indentln . pretty) scps
prntline "Variables in local scope :"
scp <- getScopeName
vars <- use (scopes . ix scp . scopeVariables)
forM_ (sortOn fst (itoList vars)) $ \(idx, pv :!: _ :!: _) -> prntline $ indentln $ ppline idx <> " -> " <> pretty pv
pure []
mainFunctionCall "assert_type" [PType dt, v] =
if datatypeMatch dt v
then pure []
else throwPosError $ "assert_type(): the value " <> pretty v <> " doesn't mach type " <> pretty dt
mainFunctionCall "assert_type" _ = throwPosError "assert_type(): Expects two arguments"
mainFunctionCall fname args = do
p <- use curPos
let representation = MainFunctionDeclaration (MainFuncDecl fname mempty p)
rs <- singleton (ExternalFunction fname args)
unless (rs == PUndef) $ throwPosError ("This function call should pure" <+> pretty PUndef <+> "and not" <+> pretty rs </> pretty representation)
pure []
ensurePackages :: [PValue] -> InterpreterMonad [Resource]
ensurePackages [packages] = ensurePackages [packages, PHash mempty]
ensurePackages [PString p, x] = ensurePackages [ PArray (V.singleton (PString p)), x ]
ensurePackages [PArray packages, PHash defparams] = do
checkStrict
"The use of the 'ensure_packages' function is a code smell."
"The 'ensure_packages' function is not allowed in strict mode."
concat <$> for packages (resolvePValueString >=> ensureResource' "package" (Map.singleton "ensure" "present" <> defparams))
ensurePackages [PArray _,_] = throwPosError "ensure_packages(): the second argument must be a hash."
ensurePackages [_,_] = throwPosError "ensure_packages(): the first argument must be a string or an array of strings."
ensurePackages _ = throwPosError "ensure_packages(): requires one or two arguments."
ensureResource :: [PValue] -> InterpreterMonad [Resource]
ensureResource [PString t, PString title, PHash params] = do
checkStrict
"The use of the 'ensure_resource' function is a code smell."
"The 'ensure_resource' function is not allowed in strict mode."
ensureResource' t params title
ensureResource [t, PArray arr, params] = concat <$> mapM (\r -> ensureResource [t, r, params]) (V.toList arr)
ensureResource [t,title] = ensureResource [t,title,PHash mempty]
ensureResource [_, PString _, PHash _] = throwPosError "ensureResource(): The first argument must be a string."
ensureResource [PString _, _, PHash _] = throwPosError "ensureResource(): The second argument must be a string."
ensureResource [PString _, PString _, _] = throwPosError "ensureResource(): The thrid argument must be a hash."
ensureResource _ = throwPosError "ensureResource(): expects 2 or 3 arguments."
ensureResource' :: Text -> HashMap Text PValue -> Text -> InterpreterMonad [Resource]
ensureResource' t params title = do
isdefined <- has (ix (normalizeRIdentifier t title)) <$> use definedResources
if isdefined
then pure []
else use curPos >>= registerResource t title params Normal
evaluateStatementsFoldable :: Foldable f => f Statement -> InterpreterMonad [Resource]
evaluateStatementsFoldable = fmap concat . mapM evaluateStatement . toList
logWithModifier :: Log.Priority -> (Doc -> Doc) -> [PValue] -> InterpreterMonad [Resource]
logWithModifier prio m [v] = do
p <- use curPos
v' <- resolvePValueString v
logWriter prio (m (ppline v') <+> showPPos p)
pure []
logWithModifier _ _ _ = throwPosError "This function takes a single argument"
validateNativeType :: Resource -> InterpreterMonad Resource
validateNativeType r = do
tps <- singleton GetNativeTypes
case tps ^. at (r ^. rid . itype) of
Just x -> case (x ^. puppetValidate) r of
Right nr -> pure nr
Left err -> throwPosError ("Invalid resource" <+> pretty r </> getError err)
Nothing -> pure r