{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
module Puppet.Interpreter
( interpretCatalog
, evaluateStatement
, computeCatalog
) where
import Control.Applicative
import Control.Lens hiding (ignored)
import Control.Monad.Except
import Control.Monad.Operational hiding (view)
import Control.Monad.Trans.Except
import Data.Char (isDigit)
import qualified Data.Either.Strict as S
import Data.Foldable (foldl', foldlM, toList)
import qualified Data.Graph as G
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import Data.List (nubBy, sortBy)
import Data.Maybe
import qualified Data.Maybe.Strict as S
import Data.Ord (comparing)
import Data.Semigroup (Max(..))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Traversable (for)
import qualified Data.Tree as T
import Data.Tuple.Strict (Pair (..))
import qualified Data.Vector as V
import System.Log.Logger
import Puppet.Interpreter.PrettyPrinter (containerComma)
import Puppet.Interpreter.Resolve
import Puppet.Interpreter.Types
import Puppet.Interpreter.Utils
import Puppet.Interpreter.IO
import Puppet.Lens
import Puppet.NativeTypes
import Puppet.Parser.PrettyPrinter
import Puppet.Parser.Types
import Puppet.Parser.Utils
import Puppet.PP
import Puppet.Utils
{-| Call the operational 'interpretMonad' function to compute the catalog.
Returns either an error, or a tuple containing all the resources,
dependency map, exported resources, and defined resources alongside with
all messages that have been generated by the compilation process.
The later 'definedResources' (eg. all class declarations) are pulled out of the
'InterpreterState' and might not be up to date.
There are only useful for coverage testing (checking dependencies for instance).
-}
interpretCatalog :: Monad m
=> InterpreterReader m -- ^ The whole environment required for computing catalog.
-> NodeName
-> Facts
-> Container Text -- ^ Server settings
-> m (Pair (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Priority Doc])
interpretCatalog interpretReader node facts settings = do
(output, _, warnings) <- interpretMonad interpretReader (initialState facts settings) (computeCatalog node)
return (strictifyEither 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" <+> 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
-- | Apply resource defaults, references overrides and expand defines
finalize :: [Resource] -> InterpreterMonad [Resource]
finalize rx = do
scp <- getScopeName
resdefaults <- use (scopes . ix scp . scopeResDefaults)
let getOver = use (scopes . ix scp . scopeOverrides) -- retrieves current overrides
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
-- we used this override, so we discard it
scopes . ix scp . scopeOverrides . at (r ^. rid) .= Nothing
let forb msg = throwPosError ("Override of parameters ("
<> list (map (ttext . 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" -- we could not get the current resource context
(x:_) -> if x == s
then return CantOverride -- we are in the same context : can't replace, but add stuff
else isParent (scopeName s) x >>= \i ->
if i || (r ^. rid . itype == "class")
then return Replace -- we can override what's defined in a parent
else forb "Can't override something that was not defined in the parent."
ifoldlM (addAttribute overrideType) r prms
-- step 1, apply resDefaults and resRefOverride
withDefaults <- mapM (addOverrides >=> addResDefaults) rx
-- There might be some overrides that could not be applied. The only
-- valid reason is that they override something in exported resources.
--
-- it probably do something unexpected on defines, but let's keep it that way for now.
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
-- we must define if we can override the value
let canOverride = CantOverride -- TODO check inheritance
ifoldlM (addAttribute canOverride) r resprms
void $ getOver >>= mapM keepforlater
let expandableDefine r = do
n <- isNativeType (r ^. rid . itype)
-- if we have a native type, or a virtual/exported resource it
-- should not be expanded !
if n || r ^. rvirtuality /= Normal
then return [r]
else expandDefine r
-- Now that all defaults / override have been applied, the defines can
-- finally be expanded.
-- The reason it has to be there is that parameters of the define could
-- be affected.
concat <$> mapM expandableDefine withDefaults
where
expandDefine :: Resource -> InterpreterMonad [Resource]
expandDefine r = do
let deftype = dropInitialColons (r ^. rid . itype)
defname = r ^. rid . iname
modulename = getModulename (r ^. rid)
curContType = ContDefine deftype defname (r ^. rpos)
p <- use curPos
-- we add the relations of this define to the global list of relations
-- before dropping it, so that they are stored for the final
-- relationship resolving
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, 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
ignored <- isIgnoredModule modulename
out <- if ignored
then return mempty
else do
loadVariable "title" (PString defname)
loadVariable "name" (PString defname)
-- not done through loadvariable because of override errors
loadParameters (r ^. rattributes) defineParams cp S.Nothing
curPos .= cp
res <- evaluateStatementsFoldable stmts
finalize (spurious ++ res)
when isImportedDefine popScope
popScope
return out
-- | Given a toplevel (type, name),
-- return the associated parsed statement together with its evaluated resources
interpretTopLevel :: TopLevelType -> Text -> InterpreterMonad ([Resource], Statement)
interpretTopLevel toptype topname =
-- check if this is a known toplevel
use (nestedDeclarations . at (toptype, topname)) >>= \case
Just x -> return ([], x) -- it is known !
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
-- popScope
(nr, ns) <- evalTopLevel s
popScope
return (r <> nr, ns)
evalTopLevel x = return ([], x)
-- | Main internal entry point, this function completes the interpretation
-- TODO: add some doc here
computeCatalog :: NodeName -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource])
computeCatalog nodename = do
(topres, stmt) <- interpretTopLevel TopNode nodename
nd <- extractPrism "computeCatalog" _NodeDecl stmt
let finalStep [] = return []
finalStep allres = do
-- collect stuff and apply thingies
(realized :!: modified) <- realize allres
-- we need to run it again against collected stuff, especially
-- for custom types (defines) that have been realized
refinalized <- finalize (toList modified) >>= finalStep
-- replace the modified stuff
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 dummyppos 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 yet, and will probably never be"
mapM evaluateStatement sx >>= finalize . concat
noderes <- evaluateNode nd >>= finalStep . (++ (mainstage : topres))
let (real :!: exported) = foldl' classify (mempty :!: mempty) noderes
-- Classify sorts resources between exported and normal ones. It
-- drops virtual resources, and puts in both categories resources
-- that are at the same time exported and realized.
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 <- HM.fromList . map (\r -> (r ^. rid, r)) <$> mapM validateNativeType (HM.elems real)
withResourceDependentRelations <- traverse getResourceDependentRelations verified
edgemap <- makeEdgeMap withResourceDependentRelations
definedRes <- use definedResources
return (withResourceDependentRelations, edgemap, exported, HM.elems definedRes)
-- | This extracts additional relationships between resources, that are
-- dependent on whether some resources are defined. A canonical example is
-- is the 'owner' field in a File, that can create problems if it's
-- defined!
--
-- For this reason, this function only adds dependencies when the resources
-- are defined.
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' (HM.unionWith (<>)) (res ^. rrelations)) (sequence actions)
return (res & rrelations .~ newrelations)
depOn :: Text -> Text -> InterpreterMonad (HM.HashMap RIdentifier (HS.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
return $ if existing
then HM.singleton targetResourceId (HS.singleton RRequire)
else HM.empty
_ -> return HM.empty
makeEdgeMap :: FinalCatalog -> InterpreterMonad EdgeMap
makeEdgeMap ct = do
-- merge the loaded classes and resources
defs' <- HM.map (view rpos) <$> use definedResources
clss' <- use loadedClasses
let defs = defs' <> classes' <> aliases' <> names'
names' = HM.map (view rpos) ct
-- generate fake resources for all extra aliases
aliases' = ifromList $ do
r <- ct ^.. traversed :: [Resource]
extraAliases <- r ^.. ralias . folded . filtered (/= r ^. rid . iname) :: [Text]
return (r ^. rid & iname .~ extraAliases, r ^. rpos)
classes' = ifromList $ do
(cn, _ :!: cp) <- itoList clss'
return (RIdentifier "class" cn, cp)
-- Preparation step : all relations to a container become relations to
-- the stuff that's contained. We build a map of resources, stored by
-- container.
-- step 1 - add relations that are stored in resources
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
-- compute the explicit resources, along with the container relationship
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)
return (nsrc, [LinkInformation nsrc ndst nlt respos])
step1 :: HM.HashMap RIdentifier [LinkInformation]
step1 = foldl' addRR mempty ct
-- step 2 - add other relations (mainly stuff made from the "->"
-- operator)
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)
-- check that all resources are defined, and build graph
let checkResDef :: (RIdentifier, [LinkInformation]) -> InterpreterMonad (RIdentifier, RIdentifier, [RIdentifier])
checkResDef (ri, lifs) = do
let checkExists r msg = do
let modulename = getModulename r
ignored <- isIgnoredModule modulename
unless (has (ix r) defs || 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))
return d
ds <- mapM genlnk lifs
return (ri, ri, ds)
edgeList <- mapM checkResDef (itoList step2)
let (graph, gresolver) = G.graphFromEdges' edgeList
-- now check for scc
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
-- let edgePairs = concatMap (\(_,k,ls) -> [(k,l) | l <- ls]) edgeList
-- throwPosError (vcat (map (\(RIdentifier st sn, RIdentifier dt dn) -> "\"" <> ttext st <> ttext sn <> "\" -> \"" <> ttext dt <> ttext dn <> "\"") edgePairs))
return step2
-- | This functions performs all the actions triggered by calls to the
-- realize function or other collectors. It returns a pair of
-- "finalcatalogs", where the first part is the new catalog, and the second
-- part the map of all modified resources. The second part is needed so
-- that we know for example which resources we should test for expansion
-- (custom types).
realize :: [Resource] -> InterpreterMonad (Pair FinalCatalog FinalCatalog)
realize rs = do
let -- rma is the initial map of resources, indexed by resource identifier
rma = ifromList (map (\r -> (r ^. rid, r)) rs)
-- mutate runs all the resource modifiers (ie. realize, overrides
-- and other collectors). It stores the modified resources on the
-- "right" of the resulting pair.
mutate :: Pair FinalCatalog FinalCatalog -> ResourceModifier -> InterpreterMonad (Pair FinalCatalog FinalCatalog)
mutate (curmap :!: modified) rmod = do
let filtrd = curmap ^.. folded . filtered fmod -- all the resources that match the selector/realize criteria
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 FinalCatalog FinalCatalog -> Resource -> InterpreterMonad (Pair FinalCatalog FinalCatalog)
applyModification (cma :!: cmo) r = do
nr <- mutation r
let i m = m & at (nr ^. rid) ?~ nr
return $ if nr /= r
then i cma :!: i cmo
else cma :!: cmo
result <- foldM applyModification (curmap :!: modified) filtrd -- apply the modifiation to all the matching resources
when (rmod ^. rmModifierType == ModifierMustMatch && null filtrd) (throwError (PrettyError ("Could not apply this resource override :" <+> pretty rmod <> ",no matching resource was found.")))
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) . reverse . nubBy equalModifier
resMod .= []
return result
-- | Fold all attribute declarations
-- checking for duplicates key locally inside a same resource.
fromAttributeDecls :: V.Vector AttributeDecl -> InterpreterMonad (Container PValue)
fromAttributeDecls = foldM resolve mempty
where
resolve acc (AttributeDecl k _ v) =
case acc ^. at k of
Just _ -> throwPosError ("Parameter" <+> dullyellow (ttext k) <+> "already defined!")
Nothing -> do
pv <- resolveExpression v
return (acc & at k ?~ pv)
saveCaptureVariables :: InterpreterMonad (HM.HashMap T.Text (Pair (Pair PValue PPosition) CurContainerDesc))
saveCaptureVariables = do
scp <- getScopeName
vars <- use (scopes . ix scp . scopeVariables)
return $ HM.filterWithKey (\k _ -> T.all isDigit k) vars
restoreCaptureVariables :: HM.HashMap T.Text (Pair (Pair PValue PPosition) CurContainerDesc) -> InterpreterMonad ()
restoreCaptureVariables vars = do
scp <- getScopeName
scopes . ix scp . scopeVariables %= HM.union vars . HM.filterWithKey (\k _ -> not (T.all isDigit k))
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 (DefineDecl 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@(ResourceCollectionDeclaration (ResCollDecl ct rtype searchexp mods p)) = do
curPos .= p
unless (isEmpty 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
resMod %= (ResourceModifier rtype ModifierCollector et rsearch (\r' -> foldM modifyCollectedAttribute r' mods) p : )
-- Now collected from the PuppetDB !
if et == RealizeCollected
then do
let q = searchExpressionToPuppetDB rtype rsearch
fqdn <- getNodeName
-- we must filter the resources that originated from this host
-- here ! They are also turned into "normal" resources
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
return o
else return []
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 ]
return []
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 varname varexpr p)) = do
curPos .= p
varval <- resolveExpression varexpr
loadVariable varname varval
return []
evaluateStatement (ConditionalDeclaration (ConditionalDecl conds p)) = do
curPos .= p
let checkCond [] = return []
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
-- invariant that must be respected : the current scope must be created
-- in "scopes", or nothing gets saved
preuse (scopes . ix scp) >>= maybe (throwPosError ("INTERNAL ERROR in evaluateStatement ResourceDefaultDeclaration: scope wasn't created - " <> pretty scp)) (const (return ()))
let newDefaults = ResDefaults rtype scp rdecls p
addDefaults x = scopes . ix scp . scopeResDefaults . at rtype ?= x
-- default merging with parent
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" <+> ttext rtype <+> "already declared at" <+> showPPos (d ^. resDefPos))
else addDefaults (mergedDefaults d)
return []
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
-- check that we didn't already override those values
withAssignements <- case curoverrides ^. at rident of
Just (ResRefOverride _ prevass prevpos) -> do
let cm = prevass `HM.intersection` raassignements
unless (isEmpty 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 (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl c p)) = curPos .= p >> evaluateHFC c
where
evaluateHFC :: HOLambdaCall -> InterpreterMonad [Resource]
evaluateHFC hf = do
varassocs <- hfGenerateAssociations hf
let runblock :: [(Text, PValue)] -> InterpreterMonad [Resource]
runblock assocs = do
saved <- hfSetvars assocs
res <- evaluateStatementsFoldable (hf ^. hoLambdaStatements)
hfRestorevars saved
return res
results <- mapM runblock varassocs
return (concat results)
evaluateStatement r = throwError (PrettyError ("Do not know how to evaluate this statement:" </> pretty r))
-----------------------------------------------------------
-- Class evaluation
-----------------------------------------------------------
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" <+> 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)
-- | This function loads class and define parameters into scope. It checks
-- that all mandatory parameters are set, that no extra parameter is
-- declared.
--
-- It is able to fill unset parameters with values from Hiera (for classes
-- only) or default values.
loadParameters :: Foldable f => Container PValue -> f (Pair Text (S.Maybe Expression)) -> PPosition -> S.Maybe T.Text -> InterpreterMonad ()
loadParameters params classParams defaultPos wHiera = do
p <- use curPos
curPos .= defaultPos
let classParamSet = HS.fromList (classParams ^.. folded . _1)
spuriousParams = ikeys params `HS.difference` classParamSet
mclassdesc = S.maybe mempty ((\x -> mempty <+> "when including class" <+> x) . ttext) wHiera
-- the following functions `throwE (Max False)` when there is no value, and `throwE (Max True)` when this value
-- in PUndef.
checkUndef :: Maybe PValue -> ExceptT (Max Bool) InterpreterMonad PValue
checkUndef Nothing = throwE (Max False)
checkUndef (Just PUndef) = throwE (Max True)
checkUndef (Just v) = return v
checkHiera :: T.Text -> ExceptT (Max Bool) InterpreterMonad PValue
checkHiera k = case wHiera of
S.Nothing -> throwE (Max False)
S.Just classname -> lift (runHiera (classname <> "::" <> k) Priority) >>= checkUndef
checkDef :: T.Text -> ExceptT (Max Bool) InterpreterMonad PValue
checkDef k = checkUndef (params ^. at k)
checkDefault :: S.Maybe Expression -> ExceptT (Max Bool) InterpreterMonad PValue
checkDefault S.Nothing = throwE (Max False)
checkDefault (S.Just expr) = lift (resolveExpression expr)
unless (isEmpty spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ttext) $ toList spuriousParams) <> mclassdesc)
-- try to set a value to all parameters
-- The order of evaluation is defined / hiera / default
unsetParams <- fmap concat $ for (toList classParams) $ \(k :!: defValue) -> do
ev <- runExceptT (checkDef k <|> checkHiera k <|> checkDefault defValue)
case ev of
Right v -> loadVariable k v >> return []
Left (Max True) -> loadVariable k PUndef >> return []
Left (Max False) -> return [k]
curPos .= p
unless (isEmpty unsetParams) $ throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ttext $ toList unsetParams) <> mclassdesc)
-- | Enters a new scope, checks it is not already defined, and inherits the
-- defaults from the current scope
--
-- Inheriting the defaults is necessary for non native types, because they
-- will be expanded in "finalize", so if this was not done, we would be
-- expanding the defines without the defaults applied
enterScope :: ScopeEnteringContext
-> CurContainerDesc
-> Text
-> PPosition
-> InterpreterMonad Text
enterScope secontext cont modulename p = do
let scopename = scopeName cont
-- This is a special hack for inheritance, because at this time we
-- have not properly stacked the scopes.
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
-- it is OK to reuse a scope related to imported stuff
unless (scopeAlreadyDefined && isImported) $ do
when scopeAlreadyDefined (throwPosError ("Internal error: scope" <+> brackets (ttext scopename) <+> "already defined when loading scope for" <+> pretty cont))
scp <- getScopeName
-- TODO fill tags
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 . scopeResDefaults)
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
loadClass :: Text
-> S.Maybe Text -- ^ Set if this is an inheritance load, so that we can set calling module properly
-> Container PValue
-> ClassIncludeType
-> InterpreterMonad [Resource]
loadClass name loadedfrom params incltype = do
let name' = dropInitialColons name
ndn <- getNodeName
singleton (TraceEvent ('[' : T.unpack ndn ++ "] loadClass " ++ T.unpack name'))
p <- use curPos
-- check if the class has already been loaded
-- http://docs.puppetlabs.com/puppet/3/reference/lang_classes.html#using-resource-like-declarations
preuse (loadedClasses . ix name' . _2) >>= \case
Just pp -> case incltype of
ClassIncludeLike -> return []
_ -> throwPosError ("Can't include class" <+> ttext name' <+> "twice when using the resource-like syntax (first occurence at"
<+> showPPos pp <> ")")
Nothing -> do
loadedClasses . at name' ?= (incltype :!: p)
-- load the actual class, note we are not changing the current position right now
(spurious, stmt) <- interpretTopLevel TopClass name'
ClassDecl _ classParams inh stmts cp <- extractPrism "loadClass" _ClassDecl stmt
-- check if we need to define a resource representing the class
-- This will be the case for the first standard include
inhstmts <- case inh of
S.Nothing -> return []
S.Just ihname -> loadClass ihname (S.Just name') mempty ClassIncludeLike
let !scopedesc = ContClass name'
modulename = getModulename (RIdentifier "class" name')
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 incltype == ClassIncludeLike
then do
scp <- use curScope
fqdn <- getNodeName
return [Resource (RIdentifier "class" name') (HS.singleton name') mempty mempty scp Normal mempty p fqdn]
else return []
pushScope scopedesc
ignored <- isIgnoredModule modulename
out <- if ignored
then return mempty
else do
loadVariable "title" (PString name')
loadVariable "name" (PString name')
loadParameters params classParams cp (S.Just name')
curPos .= cp
res <- evaluateStatementsFoldable stmts
finalize (classresource ++ spurious ++ inhstmts ++ res)
popScope
return out
-----------------------------------------------------------
-- Resource stuff
-----------------------------------------------------------
addRelationship :: LinkType -> PValue -> Resource -> InterpreterMonad Resource
addRelationship lt (PResourceReference dt dn) r = return (r & rrelations %~ insertLt)
where
insertLt = iinsertWith (<>) (normalizeRIdentifier 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 -> 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) >> 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 = 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 -> return (res & rattributes . at attributename ?~ value)
Just curval -> do
-- we must check if the resource scope is
-- a parent of the current scope
curscope <- getScopeName
i <- isParent curscope (rcurcontainer res)
if i
-- TODO check why this is set
then return (res & rattributes . at attributename ?~ value)
else do
-- We will not bark if the same attribute
-- is defined multiple times with identical
-- values.
let errmsg = "Attribute" <+> dullmagenta (ttext attributename) <+> "defined multiple times for" <+> pretty res
if curval == value
then checkStrict errmsg errmsg
else throwPosError errmsg
return res
overrideAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource
overrideAttribute attributename res value = return (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, _) -> return value
(Just (PArray a), PArray b) -> return (PArray (a <> b))
(Just (PArray a), b) -> return (PArray (V.snoc a b))
(Just a, PArray b) -> return (PArray (V.cons a b))
(Just a, b) -> return (PArray (V.fromList [a,b]))
return (res & rattributes . at attributename ?~ nvalue)
defaultAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource
defaultAttribute attributename res value = return $ case res ^. rattributes . at attributename of
Nothing -> res & rattributes . at attributename ?~ value
Just _ -> res
modifyCollectedAttribute :: Resource -> AttributeDecl -> InterpreterMonad Resource
modifyCollectedAttribute res (AttributeDecl attributename arrowop expr) = do
value <- resolveExpression expr
let optype = case arrowop of
AppendArrow -> AppendAttribute
AssignArrow -> Replace
addAttribute optype attributename res value
registerResource :: 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 t rn arg vrt p = do
curPos .= p
CurContainer cnt tgs <- getCurContainer
-- default tags
-- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#automatic-tagging
-- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#containment
let !defaulttags = {-# SCC "rrGetTags" #-} HS.fromList (t : 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,normalizeRIdentifier 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 <- getNodeName
let baseresource = Resource (normalizeRIdentifier t rn) (HS.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
let attrs = r ^. rattributes
fmap (r:) $ loadClass rn S.Nothing attrs 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
return [r]
-- functions : this can't really be exported as it uses a lot of stuff from
-- this module ...
mainFunctionCall :: Text -> [PValue] -> InterpreterMonad [Resource]
mainFunctionCall "showscope" _ = use curScope >>= warn . pretty >> return []
-- The logging functions
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 "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 _ -> return [] -- TODO check that this happened after class declaration
mainFunctionCall "include" includes = concat <$> mapM doInclude includes
where doInclude e = do
classname <- resolvePValueString e
loadClass classname S.Nothing mempty ClassIncludeLike
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') = T.span (== '@') t
virtuality <- case T.length ats of
0 -> return Normal
1 -> return Virtual
2 -> return 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" <+> 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 "ensure_packages" args = ensurePackages args
mainFunctionCall "ensure_resource" args = ensureResource args
mainFunctionCall "realize" args = do
pos <- use curPos
let updateMod (PResourceReference t rn) = resMod %= (ResourceModifier t ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) return pos : )
updateMod x = throwPosError ("realize(): all arguments must be resource references, not" <+> pretty x)
mapM_ updateMod 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 "dumpinfos" _ = do
let prntline = logWriter 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_ (sortBy (comparing fst) (itoList vars)) $ \(idx, pv :!: _ :!: _) -> prntline $ indentln $ ttext idx <> " -> " <> pretty pv
return []
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 return" <+> pretty PUndef <+> "and not" <+> pretty rs </> pretty representation)
return []
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" (HM.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."
-- | Takes a resource type, title, and a hash of attributes that describe the resource
-- Create the resource if it does not exist alreadyTakes a resource type, title, and a hash of attributes that describe the resource(s).
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,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 -> HM.HashMap T.Text PValue -> T.Text -> InterpreterMonad [Resource]
ensureResource' t params title = do
isdefined <- has (ix (normalizeRIdentifier t title)) <$> use definedResources
if isdefined
then return []
else use curPos >>= registerResource t title params Normal
-----------------------------------------------------------
-- Specific utils functions that depends on this modules
-----------------------------------------------------------
evaluateStatementsFoldable :: Foldable f => f Statement -> InterpreterMonad [Resource]
evaluateStatementsFoldable = fmap concat . mapM evaluateStatement . toList
-- A helper function for the various loggers
logWithModifier :: Priority -> (Doc -> Doc) -> [PValue] -> InterpreterMonad [Resource]
logWithModifier prio m [v] = do
p <- use curPos
v' <- resolvePValueString v
logWriter prio (m (ttext v') <+> showPPos p)
return []
logWithModifier _ _ _ = throwPosError "This function takes a single argument"