diff --git a/Puppet/Interpreter/Catalog.hs b/Puppet/Interpreter/Catalog.hs --- a/Puppet/Interpreter/Catalog.hs +++ b/Puppet/Interpreter/Catalog.hs @@ -6,10 +6,10 @@ Here is a list of known discrepencies with Puppet : -* Variables coming from an inherited class can only be referenced using the -scope of the child class. - * Resources references using the <| |> syntax are not yet supported. + +* Things defined in classes that are not included cannot be accessed. In vanilla +puppet, you can use subclass to classes that are not imported themselves. -} module Puppet.Interpreter.Catalog ( getCatalog @@ -29,15 +29,27 @@ import Text.Parsec.Pos import Control.Monad.State import Control.Monad.Error +import GHC.Exts import qualified Data.Map as Map import qualified Data.Set as Set +-- Utility function used to check if the there are duplicates a in [(a,_)] +checkDuplicateFirst :: (Show a, Eq a) => [(a,b)] -> CatalogMonad () +checkDuplicateFirst list = + let fsts = ldups (map fst list) [] + ldups [] a = a + ldups (x:xs) a | x `elem` xs = x:a + | otherwise = ldups xs a + in unless (null fsts) $ throwPosError $ "Duplicate parameters " ++ show fsts + + qualified [] = False qualified str = isPrefixOf "::" str || qualified (tail str) throwPosError msg = do p <- getPos - throwError (msg ++ " at " ++ show p) + st <- liftIO currentCallStack + throwError (msg ++ " at " ++ show p ++ intercalate "\n\t" st ) -- Int handling stuff isInt :: String -> Bool @@ -91,6 +103,7 @@ setPos cpos rname <- resolveGeneralString cname rparams <- mapM (\(a,b) -> do { ra <- resolveGeneralString a; rb <- resolveGeneralValue b; return (ra,rb); }) cparams + checkDuplicateFirst rparams -- add collected relations -- TODO unless (Map.member ctype nativeTypes) $ throwPosError $ "Can't find native type " ++ ctype @@ -186,7 +199,8 @@ curscope = head $ head (curScope curstate) nname = qualify rname curscope nstatement = case rstatement of - DefineDeclaration _ prms stms cpos -> DefineDeclaration nname prms stms cpos + DefineDeclaration _ prms stms cpos -> DefineDeclaration nname prms stms cpos + ClassDeclaration _ inhe prms stms cpos -> ClassDeclaration nname inhe prms stms cpos x -> x ntop = Map.insert (rtype, nname) nstatement ctop nstate = curstate { nestedtoplevels = ntop } @@ -284,31 +298,36 @@ -- The actual meat evaluateDefine :: CResource -> CatalogMonad [CResource] -evaluateDefine r@(CResource _ rname rtype rparams rvirtuality rpos) = do +evaluateDefine r@(CResource _ rname rtype rparams rvirtuality rpos) = let + evaluateDefineDeclaration dtype args dstmts dpos = do + --oldpos <- getPos + setPos dpos + pushScope ["#DEFINE#" ++ dtype] + -- add variables + mrrparams <- mapM (\(gs, gv) -> do { rgs <- resolveGeneralString gs; rgv <- tryResolveGeneralValue gv; return (rgs, (rgv, dpos)); }) rparams + let expr = gs2gv rname + mparams = Map.fromList mrrparams + putVariable "title" (expr, rpos) + putVariable "name" (expr, rpos) + mapM_ (loadClassVariable rpos mparams) args + + -- parse statements + res <- mapM evaluateStatements dstmts + nres <- handleDelayedActions (concat res) + popScope + return nres + in do setPos rpos isdef <- checkDefine rtype case (rvirtuality, isdef) of - (Normal, Just (DefineDeclaration dtype args dstmts dpos)) -> do - --oldpos <- getPos - setPos dpos - pushScope ["#DEFINE#" ++ dtype] - -- add variables - mrrparams <- mapM (\(gs, gv) -> do { rgs <- resolveGeneralString gs; rgv <- tryResolveGeneralValue gv; return (rgs, (rgv, dpos)); }) rparams - let expr = gs2gv rname - mparams = Map.fromList mrrparams - putVariable "title" (expr, rpos) - putVariable "name" (expr, rpos) - mapM_ (loadClassVariable rpos mparams) args - - -- parse statements - res <- mapM evaluateStatements dstmts - nres <- handleDelayedActions (concat res) - popScope - return nres + (Normal, Just (TopContainer topstmts (DefineDeclaration dtype args dstmts dpos))) -> do + mapM_ (\(n,x) -> evaluateClass x Map.empty (Just n)) topstmts + evaluateDefineDeclaration dtype args dstmts dpos + (Normal, Just (DefineDeclaration dtype args dstmts dpos)) -> evaluateDefineDeclaration dtype args dstmts dpos _ -> return [r] --- handling delayed actions (such as defaults) +-- handling delayed actions (such as defaults and define resolution) handleDelayedActions :: Catalog -> CatalogMonad Catalog handleDelayedActions res = do dres <- liftM concat (mapM applyDefaults res >>= mapM evaluateDefine) @@ -336,8 +355,10 @@ handleDelayedActions (concat res) -- include -evaluateStatements (Include includename position) = setPos position >> getstatement TopClass includename >>= evaluateStatements -evaluateStatements x@(ClassDeclaration{}) = evaluateClass x Map.empty Nothing +evaluateStatements (Include includename position) = setPos position >> getstatement TopClass includename >>= \st -> evaluateClass st Map.empty Nothing +evaluateStatements x@(ClassDeclaration cname _ _ _ _) = do + addNestedTopLevel TopClass cname x + return [] evaluateStatements n@(DefineDeclaration dtype _ _ _) = do addNestedTopLevel TopDefine dtype n return [] @@ -354,6 +375,7 @@ -- checks whether we are handling a parametrized class "class" -> do rparameters <- mapM (\(a,b) -> do { pa <- resolveExpressionString a; pb <- tryResolveExpression b; return (pa, pb) } ) parameters + checkDuplicateFirst rparameters classname <- resolveExpressionString rname topstatement <- getstatement TopClass classname let classparameters = Map.fromList $ map (\(pname, pvalue) -> (pname, (pvalue, position))) rparameters @@ -437,7 +459,7 @@ -- 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 + overparams = Set.difference inputparamset (Set.union metaparameters 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 @@ -654,7 +676,17 @@ then return $ Right $ ResolvedArray $ rights resolvedExpressions else return $ Left $ Value n --- TODO + +tryResolveValue (FunctionCall "generate" args) = if null args + then throwPosError "Empty argument list in generate" + else do + nargs <- mapM resolveExpressionString args + let cmdname:cmdargs = nargs + gens <- liftIO $ generate cmdname cmdargs + case gens of + Just w -> return $ Right $ ResolvedString w + Nothing -> throwPosError $ "Function call generate for command " ++ cmdname ++ " (" ++ show cmdargs ++ ") failed" + tryResolveValue (FunctionCall "fqdn_rand" args) = if null args then throwPosError "Empty argument list in fqdn_rand call" else do @@ -798,6 +830,24 @@ ) prestatements liftM concat (mapM evaluateStatements resources) executeFunction "create_resources" x = throwPosError ("Bad arguments to create_resources: " ++ show x) +executeFunction "validate_array" [x] = case x of + ResolvedArray _ -> return [] + y -> throwPosError $ show y ++ " is not an array" +executeFunction "validate_hash" [x] = case x of + ResolvedHash _ -> return [] + y -> throwPosError $ show y ++ " is not a hash" +executeFunction "validate_string" [x] = case x of + ResolvedString _ -> return [] + y -> throwPosError $ show y ++ " is not an string" +executeFunction "validate_re" [x,re] = case (x,re) of + (ResolvedString z, ResolvedString rre) -> do + if (regmatch z rre) + then return [] + else throwPosError $ show x ++ " is does not match the regexp" + (y,z) -> throwPosError $ "Can't compare " ++ show y ++ " to regexp " ++ show z +executeFunction "validate_bool" [x] = case x of + ResolvedBool _ -> return [] + y -> throwPosError $ show y ++ " is not a boolean" executeFunction a b = do position <- getPos addWarning $ "Function " ++ a ++ "(" ++ show b ++ ") not handled at " ++ show position @@ -840,13 +890,16 @@ 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 - Right (ResolvedInt _) -> return $ Right $ ResolvedBool True - Right ResolvedUndefined -> return $ Right $ ResolvedBool False + Left BFalse -> return $ Right $ ResolvedBool False + Left BTrue -> return $ Right $ ResolvedBool True + Right (ResolvedString "") -> return $ Right $ ResolvedBool False + Right (ResolvedString "false") -> return $ Right $ ResolvedBool False + Right (ResolvedString _) -> return $ Right $ ResolvedBool True + Right (ResolvedInt 0) -> return $ Right $ ResolvedBool False + Right (ResolvedInt _) -> return $ Right $ ResolvedBool True + Right ResolvedUndefined -> return $ Right $ ResolvedBool False + Right (ResolvedArray []) -> return $ Right $ ResolvedBool False + Right (ResolvedArray _) -> return $ Right $ ResolvedBool True Left (Value (VariableReference _)) -> return $ Right $ ResolvedBool False Left (EqualOperation (Value (VariableReference _)) (Value (Literal ""))) -> return $ Right $ ResolvedBool True -- case where a variable was not resolved and compared to the empty string Left (EqualOperation (Value (VariableReference _)) (Value (Literal "true"))) -> return $ Right $ ResolvedBool False -- case where a variable was not resolved and compared to the string "true" @@ -885,7 +938,7 @@ Nothing -> throwPosError $ "Unknown type " ++ mrtype ++ " when trying to collect" Just (DefineDeclaration _ params _ _) -> return $ Set.fromList $ map fst params Just x -> throwPosError $ "Expected a DefineDeclaration here instead of " ++ show x - when (Set.notMember paramname paramset && (paramname /= "tag")) $ + when (Set.notMember paramname paramset && (not $ Set.member paramname metaparameters)) $ throwPosError $ "Parameter " ++ paramname ++ " is not a valid parameter. It should be in : " ++ show (Set.toList paramset) return (\r -> do let param = filter (\x -> fst x == Right paramname) (crparams r) diff --git a/Puppet/Interpreter/Functions.hs b/Puppet/Interpreter/Functions.hs --- a/Puppet/Interpreter/Functions.hs +++ b/Puppet/Interpreter/Functions.hs @@ -8,6 +8,7 @@ ,puppetSplit ,puppetSHA1 ,puppetMD5 + ,generate ) where import Data.Hash.MD5 @@ -19,6 +20,7 @@ import Control.Monad.Error import System.IO import qualified Data.ByteString.Base16 as B16 +import SafeProcess puppetMD5 = md5s . Str puppetSHA1 = BS.unpack . B16.encode . SHA1.hash . BS.pack @@ -71,3 +73,10 @@ puppetSplit :: String -> String -> [String] puppetSplit str reg = splitRegexPR reg str + +generate :: String -> [String] -> IO (Maybe String) +generate command args = do + cmdout <- safeReadProcessTimeout command args "" 60000 + case cmdout of + Just (Right x) -> return $ Just x + _ -> return Nothing diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -5,6 +5,7 @@ import Control.Monad.State import Control.Monad.Error import qualified Data.Map as Map +import qualified Data.Set as Set -- | This is the potentially unsolved list of resources in the catalog. type Catalog =[CResource] @@ -137,4 +138,7 @@ generalizeStringE = Left generalizeStringS :: String -> GeneralString generalizeStringS = Right + +-- |This is the set of meta parameters +metaparameters = Set.fromList ["tag","stage","name","title"] diff --git a/Puppet/NativeTypes/Helpers.hs b/Puppet/NativeTypes/Helpers.hs --- a/Puppet/NativeTypes/Helpers.hs +++ b/Puppet/NativeTypes/Helpers.hs @@ -29,7 +29,7 @@ defaultValidate :: Set.Set String -> PuppetTypeValidate defaultValidate validparameters = checkParameterList validparameters >=> addDefaults --- | This validator checks that no unknown parameters have been set (except tag) +-- | This validator checks that no unknown parameters have been set (except metaparameters) checkParameterList :: Set.Set String -> PuppetTypeValidate checkParameterList validparameters res | Set.null validparameters = Right res | otherwise = if Set.null setdiff @@ -37,14 +37,14 @@ else Left $ "Unknown parameters " ++ show (Set.toList setdiff) where keyset = Map.keysSet (rrparams res) - setdiff = Set.difference keyset (Set.insert "tag" validparameters) + setdiff = Set.difference keyset (Set.union metaparameters validparameters) -- | This validator always accept the resources, but add the default parameters -- (such as title and name). addDefaults :: PuppetTypeValidate addDefaults res = Right (res { rrparams = newparams } ) where - newparams = Map.filter (/= ResolvedUndefined) $ Map.union defaults (rrparams res) + newparams = Map.filter (/= ResolvedUndefined) $ Map.union (rrparams res) defaults defaults = Map.fromList [("name", nm),("title", nm)] nm = ResolvedString $ rrname res 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.5 +Version: 0.1.6 -- A short (one-line) description of the package. Synopsis: Tools to parse and evaluate the Puppet DSL.