diff --git a/Erb/Compute.hs b/Erb/Compute.hs --- a/Erb/Compute.hs +++ b/Erb/Compute.hs @@ -75,9 +75,11 @@ case exists of True -> return cabalPath False -> return "calcerb.rb" - ret <- safeReadProcessTimeout "ruby" [rubyscriptpath] (BB.toLazyByteString input) 1000 + traceEventIO ("start running ruby" ++ filename) + !ret <- safeReadProcessTimeout "ruby" [rubyscriptpath] (BB.toLazyByteString input) 1000 + traceEventIO ("finished running ruby" ++ filename) case ret of - Just (Right x) -> return $ Right (BS.unpack x) + Just (Right x) -> return $! Right (BS.unpack x) Just (Left er) -> do (tmpfilename, tmphandle) <- openTempFile "/tmp" "templatefail" BS.hPut tmphandle (BB.toLazyByteString input) diff --git a/Erb/Ruby.hs b/Erb/Ruby.hs --- a/Erb/Ruby.hs +++ b/Erb/Ruby.hs @@ -1,40 +1,40 @@ module Erb.Ruby where data Value - = Literal String - | Array [Expression] + = Literal !String + | Array ![Expression] deriving (Show, Ord, Eq) data Expression - = LookupOperation Expression Expression - | PlusOperation Expression Expression - | MinusOperation Expression Expression - | DivOperation Expression Expression - | MultiplyOperation Expression Expression - | ShiftLeftOperation Expression Expression - | ShiftRightOperation Expression Expression - | AndOperation Expression Expression - | OrOperation Expression Expression - | EqualOperation Expression Expression - | DifferentOperation Expression Expression - | AboveOperation Expression Expression - | AboveEqualOperation Expression Expression - | UnderEqualOperation Expression Expression - | UnderOperation Expression Expression - | RegexpOperation Expression Expression - | NotRegexpOperation Expression Expression - | NotOperation Expression - | NegOperation Expression - | ConditionalValue Expression Expression - | Object Expression - | MethodCall Expression Expression - | BlockOperation String - | Value Value + = LookupOperation !Expression !Expression + | PlusOperation !Expression !Expression + | MinusOperation !Expression !Expression + | DivOperation !Expression !Expression + | MultiplyOperation !Expression !Expression + | ShiftLeftOperation !Expression !Expression + | ShiftRightOperation !Expression !Expression + | AndOperation !Expression !Expression + | OrOperation !Expression !Expression + | EqualOperation !Expression !Expression + | DifferentOperation !Expression !Expression + | AboveOperation !Expression !Expression + | AboveEqualOperation !Expression !Expression + | UnderEqualOperation !Expression !Expression + | UnderOperation !Expression !Expression + | RegexpOperation !Expression !Expression + | NotRegexpOperation !Expression !Expression + | NotOperation !Expression + | NegOperation !Expression + | ConditionalValue !Expression !Expression + | Object !Expression + | MethodCall !Expression !Expression + | BlockOperation !String + | Value !Value | BTrue | BFalse - | Error String + | Error !String deriving (Show, Ord, Eq) data RubyStatement - = Puts Expression + = Puts !Expression deriving(Show) diff --git a/Puppet/DSL/Types.hs b/Puppet/DSL/Types.hs --- a/Puppet/DSL/Types.hs +++ b/Puppet/DSL/Types.hs @@ -4,7 +4,7 @@ import Text.Parsec.Pos -data Parameters = Parameters [(Expression, Expression)] deriving(Show, Ord, Eq) +data Parameters = Parameters ![(Expression, Expression)] deriving(Show, Ord, Eq) -- |This type is used to differenciate the distinct top level types that are -- exposed by the DSL. @@ -34,22 +34,22 @@ -- 'Expression' data Value -- |String literal. - = Literal String + = Literal !String -- |An interpolable string, represented as a 'Value' list. - | Interpolable [Value] + | Interpolable ![Value] -- |A Puppet Regexp. This is very hackish as it alters the behaviour of some -- functions (such as conditional values). - | PuppetRegexp String - | Double Double - | Integer Integer + | PuppetRegexp !String + | Double !Double + | Integer !Integer -- |Reference to a variable. The string contains what is acutally typed in -- the manifest. - | VariableReference String + | VariableReference !String | Empty - | ResourceReference String Expression -- restype resname - | PuppetArray [Expression] - | PuppetHash Parameters - | FunctionCall String [Expression] + | ResourceReference !String !Expression -- restype resname + | PuppetArray ![Expression] + | PuppetHash !Parameters + | FunctionCall !String ![Expression] -- |This is special and quite hackish too. | Undefined deriving(Show, Ord, Eq) @@ -58,46 +58,46 @@ -- | The actual puppet statements data Statement - = Node String ![Statement] SourcePos -- ^ This holds the node name and list of statements. + = Node String ![Statement] !SourcePos -- ^ This holds the node name and list of statements. -- | This holds the variable name and the expression that it represents. - | VariableAssignment String Expression SourcePos - | Include String SourcePos - | Import String SourcePos - | Require String SourcePos + | VariableAssignment !String !Expression !SourcePos + | Include !String !SourcePos + | Import !String !SourcePos + | Require !String !SourcePos -- | This holds the resource type, name, parameter list and virtuality. - | Resource String Expression ![(Expression, Expression)] Virtuality SourcePos + | Resource !String !Expression ![(Expression, Expression)] !Virtuality !SourcePos {-| This is a resource default declaration, such as File {owner => \'root\'; }. It holds the resource type and the list of default parameters. -} - | ResourceDefault String ![(Expression, Expression)] SourcePos + | ResourceDefault !String ![(Expression, Expression)] !SourcePos {-| This works like 'Resource', but the 'Expression' holds the resource name. -} - | ResourceOverride String Expression ![(Expression, Expression)] SourcePos + | ResourceOverride !String !Expression ![(Expression, Expression)] !SourcePos {-| The pairs hold on the left a value that is resolved as a boolean, and on the right the list of statements that correspond to this. This will be generated by if\/then\/else statement, but also by the case statement. -} - | ConditionalStatement ![(Expression, [Statement])] SourcePos + | ConditionalStatement ![(Expression, [Statement])] !SourcePos {-| The class declaration holds the class name, the optional name of the class it inherits from, a list of parameters with optional default values, and the list of statements it contains. -} - | ClassDeclaration String (Maybe String) ![(String, Maybe Expression)] ![Statement] SourcePos + | ClassDeclaration !String !(Maybe String) ![(String, Maybe Expression)] ![Statement] !SourcePos {-| The define declaration is like the 'ClassDeclaration' except it can't inherit from anything. -} - | DefineDeclaration String ![(String, Maybe Expression)] ![Statement] SourcePos + | DefineDeclaration !String ![(String, Maybe Expression)] ![Statement] !SourcePos {-| This is the resource collection syntax (\<\<\| \|\>\>). It holds the conditional expression, and an eventual list of overrides. This is important as the same token conveys two distinct Puppet concepts : resource collection and resource overrides. -} - | ResourceCollection String !Expression ![(Expression, Expression)] SourcePos + | ResourceCollection !String !Expression ![(Expression, Expression)] !SourcePos -- |Same as 'ResourceCollection', but for \<\| \|\>. - | VirtualResourceCollection String !Expression ![(Expression, Expression)] SourcePos - | DependenceChain !(String,Expression) !(String,Expression) SourcePos - | MainFunctionCall String ![Expression] SourcePos + | VirtualResourceCollection !String !Expression ![(Expression, Expression)] !SourcePos + | DependenceChain !(String,Expression) !(String,Expression) !SourcePos + | MainFunctionCall !String ![Expression] !SourcePos {-| This is a magic statement that is used to hold the spurious top level statements that comes in the same file as the correct top level statement that is stored in the second field. The first field contains pairs of @@ -133,9 +133,9 @@ | NegOperation !Expression -- ^ - a | ConditionalValue !Expression !Expression -- ^ a ? b (b should be a 'PuppetHash') - | Value Value -- ^ 'Value' terminal - | ResolvedResourceReference String String -- ^ Resolved resource reference + | Value !Value -- ^ 'Value' terminal + | ResolvedResourceReference !String !String -- ^ Resolved resource reference | BTrue -- ^ True expression, this could have been better to use a 'Value' | BFalse -- ^ False expression - | Error String -- ^ Not used anymore. + | Error !String -- ^ Not used anymore. deriving(Show, Ord, Eq) diff --git a/Puppet/Daemon.hs b/Puppet/Daemon.hs --- a/Puppet/Daemon.hs +++ b/Puppet/Daemon.hs @@ -28,7 +28,7 @@ -- this daemon returns a catalog when asked for a node and facts data DaemonMessage = QCatalog (String, Facts, Chan DaemonMessage) - | RCatalog (Either String FinalCatalog) + | RCatalog (Either String (FinalCatalog, EdgeMap, FinalCatalog)) logDebug = LOG.debugM "Puppet.Daemon" logInfo = LOG.infoM "Puppet.Daemon" @@ -38,8 +38,9 @@ {-| This is a high level function, that will initialize the parsing and interpretation infrastructure from the 'Prefs' structure, and will return a function that will take a node name, 'Facts' and return either an error or the -'FinalCatalog'. It also return a few IO functions that can be used in order to -query the daemon for statistics, following the format in "Puppet.Stats". +'FinalCatalog', along with the dependency graph and catalog of exported resources. It also return a few IO +functions that can be used in order to query the daemon for statistics, +following the format in "Puppet.Stats". It will internaly initialize several threads that communicate with channels. It should scale well, althrough it hasn't really been tested yet. It should cache @@ -74,7 +75,7 @@ is not existent. This will need fixing. -} -initDaemon :: Prefs -> IO ( String -> Facts -> IO(Either String FinalCatalog), IO StatsTable, IO StatsTable, IO StatsTable ) +initDaemon :: Prefs -> IO ( String -> Facts -> IO(Either String (FinalCatalog, EdgeMap, FinalCatalog)), IO StatsTable, IO StatsTable, IO StatsTable ) initDaemon prefs = do logDebug "initDaemon" traceEventIO "initDaemon" @@ -111,7 +112,7 @@ _ -> logError "Bad message type for master" master prefs chan getstmts gettemplate mstats -gCatalog :: Chan DaemonMessage -> String -> Facts -> IO (Either String FinalCatalog) +gCatalog :: Chan DaemonMessage -> String -> Facts -> IO (Either String (FinalCatalog, EdgeMap, FinalCatalog)) gCatalog channel nodename facts = do respchan <- newChan writeChan channel $ QCatalog (nodename, facts, respchan) diff --git a/Puppet/Interpreter/Catalog.hs b/Puppet/Interpreter/Catalog.hs --- a/Puppet/Interpreter/Catalog.hs +++ b/Puppet/Interpreter/Catalog.hs @@ -52,6 +52,10 @@ import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Traversable as DT +import qualified Data.Graph as Graph +import qualified Data.Tree as Tree +--import qualified Data.Graph.Inductive as Graph +--import Data.Graph.Analysis.Algorithms.Common (cyclesIn) qualified [] = False qualified str = isPrefixOf "::" str || qualified (tail str) @@ -64,6 +68,9 @@ then return (read x) else throwPosError $ "Expected an integer instead of '" ++ x +-- | This function returns an error, or the 'FinalCatalog' of resources to +-- apply, the map of all edges between resources, and the 'FinalCatalog' of +-- exported resources. getCatalog :: (TopLevelType -> String -> IO (Either String Statement)) -- ^ The \"get statements\" function. Given a top level type and its name it -- should return the corresponding statement. @@ -78,7 +85,7 @@ -> Facts -- ^ Facts of this node. -> Maybe String -- ^ Path to the modules, for user plugins. If set to Nothing, plugins are disabled. -> Map.Map PuppetTypeName PuppetTypeMethods -- ^ The list of native types - -> IO (Either String FinalCatalog, [String]) + -> IO (Either String (FinalCatalog, EdgeMap, FinalCatalog), [String]) getCatalog getstatements gettemplate puppetdb nodename facts modules ntypes = do let convertedfacts = Map.map (\fval -> (Right fval, initialPos "FACTS")) @@ -104,7 +111,8 @@ , luaState = luastate , userFunctions = Set.fromList userfunctions , nativeTypes = ntypes - , definedResources = Set.empty + , definedResources = Map.empty + , currentDependencyStack = [("node",nodename)] } ) case luastate of Just l -> closeLua l @@ -113,30 +121,34 @@ Left x -> return (Left x, getWarnings finalstate) Right _ -> return (output, getWarnings finalstate) -computeCatalog :: (TopLevelType -> String -> IO (Either String Statement)) -> String -> CatalogMonad FinalCatalog +computeCatalog :: (TopLevelType -> String -> IO (Either String Statement)) -> String -> CatalogMonad (FinalCatalog, EdgeMap, FinalCatalog) computeCatalog getstatements nodename = do nodestatements <- liftIO $ getstatements TopNode nodename case nodestatements of Left x -> throwError x Right nodestmts -> evaluateStatements nodestmts >>= finalResolution +resolveResource :: CResource -> CatalogMonad (ResIdentifier, RResource) +resolveResource cr@(CResource cid cname ctype cparams _ cpos) = do + setPos cpos + rname <- resolveGeneralString cname + rparams <- mapM (\(a,b) -> do { ra <- resolveGeneralString a; rb <- resolveGeneralValue b; return (ra,rb); }) (Map.toList cparams) + nparams <- processOverride cr (Map.fromList rparams) + let mrrelations = [] + prefinalresource = RResource cid rname ctype nparams mrrelations cpos + return ((ctype, rname), prefinalresource) -- this validates the resolved resources -- it should only be called with native types or the validatefunction lookup with abord with an error finalizeResource :: CResource -> CatalogMonad (ResIdentifier, RResource) -finalizeResource cr@(CResource cid cname ctype cparams _ cpos) = do - setPos cpos - rname <- resolveGeneralString cname - rparams <- mapM (\(a,b) -> do { ra <- resolveGeneralString a; rb <- resolveGeneralValue b; return (ra,rb); }) (Map.toList cparams) - -- add collected relations - -- TODO +finalizeResource cr = do + ((_, rname), prefinalresource) <- resolveResource cr + let ctype = rrtype prefinalresource + cpos = rrpos prefinalresource ntypes <- fmap nativeTypes get unless (Map.member ctype ntypes) $ throwPosError $ "Can't find native type " ++ ctype -- now run the collection checks for overrides - nparams <- processOverride cr (Map.fromList rparams) - let mrrelations = [] - prefinalresource = RResource cid rname ctype nparams mrrelations cpos - validatefunction = puppetvalidate (ntypes Map.! ctype) + let validatefunction = puppetvalidate (ntypes Map.! ctype) validated = validatefunction prefinalresource case validated of Left err -> throwError (err ++ " for resource " ++ ctype ++ "[" ++ rname ++ "] at " ++ show cpos) @@ -188,11 +200,62 @@ extractRelations :: CResource -> CatalogMonad CResource extractRelations cr = do - let (params, rels) = partitionParamsRelations (crparams cr) - -- TODO export relations + let (params, relations) = partitionParamsRelations (crparams cr) + addUnresRel (relations, (crtype cr, crname cr), UNormal, pos cr) return cr { crparams = params } -finalResolution :: Catalog -> CatalogMonad FinalCatalog +-- resolves a single relationship +resolveRelationship :: ([(LinkType, GeneralValue, GeneralValue)], (String, GeneralString), RelUpdateType, SourcePos) + -> CatalogMonad ([(LinkType, ResIdentifier)], ResIdentifier, RelUpdateType, SourcePos) +resolveRelationship (udsts, (stype, usname), uptype, spos) = do + let resolveSrcRel (ltype, udtype, udname) = do + dtype <- resolveGeneralValue udtype >>= rstring + dname <- resolveGeneralValue udname >>= rstring + return (ltype, (dtype, dname)) + dsts <- mapM resolveSrcRel udsts + sname <- resolveGeneralString usname + return (dsts, (stype, sname), uptype, spos) + +-- this does all the relation stuff +finalizeRelations :: FinalCatalog -> FinalCatalog -> CatalogMonad (FinalCatalog, EdgeMap) +finalizeRelations exported cat = do + grels <- fmap unresolvedRels get >>= mapM resolveRelationship + drs <- fmap definedResources get + let extr :: ([(LinkType, ResIdentifier)], ResIdentifier, RelUpdateType, SourcePos) + -> [(ResIdentifier, ResIdentifier, LinkInfo)] + extr (dsts, src, rutype, spos) = do + (ltype, dst) <- dsts + return (dst, src, (ltype, rutype, spos)) + !rels = concatMap extr grels :: [(ResIdentifier, ResIdentifier, LinkInfo)] + checkRelationExists :: (ResIdentifier, ResIdentifier, LinkInfo) -> CatalogMonad (Maybe (ResIdentifier, ResIdentifier, LinkInfo)) + checkRelationExists !o@(!src, !dst, (!ltype,!lutype,!lpos)) = do + -- if the source of the relation doesn't exist (is exported), + -- then when drop this relation + case (Map.member src drs, Map.member dst drs, Map.member src exported, Map.member dst exported) of + (_, _, _, True) -> return Nothing + -- we have a good relation, reorder it so that all arrows point the same way + (True, True,_ , _) -> case ltype of + RNotify -> return $ Just (dst, src, (RSubscribe, lutype,lpos)) + RBefore -> return $ Just (dst, src, (RRequire , lutype,lpos)) + _ -> return (Just o) + _ -> throwError $ "Unknown resource " ++ show dst ++ " used at " ++ show lpos ++ " debug: " ++ show (Map.member src drs, Map.member dst drs, Map.member src exported, Map.member dst exported) + -- now look for cycles in the graph + checkedrels <- fmap catMaybes $ mapM checkRelationExists rels + let !edgeMap = Map.fromList (map (\(d,s,i) -> ((s,d),i)) checkedrels) :: EdgeMap -- warning, in the edgemap we have (src, dst), contrary to all other uses + !nodeRel = Map.fromListWith (++) (map (\(d,s,_) -> (s,[d])) checkedrels) :: Map.Map ResIdentifier [ResIdentifier] + !(relgraph,qfunc) = Graph.graphFromEdges' $ map (\(a,b) -> (a,a,b)) $ Map.toList nodeRel + !cycles = map (map ((\(a,_,_) -> a) . qfunc) . Tree.flatten) $ filter (not . null . Tree.subForest) $ Graph.scc relgraph :: [[ResIdentifier]] + describe :: [ResIdentifier] -> String + describe x = let rx = map (\i -> (i, drs Map.! i)) x + in intercalate "\n\t\t" (showRRef (head x) : map describe' (zip x (tail rx))) + describe' :: (ResIdentifier, (ResIdentifier, SourcePos)) -> String + describe' (src,(dst,dpos)) = " -> " ++ showRRef dst ++ " [" ++ show dpos ++ "] link is " ++ show (Map.lookup (src,dst) edgeMap) + if null cycles + then return (cat, edgeMap) + else throwError $ "The following cycles have been found:\n\t" ++ intercalate "\n\t" (map describe cycles) + + +finalResolution :: Catalog -> CatalogMonad (FinalCatalog, EdgeMap, FinalCatalog) finalResolution cat = do pdbfunction <- fmap puppetDBFunction get fqdnr <- getVariable "::fqdn" @@ -209,12 +272,15 @@ collected <- mapM evaluateDefine (collectedLocal ++ collectedRemote') let (real, allvirtual) = partition (\x -> crvirtuality x == Normal) (concat collected) (_, exported) = partition (\x -> crvirtuality x == Virtual) allvirtual + rexported <- mapM resolveResource exported + let !exportMap = Map.fromList rexported -- TODO --export stuff --liftIO $ putStrLn "EXPORTED:" --liftIO $ mapM print exported --get >>= return . unresolvedRels >>= liftIO . (mapM print) - mapM finalizeResource real >>= createResourceMap + (fc, em) <- mapM finalizeResource real >>= createResourceMap >>= finalizeRelations exportMap + return (fc, em, exportMap) createResourceMap :: [(ResIdentifier, RResource)] -> CatalogMonad FinalCatalog createResourceMap = foldM insertres Map.empty @@ -239,7 +305,6 @@ Right y -> return y -- State alteration functions -pushScope = modify . modifyScope . (:) pushDefaults :: ResDefaults -> CatalogMonad () pushDefaults d = do @@ -266,7 +331,10 @@ Nothing -> return [] Just x -> return x -popScope = modify (modifyScope tail) +pushDependency = modify . modifyDeps . (:) +popDependency = modify (modifyDeps tail) +pushScope = modify . modifyScope . (:) +popScope = modify (modifyScope tail) getScope = do scope <- liftM curScope get if null scope @@ -409,9 +477,11 @@ evaluateDefineDeclaration dtype args dstmts dpos = do --oldpos <- getPos pushScope ["#DEFINE#" ++ dtype] + rexpr <- resolveGeneralString rname + pushDependency (dtype, rexpr) -- add variables mparams <- fmap Map.fromList $ mapM (\(gs, gv) -> do { rgs <- resolveGeneralString gs; rgv <- tryResolveGeneralValue gv; return (rgs, (rgv, dpos)); }) (Map.toList rparams) - let expr = gs2gv rname + let expr = Right (ResolvedString rexpr) defineparamset = Set.fromList $ map fst args mandatoryparams = Set.fromList $ map fst $ filter (isNothing . snd) args resourceparamset = Map.keysSet mparams @@ -427,6 +497,7 @@ -- parse statements res <- mapM evaluateStatements dstmts nres <- handleDelayedActions (concat res) + popDependency popScope return nres in do @@ -454,12 +525,14 @@ srname <- case grname of Right e -> do rse <- rstring e - addDefinedResource (rtype, rse) + getPos >>= addDefinedResource (rtype, rse) return $ Right rse Left e -> return $ Left e let (realparams, relations) = partitionParamsRelations rparameters -- push all the relations - addUnresRel (relations, (rtype, srname), UNormal, position) + (curdeptype, curdepname) <- fmap (head . currentDependencyStack) get + let defaultdependency = (RRequire, Right (ResolvedString curdeptype), Right (ResolvedString curdepname)) + addUnresRel (defaultdependency : relations, (rtype, srname), UNormal, position) return [CResource resid srname rtype realparams virtuality position] -- node @@ -572,6 +645,8 @@ if isloaded then return [] else do + oldpos <- getPos -- saves where we were at class declaration so that we known were the class was included + addDefinedResource ("class",classname) oldpos -- detection of spurious parameters let classparamset = Set.fromList $ map fst parameters inputparamset = Set.filter (\x -> getRelationParameterType (Right x) == Nothing) $ Map.keysSet inputparams @@ -579,8 +654,8 @@ unless (Set.null overparams) (throwError $ "Spurious parameters " ++ intercalate ", " (Set.toList overparams) ++ " at " ++ show position) resid <- getNextId -- get this resource id, for the dummy class that will be used to handle relations - oldpos <- getPos -- saves where we were at class declaration so that we known were the class was included setPos position + pushDependency ("class",classname) case actualname of Nothing -> pushScope [classname] -- sets the scope Just ac -> pushScope [classname, ac] @@ -606,6 +681,7 @@ -- this is probably not puppet perfect with resources that -- depend explicitely on a class popScope + popDependency return $ [CResource resid (Right classname) "class" Map.empty Normal position] ++ inherited @@ -914,7 +990,7 @@ Nothing -> liftM (Right . ResolvedBool . Map.member typeorclass . curClasses) get Right (ResolvedRReference rtype (ResolvedString rname)) -> do defset <- fmap definedResources get - return $ Right $ ResolvedBool (Set.member (rtype, rname) defset) + return $ Right $ ResolvedBool (Map.member (rtype, rname) defset) Right x -> throwPosError $ "Can't know if this could be defined : " ++ show x tryResolveValue n@(FunctionCall "regsubst" [str, src, dst, flags]) = do rstr <- tryResolveExpressionString str @@ -1133,10 +1209,6 @@ resolveGeneralString :: GeneralString -> CatalogMonad String resolveGeneralString (Right x) = return x resolveGeneralString (Left y) = resolveExpressionString y - -gs2gv :: GeneralString -> GeneralValue -gs2gv (Left e) = Left e -gs2gv (Right s) = Right $ ResolvedString s collectionFunction :: Virtuality -> String -> Expression -> CatalogMonad (CResource -> CatalogMonad Bool, Maybe PDB.Query) collectionFunction virt mrtype exprs = do diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -28,6 +28,7 @@ -- | Relationship link type. data LinkType = RNotify | RRequire | RBefore | RSubscribe deriving(Show, Ord, Eq) +type LinkInfo = (LinkType, RelUpdateType, SourcePos) -- | The list of resolved values that are used to define everything in a -- 'FinalCatalog' and in the resolved parts of a 'Catalog'. They are to be @@ -59,12 +60,12 @@ data structure by the interpreter. -} data CResource = CResource { - crid :: Int, -- ^ Resource ID, used in the Puppet YAML. - crname :: GeneralString, -- ^ Resource name. - crtype :: String, -- ^ Resource type. - crparams :: Map.Map GeneralString GeneralValue, -- ^ Resource parameters. - crvirtuality :: Virtuality, -- ^ Resource virtuality. - pos :: SourcePos -- ^ Source code position of the resource definition. + crid :: !Int, -- ^ Resource ID, used in the Puppet YAML. + crname :: !GeneralString, -- ^ Resource name. + crtype :: !String, -- ^ Resource type. + crparams :: !(Map.Map GeneralString GeneralValue), -- ^ Resource parameters. + crvirtuality :: !Virtuality, -- ^ Resource virtuality. + pos :: !SourcePos -- ^ Source code position of the resource definition. } deriving(Show) -- | Resource identifier, made of a type, name pair. @@ -147,17 +148,22 @@ -- a query, and returns a resolved value from puppetDB. luaState :: Maybe Lua.LuaState, -- ^ The Lua state, used for user supplied content. - userFunctions :: Set.Set String, + userFunctions :: !(Set.Set String), -- ^ The list of registered user functions - nativeTypes :: Map.Map PuppetTypeName PuppetTypeMethods, + nativeTypes :: !(Map.Map PuppetTypeName PuppetTypeMethods), -- ^ The list of native types. - definedResources :: Set.Set (String, String) + definedResources :: !(Map.Map ResIdentifier SourcePos), -- ^ Horrible hack to kind of support the "defined" function + currentDependencyStack :: [ResIdentifier] } -- | The monad all the interpreter lives in. It is 'ErrorT' with a state. type CatalogMonad = ErrorT String (StateT ScopeState IO) +-- | This is the map of all edges associated with the 'FinalCatalog'. +-- The key is (source, target). +type EdgeMap = Map.Map (ResIdentifier, ResIdentifier) LinkInfo + generalizeValueE :: Expression -> GeneralValue generalizeValueE = Left generalizeValueR :: ResolvedValue -> GeneralValue @@ -172,6 +178,7 @@ getPos = liftM curPos get modifyScope f sc = sc { curScope = f $ curScope sc } +modifyDeps f sc = sc { currentDependencyStack = f $ currentDependencyStack sc } modifyVariables f sc = sc { curVariables = f $ curVariables sc } modifyClasses f sc = sc { curClasses = f $ curClasses sc } incrementResId sc = sc { curResId = curResId sc + 1 } @@ -179,7 +186,7 @@ pushWarning t sc = sc { getWarnings = getWarnings sc ++ [t] } pushCollect r sc = sc { curCollect = r : curCollect sc } pushUnresRel r sc = sc { unresolvedRels = r : unresolvedRels sc } -addDefinedResource r = modify (\st -> st { definedResources = Set.insert r (definedResources st) } ) +addDefinedResource r p = modify (\st -> st { definedResources = Map.insert r p (definedResources st) } ) saveVariables vars = modify (\st -> st { curVariables = vars }) throwPosError :: String -> CatalogMonad a diff --git a/Puppet/Printers.hs b/Puppet/Printers.hs --- a/Puppet/Printers.hs +++ b/Puppet/Printers.hs @@ -3,6 +3,7 @@ , showRRes , showFCatalog , showValue + , showRRef ) where import Puppet.Interpreter.Types @@ -22,17 +23,20 @@ -- helpers commasep :: [String] -> String -commasep = intercalate ", " +commasep = intercalate ", " commaretsep :: [String] -> String -commaretsep = intercalate ",\n" +commaretsep = intercalate ",\n" +showRRef :: ResIdentifier -> String +showRRef (rt, rn) = rt ++ "[" ++ rn ++ "]" + showValue :: ResolvedValue -> String showValue (ResolvedString x) = show x showValue (ResolvedInt x) = show x showValue (ResolvedDouble x) = show x showValue (ResolvedBool True) = "true" showValue (ResolvedBool False) = "false" -showValue (ResolvedRReference rt rn) = rt ++ "[" ++ showValue rn ++ "]" +showValue (ResolvedRReference rt rn) = showRRef (rt, showValue rn) showValue (ResolvedArray ar) = "[" ++ commasep (map showValue ar) ++ "]" showValue (ResolvedHash h) = "{" ++ commasep (map (\(k,v) -> k ++ " => " ++ showValue v) h) ++ "}" showValue (ResolvedRegexp r) = "/" ++ r ++ "/" @@ -42,14 +46,17 @@ showuniqueres res = mrtype ++ " {\n" ++ concatMap showrres res ++ "}\n" where showrres (RResource _ rname _ params rels mpos) = - let paramlist = (Map.toList $ Map.delete "title" params) :: [(String, ResolvedValue)] + let relslist = map asparams rels + groupedrels = Map.fromListWith (++) relslist :: Map.Map String [ResolvedValue] + maybeArray (s,[a]) = (s,a) + maybeArray (s, x ) = (s,ResolvedArray x) + paramlist = (Map.toList $ Map.delete "title" params) ++ map maybeArray (Map.toList groupedrels) :: [(String, ResolvedValue)] maxlen = maximum (map (length . fst) paramlist) :: Int in " " ++ show rname ++ ":" ++ " #" ++ show mpos ++ "\n" - ++ commaretsep (map (showparams maxlen) paramlist) - ++ commareqs (null rels || Map.null params) - ++ commaretsep (map showrequire (sort rels)) ++ ";\n" - commareqs c | c = "" - | otherwise = ",\n" + ++ commaretsep (map (showparams maxlen) paramlist) ++ ";\n" showparams mxl (name, val) = " " ++ name ++ replicate (mxl - length name) ' ' ++ " => " ++ showValue val - showrequire (ltype, dst) = " " ++ show ltype ++ " " ++ show dst - mrtype = rrtype (head res) + asparams (RBefore, (dtype, dname)) = ("before", [ResolvedRReference dtype (ResolvedString dname)]) + asparams (RNotify, (dtype, dname)) = ("notify", [ResolvedRReference dtype (ResolvedString dname)]) + asparams (RSubscribe, (dtype, dname)) = ("subscribe", [ResolvedRReference dtype (ResolvedString dname)]) + asparams (RRequire, (dtype, dname)) = ("require", [ResolvedRReference dtype (ResolvedString dname)]) + mrtype = rrtype (head res) diff --git a/Puppet/Stats.hs b/Puppet/Stats.hs --- a/Puppet/Stats.hs +++ b/Puppet/Stats.hs @@ -24,15 +24,15 @@ measure :: MStats -> String -> IO a -> IO a measure mtable statsname action = do (tm, out) <- time action - stats <- takeMVar mtable :: IO StatsTable + !stats <- takeMVar mtable :: IO StatsTable let nstats :: StatsTable - nstats = case Map.lookup statsname stats of + !nstats = case Map.lookup statsname stats of Nothing -> Map.insert statsname (StatsPoint 1 tm tm tm) stats Just (StatsPoint sc st smi sma) -> - let nmax = if tm > sma + let !nmax = if tm > sma then tm else sma - nmin = if tm < smi + !nmin = if tm < smi then tm else smi in Map.insert statsname (StatsPoint (sc+1) (st+tm) nmin nmax) stats @@ -48,7 +48,7 @@ time :: IO a -> IO (Double, a) time act = do start <- getTime - result <- act + !result <- act end <- getTime let !delta = end - start return (delta, result) diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.2.2.0 +Version: 0.3.0.0 -- A short (one-line) description of the package. Synopsis: Tools to parse and evaluate the Puppet DSL.