diff --git a/Puppet/Daemon.hs b/Puppet/Daemon.hs --- a/Puppet/Daemon.hs +++ b/Puppet/Daemon.hs @@ -208,18 +208,24 @@ Just (_,_,x) -> return x Nothing -> throwError ("Could not find correct top level statement for " ++ show qtype ++ " " ++ nodename) - - +{- Given a base file name and an import statement, will load these imports. +This is not as obvious as it seems because you need to load imported's imports. +-} loadImport :: (TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse ) -> FilePath -> Statement -> ErrorT String IO [(TopLevelType, String, Statement)] loadImport updatepinfo fdir mimport = do matched <- globImport fdir mimport - -- globDir [compile importstring] fdir >>= return . concat . fst fileinfos <- liftIO $ mapM getFileInfo matched let fpathinfos = zip matched fileinfos goodpathinfos = concatMap unjust fpathinfos unjust (a, Just b) = [(a,b)] unjust _ = [] - liftM (concatMap snd) (mapM (\(fname, finfo) -> loadUpdateFile fname finfo updatepinfo) goodpathinfos) + ex <- (mapM (\(fname, finfo) -> liftM (\x -> (fname, x)) $ loadUpdateFile fname finfo updatepinfo) goodpathinfos) + -- This is a complicated and very expensive way to load imports that were imported. + -- The only way to make it faster would be to query the cache before reloading the files .. + let reloaded = concatMap (snd . snd) ex + limports = map (\(fname, (mimports, _)) -> (fname, mimports)) ex + mapM_ (\(fname, mimports) -> mapM_ (\stmt -> loadImport updatepinfo fname stmt) mimports) limports + return $ reloaded loadRelated :: ( TopLevelType -> String -> ErrorT String IO (Maybe CacheEntry) ) diff --git a/Puppet/Interpreter/Catalog.hs b/Puppet/Interpreter/Catalog.hs --- a/Puppet/Interpreter/Catalog.hs +++ b/Puppet/Interpreter/Catalog.hs @@ -251,27 +251,24 @@ applyDefaults :: CResource -> CatalogMonad CResource applyDefaults res = liftM curDefaults get >>= foldM applyDefaults' res -applyDefaults' :: CResource -> Statement -> CatalogMonad CResource -applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (ResourceDefault dtype defs dpos) = do +applyDefaults' :: CResource -> ResDefaults -> CatalogMonad CResource +applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (RDefaults dtype rdefs dpos) = do srname <- resolveGeneralString rname - rdefs <- mapM resolveParams defs let (nparams, nrelations) = mergeParams rparams rdefs False if dtype == rtype then do addUnresRel (nrelations, (rtype, Right srname), UDefault, dpos) return $ CResource i rname rtype nparams rvirtuality rpos else return r -applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (ResourceOverride dtype dname defs dpos) = do +applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (ROverride dtype dname rdefs dpos) = do srname <- resolveGeneralString rname - sdname <- resolveExpressionString dname - rdefs <- mapM resolveParams defs + sdname <- resolveGeneralString dname let (nparams, nrelations) = mergeParams rparams rdefs True if (dtype == rtype) && (srname == sdname) then do addUnresRel (nrelations, (rtype, Right srname), UDefault, dpos) return $ CResource i rname rtype nparams rvirtuality rpos else return r -applyDefaults' r d = throwError $ "Can't apply non default statement " ++ show d ++ " to resource " ++ show r -- merge defaults and actual parameters depending on the override flag mergeParams :: [(GeneralString, GeneralValue)] -> [(GeneralString, GeneralValue)] -> Bool -> ([(GeneralString, GeneralValue)], [(LinkType, GeneralValue, GeneralValue)]) @@ -367,11 +364,14 @@ (Right (ResolvedArray arr)) -> fmap concat (mapM (addResource rtype parameters virtuality position . Right) arr) _ -> addResource rtype parameters virtuality position srname -evaluateStatements x@(ResourceDefault{}) = do - pushDefaults x +evaluateStatements (ResourceDefault rdtype rdparams rdpos) = do + rrdparams <- mapM resolveParams rdparams + pushDefaults $ RDefaults rdtype rrdparams rdpos return [] -evaluateStatements x@(ResourceOverride{}) = do - pushDefaults x +evaluateStatements (ResourceOverride rotype roname roparams ropos) = do + rroname <- tryResolveExpressionString roname + rroparams <- mapM resolveParams roparams + pushDefaults $ ROverride rotype rroname rroparams ropos return [] evaluateStatements (DependenceChain (srctype, srcname) (dsttype, dstname) position) = do setPos position @@ -434,6 +434,12 @@ if isloaded then return [] else do + -- detection of spurious parameters + let classparamset = Set.fromList $ map fst parameters + inputparamset = Set.filter (\x -> getRelationParameterType (Right x) == Nothing) $ Map.keysSet inputparams + overparams = Set.difference inputparamset classparamset + 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 @@ -624,7 +630,7 @@ if null matching then do position <- getPos - addWarning ("Could not resolveValue " ++ show varnames ++ " at " ++ show position) + addWarning ("Could not resolveValue variables " ++ show varnames ++ " at " ++ show position) return $ Left $ Value $ VariableReference (head varnames) else return $ case head matching of (x,_) -> x @@ -749,7 +755,7 @@ case r of Right (ResolvedString v) -> return $ Right v Right (ResolvedInt i) -> return $ Right (show i) - Right v -> throwError ("Can't resolve valuestring for " ++ show v) + Right v -> throwPosError ("Can't resolve valuestring for " ++ show v) Left v -> return $ Left v getRelationParameterType :: GeneralString -> Maybe LinkType @@ -834,6 +840,8 @@ tryResolveBoolean v = do rv <- tryResolveGeneralValue v case rv of + Left BFalse -> return $ Right $ ResolvedBool False + Left BTrue -> return $ Right $ ResolvedBool True Right (ResolvedString "") -> return $ Right $ ResolvedBool False Right (ResolvedString _) -> return $ Right $ ResolvedBool True Right (ResolvedInt 0) -> return $ Right $ ResolvedBool False diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -78,6 +78,12 @@ -- many fairly acceptable behaviours and the correct one is not documented. data RelUpdateType = UNormal | UOverride | UDefault | UPlus deriving (Show, Ord, Eq) +{-| A data type to hold defaults values + -} +data ResDefaults = RDefaults String [(GeneralString, GeneralValue)] SourcePos + | ROverride String GeneralString [(GeneralString, GeneralValue)] SourcePos + deriving (Show, Ord, Eq) + {-| The most important data structure for the interpreter. It stores its internal state. -} @@ -94,7 +100,7 @@ curClasses :: !(Map.Map String SourcePos), -- ^ The list of classes that have already been included, along with the -- place where this happened. - curDefaults :: ![Statement], + curDefaults :: ![ResDefaults], -- ^ List of defaults to apply. All defaults are applied at the end of the -- interpretation of each top level statement. curResId :: !Int, -- ^ Stores the value of the current 'crid'. 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.1.4 +Version: 0.1.5 -- A short (one-line) description of the package. Synopsis: Tools to parse and evaluate the Puppet DSL. @@ -27,6 +27,8 @@ -- An email address to which users can send suggestions, bug reports, -- and patches. Maintainer: bartavelle@gmail.com + +Homepage: http://lpuppet.banquise.net -- A copyright notice. -- Copyright: