language-puppet 0.1.5 → 0.1.6
raw patch · 5 files changed
+106/−40 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Puppet.Interpreter.Types: metaparameters :: Set [Char]
Files
- Puppet/Interpreter/Catalog.hs +89/−36
- Puppet/Interpreter/Functions.hs +9/−0
- Puppet/Interpreter/Types.hs +4/−0
- Puppet/NativeTypes/Helpers.hs +3/−3
- language-puppet.cabal +1/−1
Puppet/Interpreter/Catalog.hs view
@@ -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)
Puppet/Interpreter/Functions.hs view
@@ -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
Puppet/Interpreter/Types.hs view
@@ -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"]
Puppet/NativeTypes/Helpers.hs view
@@ -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
language-puppet.cabal view
@@ -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.