language-puppet 0.1.6 → 0.1.7
raw patch · 16 files changed
+480/−81 lines, 16 filesdep +regex-pcre-builtin
Dependencies added: regex-pcre-builtin
Files
- Erb/Evaluate.hs +4/−5
- Erb/Parser.hs +10/−7
- Puppet/DSL/Parser.hs +13/−17
- Puppet/Interpreter/Catalog.hs +55/−21
- Puppet/Interpreter/Functions.hs +32/−7
- Puppet/Interpreter/Types.hs +2/−2
- Puppet/NativeTypes.hs +16/−2
- Puppet/NativeTypes/Cron.hs +64/−0
- Puppet/NativeTypes/Exec.hs +33/−0
- Puppet/NativeTypes/File.hs +3/−3
- Puppet/NativeTypes/Group.hs +27/−0
- Puppet/NativeTypes/Helpers.hs +99/−12
- Puppet/NativeTypes/Host.hs +49/−0
- Puppet/NativeTypes/Mount.hs +27/−0
- Puppet/NativeTypes/ZoneRecord.hs +39/−0
- language-puppet.cabal +7/−5
Erb/Evaluate.hs view
@@ -40,14 +40,13 @@ getVariable :: Map.Map String GeneralValue -> String -> String -> Either String ResolvedValue getVariable mp ctx rvname =- let vars = map (\x -> Map.lookup x mp) [rvname, ctx ++ "::" ++ rvname, "::" ++ rvname]- jsts = catMaybes vars+ let vars = map (\x -> Map.lookup x mp) [rvname, ctx ++ "::" ++ rvname, "::" ++ rvname]+ jsts = catMaybes vars rghts = rights jsts in do- when (null jsts) (throwError $ "Can't resolve variable " ++ rvname)- when (null rghts) (throwError $ "Variable " ++ rvname ++ " value is not resolved")+ when (null jsts) (throwError $ "ERB: can't resolve variable " ++ rvname)+ when (null rghts) (throwError $ "ERB: variable " ++ rvname ++ " value is not resolved") return (head rghts)- evalValue :: GeneralValue -> Either String String evalValue (Left _) = Left $ "Can't evaluate a value"
Erb/Parser.hs view
@@ -76,22 +76,25 @@ rubystatement = rubyexpression >>= return . Puts -textblock :: Parser [RubyStatement]-textblock = do+textblockW :: Maybe Char -> Parser [RubyStatement]+textblockW c = do s <- many (noneOf "<")- let returned = Puts $ Value $ Literal s+ let ns = case c of+ Just x -> x:s+ Nothing -> s+ returned = Puts $ Value $ Literal ns isend <- optionMaybe eof case isend of Just _ -> return [returned] Nothing -> do char '<' isrub <- optionMaybe (char '%')- let nextrun = case isrub of- Just _ -> rubyblock- Nothing -> textblock- n <- nextrun+ n <- case isrub of+ Just _ -> rubyblock+ Nothing -> textblockW (Just '<') return (returned : n) +textblock = textblockW Nothing rubyblock :: Parser [RubyStatement] rubyblock = do
Puppet/DSL/Parser.hs view
@@ -34,7 +34,7 @@ , P.reservedNames = ["if", "else", "case", "elsif", "and", "or", "in", "import", "include", "define", "require", "class", "node"] , P.reservedOpNames= ["=>","=","+","-","/","*","+>","->","~>","!"] , P.caseSensitive = True- } + } lexer = P.makeTokenParser def parens = P.parens lexer@@ -48,13 +48,13 @@ naturalOrFloat = P.naturalOrFloat lexer lowerFirstChar :: String -> String-lowerFirstChar x = [toLower $ head x] ++ (tail x)+lowerFirstChar x = toLower (head x) : tail x -- expression parser {-| This is a parser for Puppet 'Expression's. -} exprparser = buildExpressionParser table term <?> "expression"- -table = [ ++table = [ [ Infix ( reservedOp "?" >> return ConditionalValue ) AssocLeft ] , [ Prefix ( symbol "-" >> return NegOperation ) ] , [ Prefix ( symbol "!" >> return NotOperation ) ]@@ -104,9 +104,7 @@ } makeLookupOperation :: String -> [Expression] -> Expression-makeLookupOperation name exprs = foldl lookups (LookupOperation (Value (VariableReference name)) (head exprs)) (tail exprs)- where- lookups ctx v = LookupOperation ctx v+makeLookupOperation name exprs = foldl LookupOperation (LookupOperation (Value (VariableReference name)) (head exprs)) (tail exprs) identstring = many1 (alphaNum <|> oneOf "-_") @@ -118,20 +116,20 @@ puppetResourceReference = do { rtype <- puppetQualifiedReference ; symbol "["- ; rnames <- exprparser `sepBy` (symbol ",")+ ; rnames <- exprparser `sepBy` symbol "," ; symbol "]" ; if length rnames == 1 then return $ Value (ResourceReference rtype (head rnames))- else return $ Value $ PuppetArray $ map (\rname -> Value $ ResourceReference rtype rname) rnames+ else return $ Value $ PuppetArray $ map (Value . ResourceReference rtype) rnames } puppetResourceOverride = do { pos <- getPosition ; rtype <- puppetQualifiedReference ; symbol "["- ; rname <- exprparser `sepBy` (symbol ",")+ ; rname <- exprparser `sepBy` symbol "," ; symbol "]" ; symbol "{"- ; e <- puppetAssignment `sepEndBy` (symbol ",")+ ; e <- puppetAssignment `sepEndBy` symbol "," ; symbol "}" ; return (map (\n -> ResourceOverride rtype n e pos) rname) }@@ -185,7 +183,7 @@ ; return $ Value (PuppetHash (Parameters e)) } -puppetAssignment = do { n <- puppetRegexpExpr <|> puppetVariableOrHashLookup <|> puppetLiteralValue+puppetAssignment = do { n <- exprparser ; symbol "=>" ; v <- exprparser ; return $ (n, v)@@ -288,7 +286,7 @@ puppetNumeric = do { v <- naturalOrFloat ; return (case v of- Left x -> (Value . Integer) x + Left x -> (Value . Integer) x Right x -> (Value . Double) x ) }@@ -307,7 +305,6 @@ "@" -> return $ map (\(rname, rvalues, pos) -> (Resource v rname rvalues Virtual pos)) (concat x) "@@" -> return $ map (\(rname, rvalues, pos) -> (Resource v rname rvalues Exported pos)) (concat x) _ -> unexpected "Too many @'s"- -- todo parse resource collection properly puppetResourceCollection = do { pos <- getPosition@@ -387,7 +384,6 @@ ; symbol "}" ; return [DefineDeclaration cname params (concat st) pos] }- puppetIfStyleCondition = do { cond <- exprparser <?> "Conditional expression" ; symbol "{"@@ -395,7 +391,7 @@ ; symbol "}" ; return (cond, concat e) }- + puppetElseIfCondition = do { reservedOp "elsif" ; whiteSpace ; out <- puppetIfStyleCondition@@ -419,7 +415,7 @@ ; return [ConditionalStatement ([maincond] ++ others ++ [(BTrue, elsec)]) pos] } -puppetCase = do { +puppetCase = do { compares <- exprparser `sepBy` symbol "," ; symbol ":" ; symbol "{"
Puppet/Interpreter/Catalog.hs view
@@ -21,8 +21,9 @@ import Puppet.Interpreter.Functions import Puppet.Interpreter.Types +import System.IO.Unsafe import Data.List-import Data.Char (isDigit,toLower,toUpper)+import Data.Char (isDigit,toLower,toUpper, isAlpha, isAlphaNum) import Data.Maybe (isJust, fromJust, catMaybes) import Data.Either (lefts, rights, partitionEithers) import Data.Ord (comparing)@@ -531,16 +532,24 @@ tryResolveGeneralValue n@(Left (DifferentOperation a b)) = compareGeneralValue n a b [LT,GT] tryResolveGeneralValue n@(Left (OrOperation a b)) = do ra <- tryResolveBoolean $ Left a- rb <- tryResolveBoolean $ Left b- case (ra, rb) of- (Right (ResolvedBool rra), Right (ResolvedBool rrb)) -> return $ Right $ ResolvedBool $ rra || rrb- _ -> return n+ if( ra == Right (ResolvedBool True) )+ then return $ Right $ ResolvedBool True+ else do+ rb <- tryResolveBoolean $ Left b+ case (ra, rb) of+ (_, Right (ResolvedBool True)) -> return $ Right $ ResolvedBool True+ (Right (ResolvedBool rra), Right (ResolvedBool rrb)) -> return $ Right $ ResolvedBool $ rra || rrb+ _ -> return n tryResolveGeneralValue n@(Left (AndOperation a b)) = do ra <- tryResolveBoolean $ Left a- rb <- tryResolveBoolean $ Left b- case (ra, rb) of- (Right (ResolvedBool rra), Right (ResolvedBool rrb)) -> return $ Right $ ResolvedBool $ rra && rrb- _ -> return n+ if( ra == Right (ResolvedBool False) )+ then return $ Right $ ResolvedBool False+ else do+ rb <- tryResolveBoolean $ Left b+ case (ra, rb) of+ (_, Right (ResolvedBool False)) -> return $ Right $ ResolvedBool False+ (Right (ResolvedBool rra), Right (ResolvedBool rrb)) -> return $ Right $ ResolvedBool $ rra && rrb+ _ -> return n tryResolveGeneralValue (Left (NotOperation x)) = do rx <- tryResolveBoolean $ Left x case rx of@@ -559,7 +568,7 @@ (Right (ResolvedHash ar), Right idx) -> do let filtered = filter (\(x,_) -> x == idx) ar case filtered of- [] -> throwError "TODO empty filtered"+ [] -> return $ Right ResolvedUndefined [(_,x)] -> return $ Right x x -> throwPosError ("Hum, WTF tryResolveGeneralValue " ++ show x) (_, Left y) -> throwPosError ("Could not resolve index " ++ show y)@@ -580,7 +589,7 @@ tryResolveGeneralValue o@(Left (MinusOperation a b)) = arithmeticOperation a b (-) (-) o tryResolveGeneralValue o@(Left (DivOperation a b)) = arithmeticOperation a b div (/) o tryResolveGeneralValue o@(Left (MultiplyOperation a b)) = arithmeticOperation a b (*) (*) o- + tryResolveGeneralValue e = throwPosError ("tryResolveGeneralValue not implemented for " ++ show e) resolveGeneralValue :: GeneralValue -> CatalogMonad ResolvedValue@@ -687,6 +696,23 @@ Just w -> return $ Right $ ResolvedString w Nothing -> throwPosError $ "Function call generate for command " ++ cmdname ++ " (" ++ show cmdargs ++ ") failed" +tryResolveValue n@(FunctionCall "is_domain_name" [x]) = do+ rx <- tryResolveExpressionString x+ case rx of+ Right s -> let+ goodpart gs = (length gs < 64) && (not $ null gs) && (isAlpha $ head gs) && (all (\gx -> (gx=='-') || (isAlphaNum gx)) gs)+ badparts "" = False+ badparts str =+ let (b,e) = break (=='.') str+ in case (goodpart b, null e) of+ (True, False) -> badparts (tail e)+ (True, _) -> False+ (False, _) -> True+ bad = (null s) || (length s > 255) || (badparts s)+ -- TODO check the parts are 63 char long+ in return $ Right $ ResolvedBool $ not bad+ _ -> return $ Left $ Value n+ tryResolveValue (FunctionCall "fqdn_rand" args) = if null args then throwPosError "Empty argument list in fqdn_rand call" else do@@ -748,7 +774,11 @@ rstr <- tryResolveExpressionString str rreg <- tryResolveExpressionString reg case (rstr, rreg) of- (Right sstr, Right sreg) -> return $ Right $ ResolvedArray $ map ResolvedString $ puppetSplit sstr sreg+ (Right sstr, Right sreg) -> do+ sp <- liftIO $ puppetSplit sstr sreg+ case sp of+ Right o -> return $ Right $ ResolvedArray $ map ResolvedString o+ Left r -> throwPosError $ "split error: " ++ show r _ -> return $ Left $ Value n tryResolveValue (FunctionCall "split" _) = throwPosError "Bad argument count for function split" tryResolveValue n@(FunctionCall "upcase" args) = stringTransform args n (map toUpper)@@ -791,11 +821,11 @@ Left v -> return $ Left v getRelationParameterType :: GeneralString -> Maybe LinkType-getRelationParameterType (Right "require" ) = Just RRequire-getRelationParameterType (Right "notify" ) = Just RNotify-getRelationParameterType (Right "before" ) = Just RBefore-getRelationParameterType (Right "register") = Just RRegister-getRelationParameterType _ = Nothing+getRelationParameterType (Right "require" ) = Just RRequire+getRelationParameterType (Right "notify" ) = Just RNotify+getRelationParameterType (Right "before" ) = Just RBefore+getRelationParameterType (Right "subscribe") = Just RSubscribe+getRelationParameterType _ = Nothing -- this function saves a new condition for collection pushRealize :: ResolvedValue -> CatalogMonad ()@@ -841,9 +871,11 @@ 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"+ m <- liftIO $ regmatch z rre+ case m of+ Right True -> return []+ Right False -> throwPosError $ show x ++ " does not match the regexp " ++ show rre+ Left err -> throwPosError $ "Error with regexp " ++ show rre ++ ": " ++ err (y,z) -> throwPosError $ "Can't compare " ++ show y ++ " to regexp " ++ show z executeFunction "validate_bool" [x] = case x of ResolvedBool _ -> return []@@ -878,7 +910,9 @@ compareValues a@(ResolvedString _) b@(ResolvedInt _) = compareValues b a compareValues (ResolvedInt a) (ResolvedString b) | isInt b = compare a (read b) | otherwise = LT-compareValues (ResolvedString a) (ResolvedRegexp b) = if regmatch a b then EQ else LT+compareValues (ResolvedString a) (ResolvedRegexp b) = case (unsafePerformIO $ regmatch a b) of+ Right True -> EQ+ _ -> LT compareValues (ResolvedString a) (ResolvedString b) = comparing (map toLower) a b compareValues x y = compare x y
Puppet/Interpreter/Functions.hs view
@@ -16,6 +16,7 @@ import qualified Data.ByteString.Char8 as BS import Data.String.Utils (join,replace) import Text.RegexPR+import Text.Regex.PCRE.String import Puppet.Interpreter.Types import Control.Monad.Error import System.IO@@ -52,14 +53,20 @@ when extended $ throwError "Extended flag not implemented" when insensitive $ throwError "Case insensitive flag not implemented" return $ refunc (alterregexp src) dst str- alterregexp :: String -> String alterregexp = replace "\\n" "\n" -regmatch :: String -> String -> Bool-regmatch str reg = case matchRegexPR (alterregexp str) reg of- Just _ -> True- Nothing -> False+regmatch :: String -> String -> IO (Either String Bool)+regmatch str reg = do+ icmp <- compile compBlank execBlank reg+ case icmp of+ Right rr -> do+ x <- execute rr str+ case x of+ Right (Just _) -> return $ Right True+ Right Nothing -> return $ Right False+ Left err -> return $ Left $ show err+ Left err -> return $ Left $ show err -- TODO versioncmp :: String -> String -> Integer@@ -71,8 +78,26 @@ file [] = return Nothing file (x:xs) = catch (liftM Just (withFile x ReadMode hGetContents)) (\_ -> file xs) -puppetSplit :: String -> String -> [String]-puppetSplit str reg = splitRegexPR reg str+puppetSplit :: String -> String -> IO (Either String [String])+puppetSplit str reg = do+ icmp <- compile compBlank execBlank reg+ case icmp of+ Right rr -> execSplit rr str+ Left err -> return $ Left $ show err++-- helper for puppetSplit, once the regexp is compiled+execSplit :: Regex -> String -> IO (Either String [String])+execSplit _ "" = return $ Right [""]+execSplit rr str = do+ x <- regexec rr str+ case x of+ Right (Just (before, _, after, _)) -> do+ sx <- execSplit rr after+ case sx of+ Right s -> return $ Right $ before:s+ Left er -> return $ Left $ show er+ Right Nothing -> return $ Right [str]+ Left err -> return $ Left $ show err generate :: String -> [String] -> IO (Maybe String) generate command args = do
Puppet/Interpreter/Types.hs view
@@ -12,7 +12,7 @@ type Facts = Map.Map String ResolvedValue -- | Relationship link type.-data LinkType = RNotify | RRequire | RBefore | RRegister deriving(Show, Ord, Eq)+data LinkType = RNotify | RRequire | RBefore | RSubscribe deriving(Show, Ord, Eq) -- | 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@@ -140,5 +140,5 @@ generalizeStringS = Right -- |This is the set of meta parameters-metaparameters = Set.fromList ["tag","stage","name","title"]+metaparameters = Set.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule"]
Puppet/NativeTypes.hs view
@@ -3,12 +3,26 @@ import Puppet.NativeTypes.Helpers import Puppet.NativeTypes.File+import Puppet.NativeTypes.Cron+import Puppet.NativeTypes.Exec+import Puppet.NativeTypes.Group+import Puppet.NativeTypes.Host+import Puppet.NativeTypes.Mount+import Puppet.NativeTypes.ZoneRecord import qualified Data.Map as Map fakeTypes = map faketype ["class", "ssh_authorized_key_secure"] -defaultTypes = map defaulttype ["augeas","computer","cron","exec","filebucket","group","host","interface","k5login","macauthorization","mailalias","maillist","mcx","mount","nagios_command","nagios_contact","nagios_contactgroup","nagios_host","nagios_hostdependency","nagios_hostescalation","nagios_hostextinfo","nagios_hostgroup","nagios_service","nagios_servicedependency","nagios_serviceescalation","nagios_serviceextinfo","nagios_servicegroup","nagios_timeperiod","notify","package","resources","router","schedule","scheduledtask","selboolean","selmodule","service","sshauthorizedkey","sshkey","stage","tidy","user","vlan","yumrepo","zfs","zone","zpool","mysql_database","mysql_user","mysql_grant","anchor"]+defaultTypes = map defaulttype ["augeas","computer","filebucket","interface","k5login","macauthorization","mailalias","maillist","mcx","nagios_command","nagios_contact","nagios_contactgroup","nagios_host","nagios_hostdependency","nagios_hostescalation","nagios_hostextinfo","nagios_hostgroup","nagios_service","nagios_servicedependency","nagios_serviceescalation","nagios_serviceextinfo","nagios_servicegroup","nagios_timeperiod","notify","package","resources","router","schedule","scheduledtask","selboolean","selmodule","service","sshauthorizedkey","sshkey","stage","tidy","user","vlan","yumrepo","zfs","zone","zpool","mysql_database","mysql_user","mysql_grant","anchor"] -- | The map of native types. They are described in "Puppet.NativeTypes.Helpers". nativeTypes :: Map.Map PuppetTypeName PuppetTypeMethods-nativeTypes = Map.fromList (fakeTypes ++ defaultTypes ++ nativeFile)+nativeTypes = Map.fromList+ ( nativeHost+ : nativeMount+ : nativeGroup+ : nativeFile+ : nativeZoneRecord+ : nativeCron+ : nativeExec+ : fakeTypes ++ defaultTypes)
+ Puppet/NativeTypes/Cron.hs view
@@ -0,0 +1,64 @@+module Puppet.NativeTypes.Cron (nativeCron) where++import Puppet.NativeTypes.Helpers+import Control.Monad.Error+import Puppet.Interpreter.Types+import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Char++nativeCron = ("cron", PuppetTypeMethods validateCron parameterset)++-- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them.+parameterset = Set.fromList $ map fst parameterfunctions+parameterfunctions =+ [("command" , [string, mandatory])+ ,("ensure" , [defaultvalue "present", string, values ["present","absent"]])+ ,("environment" , [])+ ,("hour" , [vrange 0 23 [] ])+ ,("minute" , [vrange 0 59 [] ])+ ,("month" , [vrange 1 12 ["January","February","March","April","May","June","July","August","September","October","November","December"] ])+ ,("monthday" , [vrange 1 31 [] ])+ ,("name" , [string])+ ,("provider" , [defaultvalue "crontab", string, values ["crontab"]])+ ,("special" , [string])+ ,("target" , [string])+ ,("user" , [defaultvalue "root", string])+ ,("weekday" , [vrange 0 7 ["Monday","Tuesday","Wednesday","Thursday","Friday","Saturday"]])+ ]++validateCron :: PuppetTypeValidate+validateCron = defaultValidate parameterset >=> parameterFunctions parameterfunctions++vrange :: Integer -> Integer -> [String] -> String -> PuppetTypeValidate+vrange mi ma valuelist param res = case (Map.lookup param (rrparams res)) of+ Just (ResolvedArray xs) -> foldM (vrange' mi ma valuelist param) res xs+ Just x -> vrange' mi ma valuelist param res x+ Nothing -> defaultvalue "*" param res++vrange' :: Integer -> Integer -> [String] -> String -> RResource -> ResolvedValue -> Either String RResource+vrange' mi ma valuelist param res y = case y of+ ResolvedString "*" -> Right res+ ResolvedString "absent" -> Right res+ ResolvedString x -> if elem x valuelist+ then Right res+ else parseval x mi ma param res+ ResolvedInt i -> checkint' i mi ma param res+ x -> Left $ "Parameter " ++ param ++ " value should be a valid cron declaration and not " ++ show x++parseval :: String -> Integer -> Integer -> String -> PuppetTypeValidate+parseval ('*':'/':xs) _ ma pname res = checkint xs 1 ma pname res+parseval resval mi ma pname res = checkint resval mi ma pname res++checkint :: String -> Integer -> Integer -> String -> PuppetTypeValidate+checkint st mi ma pname res = if all isDigit st+ then+ let v = read st :: Integer+ in checkint' v mi ma pname res+ else Left $ "Invalid value type for parameter " ++ pname++checkint' :: Integer -> Integer -> Integer -> String -> PuppetTypeValidate+checkint' i mi ma param res = + if (i>=mi) && (i<=ma)+ then Right res+ else Left $ "Parameter " ++ param ++ " value is out of bound, should statisfy " ++ show mi ++ "<=" ++ show i ++ "<=" ++ show ma
+ Puppet/NativeTypes/Exec.hs view
@@ -0,0 +1,33 @@+module Puppet.NativeTypes.Exec (nativeExec) where++import Puppet.NativeTypes.Helpers+import Control.Monad.Error+import qualified Data.Set as Set++nativeExec = ("exec", PuppetTypeMethods validateExec parameterset)++-- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them.+parameterset = Set.fromList $ map fst parameterfunctions+parameterfunctions =+ [("command" , [string, nameval])+ ,("creates" , [rarray, strings, fullyQualifieds])+ ,("cwd" , [string, fullyQualified])+ ,("environment" , [rarray, strings])+ ,("group" , [string])+ ,("logoutput" , [defaultvalue "false", string, values ["true","false","on_failure"]])+ ,("onlyif" , [string])+ ,("path" , [rarray, strings, fullyQualifieds])+ ,("provider" , [string, values ["posix","shell","windows"]])+ ,("refresh" , [string])+ ,("refreshonly" , [defaultvalue "false", string, values ["true","false"]])+ ,("returns" , [defaultvalue "0", rarray, integers])+ ,("timeout" , [defaultvalue "300", integer])+ ,("tries" , [defaultvalue "1", integer])+ ,("try_sleep" , [defaultvalue "0", integer])+ ,("unless" , [string])+ ,("user" , [string])+ ]++validateExec :: PuppetTypeValidate+validateExec = defaultValidate parameterset >=> parameterFunctions parameterfunctions+
Puppet/NativeTypes/File.hs view
@@ -6,7 +6,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set -nativeFile = [("file", PuppetTypeMethods validateFile parameterset)]+nativeFile = ("file", PuppetTypeMethods validateFile parameterset) -- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. parameterset = Set.fromList $ map fst parameterfunctions@@ -14,6 +14,7 @@ [("backup" , [string]) ,("checksum" , [values ["md5", "md5lite", "mtime", "ctime", "none"]]) ,("content" , [string])+ --,("ensure" , [defaultvalue "present", string, values ["directory","file","present","absent","link"]]) ,("ensure" , [defaultvalue "present", string]) ,("force" , [string, values ["true","false"]]) ,("group" , [defaultvalue "root", string])@@ -21,7 +22,7 @@ ,("links" , [string]) ,("mode" , [integer]) ,("owner" , [string])- ,("path" , [string])+ ,("path" , [nameval, string, mandatory, fullyQualified]) ,("provider" , [values ["posix","windows"]]) ,("purge" , [string, values ["true","false"]]) ,("recurse" , [string, values ["inf","true","false","remote"]])@@ -34,7 +35,6 @@ validateFile :: PuppetTypeValidate validateFile = defaultValidate parameterset >=> parameterFunctions parameterfunctions >=> validateSourceOrContent- validateSourceOrContent :: PuppetTypeValidate validateSourceOrContent res = let
+ Puppet/NativeTypes/Group.hs view
@@ -0,0 +1,27 @@+module Puppet.NativeTypes.Group (nativeGroup) where++import Puppet.NativeTypes.Helpers+import Control.Monad.Error+import qualified Data.Set as Set++nativeGroup = ("group", PuppetTypeMethods validateGroup parameterset)++-- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them.+parameterset = Set.fromList $ map fst parameterfunctions+parameterfunctions = + [("allowdupe" , [string, defaultvalue "false", values ["true","false"]])+ ,("attribute_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]])+ ,("attributes" , [strings])+ ,("auth_membership" , [defaultvalue "true"])+ ,("ensure" , [defaultvalue "present", string, values ["present","absent"]])+ ,("gid" , [integer])+ ,("ia_load_module" , [string])+ ,("members" , [strings])+ ,("name" , [string]) -- auto nameval+ ,("provider" , [string, values ["aix","directoryservice","groupadd","ldap","pw","window_adsi"]])+ ,("system" , [string, defaultvalue "false", values ["true","false"]])+ ]++validateGroup :: PuppetTypeValidate+validateGroup = defaultValidate parameterset >=> parameterFunctions parameterfunctions+
Puppet/NativeTypes/Helpers.hs view
@@ -48,25 +48,39 @@ defaults = Map.fromList [("name", nm),("title", nm)] nm = ResolvedString $ rrname res +-- | Helper function that runs a validor on a ResolvedArray+runarray :: String -> (String -> ResolvedValue -> PuppetTypeValidate) -> PuppetTypeValidate+runarray param func res = case Map.lookup param (rrparams res) of+ Just (ResolvedArray x) -> foldM (\res' cu -> func param cu res') res x+ Just x -> Left $ "Parameter " ++ param ++ " should be an array, not " ++ show x+ Nothing -> Right res+ {-| This checks that a given parameter is a string. If it is a 'ResolvedInt' or 'ResolvedBool' it will convert them to strings. -} string :: String -> PuppetTypeValidate string param res = case Map.lookup param (rrparams res) of- Just (ResolvedString _) -> Right res- Just (ResolvedInt n) -> Right (insertparam res param (ResolvedString $ show n))- Just (ResolvedBool True) -> Right (insertparam res param (ResolvedString "true"))- Just (ResolvedBool False) -> Right (insertparam res param (ResolvedString "false"))- Just x -> Left $ "Parameter " ++ param ++ " should be a string, and not " ++ show x+ Just x -> string' param x res Nothing -> Right res +strings :: String -> PuppetTypeValidate+strings param = runarray param string'++string' :: String -> ResolvedValue -> PuppetTypeValidate+string' param re res = case re of+ ResolvedString _ -> Right res+ ResolvedInt n -> Right (insertparam res param (ResolvedString $ show n))+ ResolvedBool True -> Right (insertparam res param (ResolvedString "true"))+ ResolvedBool False -> Right (insertparam res param (ResolvedString "false"))+ x -> Left $ "Parameter " ++ param ++ " should be a string, and not " ++ show x+ -- | Makes sure that the parameter, if defined, has a value among this list. values :: [String] -> String -> PuppetTypeValidate values valuelist param res = case (Map.lookup param (rrparams res)) of Just (ResolvedString x) -> if elem x valuelist then Right res- else Left $ "Parameter " ++ param ++ " value should be one of " ++ show valuelist- Just _ -> Left $ "Parameter " ++ param ++ " value should be one of " ++ show valuelist+ else Left $ "Parameter " ++ param ++ " value should be one of " ++ show valuelist ++ " and not " ++ x+ Just x -> Left $ "Parameter " ++ param ++ " value should be one of " ++ show valuelist ++ " and not " ++ show x Nothing -> Right res -- | This fills the default values of unset parameters.@@ -84,13 +98,35 @@ integer prm res = string prm res >>= integer' prm where integer' pr rs = case (Map.lookup pr (rrparams rs)) of+ Just x -> integer'' prm x res Nothing -> Right rs- Just (ResolvedString x) -> if all isDigit x- then Right $ insertparam rs pr (ResolvedInt $ read x)- else Left $ "Parameter " ++ pr ++ " should be a number"- Just (ResolvedInt _) -> Right rs- _ -> Left $ "Parameter " ++ pr ++ " must be an integer" +integers :: String -> PuppetTypeValidate+integers param = runarray param integer''++integer'' :: String -> ResolvedValue -> PuppetTypeValidate+integer'' param val res = case val of+ ResolvedString x -> if all isDigit x+ then Right $ insertparam res param (ResolvedInt $ read x)+ else Left $ "Parameter " ++ param ++ " should be a number"+ ResolvedInt _ -> Right res+ _ -> Left $ "Parameter " ++ param ++ " must be an integer"++-- | Copies the "name" value into this if this is not set.+nameval :: String -> PuppetTypeValidate+nameval prm res = do+ nres <- string prm res+ case Map.lookup "name" (rrparams res) of+ Just (ResolvedString nm) -> defaultvalue nm prm nres+ Just x -> Left $ "Parameter name should be a string, and not " ++ show x+ Nothing -> Left "Parameter name not set."++-- | Checks that a given parameter is set.+mandatory :: String -> PuppetTypeValidate+mandatory param res = case Map.lookup param (rrparams res) of+ Just _ -> Right res+ Nothing -> Left $ "Parameter " ++ param ++ " should be set."+ -- | Helper that takes a list of stuff and will generate a validator. parameterFunctions :: [(String, [String -> PuppetTypeValidate])] -> PuppetTypeValidate parameterFunctions argrules rs = foldM parameterFunctions' rs argrules@@ -99,3 +135,54 @@ parameterFunctions' r (param, validationfunctions) = foldM (parameterFunctions'' param) r validationfunctions parameterFunctions'' :: String -> RResource -> (String -> PuppetTypeValidate) -> Either String RResource parameterFunctions'' param r validationfunction = validationfunction param r++-- checks that a parameter is fully qualified+fullyQualified :: String -> PuppetTypeValidate+fullyQualified param res = case Map.lookup param (rrparams res) of+ Just path -> fullyQualified' param path res+ Nothing -> Right res++fullyQualifieds :: String -> PuppetTypeValidate+fullyQualifieds param = runarray param fullyQualified'++fullyQualified' :: String -> ResolvedValue -> PuppetTypeValidate+fullyQualified' param path res = case path of+ ResolvedString ("") -> Left $ "Empty path for parameter " ++ param+ ResolvedString ('/':_) -> Right res+ ResolvedString p -> Left $ "Path must be absolute, not " ++ p ++ " for parameter " ++ param+ x -> Left $ "SHOULD NOT HAPPEN: path is not a resolved string, but " ++ show x ++ " for parameter " ++ show x++rarray :: String -> PuppetTypeValidate+rarray param res = case Map.lookup param (rrparams res) of+ Just (ResolvedArray _) -> Right res+ Just x -> Right $ insertparam res param (ResolvedArray [x])+ Nothing -> Right res++ipaddr :: String -> PuppetTypeValidate+ipaddr param res = case Map.lookup param (rrparams res) of+ Nothing -> Right res+ Just (ResolvedString ip) ->+ if checkipv4 ip 0+ then Right res+ else Left $ "Invalid IP address for parameter " ++ param+ Just x -> Left $ "Parameter " ++ param ++ " should be an IP address string, not " ++ show x++checkipv4 :: String -> Int -> Bool+checkipv4 _ 4 = False -- means that there are more than 4 groups+checkipv4 "" _ = False -- should never get an empty string+checkipv4 ip v =+ let (cur, nxt) = break (=='.') ip+ nextfunc = if null nxt+ then v == 3+ else checkipv4 (tail nxt) (v+1)+ goodcur = not (null cur) && all isDigit cur && (let rcur = read cur :: Int in (rcur >= 0) && (rcur <= 255))+ in goodcur && nextfunc++inrange :: Integer -> Integer -> String -> PuppetTypeValidate+inrange mi ma param res = case Map.lookup param (rrparams res) of+ Nothing -> Right res+ Just (ResolvedInt v) -> if (v>=mi) && (v<=ma)+ then Right res+ else Left $ "Parameter " ++ param ++ "'s value should be between " ++ show mi ++ " and " ++ show ma+ Just x -> Left $ "Parameter " ++ param ++ " should be an integer, and not " ++ show x+
+ Puppet/NativeTypes/Host.hs view
@@ -0,0 +1,49 @@+module Puppet.NativeTypes.Host (nativeHost) where++import Puppet.NativeTypes.Helpers+import Control.Monad.Error+import Puppet.Interpreter.Types+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Char (isAlphaNum)++nativeHost = ("host", PuppetTypeMethods validateHost parameterset)++-- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them.+parameterset = Set.fromList $ map fst parameterfunctions+parameterfunctions =+ [("comment" , [string, values ["true","false"]])+ ,("ensure" , [defaultvalue "present", string, values ["present","absent"]])+ ,("host_aliases" , [rarray, strings, checkhostname])+ ,("ip" , [string, mandatory, ipaddr])+ ,("name" , [string, checkhostname]) -- auto nameval+ ,("provider" , [string, values ["parsed"]])+ ,("target" , [string, fullyQualified])+ ]++validateHost :: PuppetTypeValidate+validateHost = defaultValidate parameterset >=> parameterFunctions parameterfunctions++checkhostname :: String -> PuppetTypeValidate+checkhostname param res = case Map.lookup param (rrparams res) of+ Nothing -> Right res+ Just (ResolvedArray xs) -> foldM (checkhostname' param) res xs+ Just x@(ResolvedString _) -> checkhostname' param res x+ Just x -> Left $ param ++ " should be an array or a single string, not " ++ show x++checkhostname' :: String -> RResource -> ResolvedValue -> Either String RResource+checkhostname' prm _ (ResolvedString "") = Left $ "Empty hostname for parameter " ++ prm+checkhostname' prm res (ResolvedString x ) = checkhostname'' prm res x+checkhostname' prm _ x = Left $ "Parameter " ++ prm ++ "should be an string or an array of strings, but this was found : " ++ show x++checkhostname'' :: String -> RResource -> String -> Either String RResource+checkhostname'' prm _ "" = Left $ "Empty hostname part in parameter " ++ prm+checkhostname'' prm res prt =+ let (cur,nxt) = break (=='.') prt+ nextfunc = if null nxt+ then Right res+ else checkhostname'' prm res (tail nxt)+ in if null cur || (head cur == '-') || not (all (\x -> isAlphaNum x || (x=='-')) cur)+ then Left $ "Invalid hostname part for parameter " ++ prm+ else nextfunc+
+ Puppet/NativeTypes/Mount.hs view
@@ -0,0 +1,27 @@+module Puppet.NativeTypes.Mount (nativeMount) where++import Puppet.NativeTypes.Helpers+import Control.Monad.Error+import qualified Data.Set as Set++nativeMount = ("mount", PuppetTypeMethods validateMount parameterset)++parameterset = Set.fromList $ map fst parameterfunctions+parameterfunctions =+ [("atboot" , [string, values ["true","false"]])+ ,("blockdevice" , [string])+ ,("device" , [string, mandatory])+ ,("dump" , [integer, inrange 0 2])+ ,("ensure" , [defaultvalue "present", string, values ["present","absent","mounted"]])+ ,("fstype" , [string, mandatory])+ ,("name" , [string])+ ,("options" , [string])+ ,("pass" , [defaultvalue "0", integer])+ ,("provider" , [defaultvalue "parsed", string, values ["parsed"]])+ ,("remounts" , [string, values ["true","false"]])+ ,("target" , [string, fullyQualified])+ ]++validateMount :: PuppetTypeValidate+validateMount = defaultValidate parameterset >=> parameterFunctions parameterfunctions+
+ Puppet/NativeTypes/ZoneRecord.hs view
@@ -0,0 +1,39 @@+module Puppet.NativeTypes.ZoneRecord (nativeZoneRecord) where++import Puppet.NativeTypes.Helpers+import Control.Monad.Error+import Puppet.Interpreter.Types+import qualified Data.Map as Map+import qualified Data.Set as Set++nativeZoneRecord = ("zone_record", PuppetTypeMethods validateZoneRecord parameterset)++-- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them.+parameterset = Set.fromList $ map fst parameterfunctions+parameterfunctions = + [("name" , [string]) -- automatically nameval+ ,("owner" , [string])+ ,("dest" , [string])+ ,("rtype" , [string, defaultvalue "A", values ["SOA", "A", "AAAA", "MX", "NS", "CNAME", "PTR", "SRV"]])+ ,("rclass" , [defaultvalue "IN", string])+ ,("ttl" , [defaultvalue "2d", string])+ ,("target" , [string, mandatory])+ ,("nsname" , [string])+ ,("serial" , [string])+ ,("slave_refresh" , [string])+ ,("slave_retry" , [string])+ ,("slave_expiration" , [string])+ ,("min_ttl" , [string])+ ,("email" , [string])+ ]++validateZoneRecord :: PuppetTypeValidate+validateZoneRecord = defaultValidate parameterset >=> parameterFunctions parameterfunctions >=> validateMandatories++validateMandatories :: PuppetTypeValidate+validateMandatories res = case (Map.lookup "rtype" (rrparams res)) of+ Nothing -> Left "The rtype parameter is mandatory."+ Just (ResolvedString "SOA") -> foldM (\r n -> mandatory n r) res ["nsname", "email", "serial", "slave_refresh", "slave_retry", "slave_expiration", "min_ttl"]+ Just (ResolvedString "NS") -> foldM (\r n -> mandatory n r) res ["owner", "rclass", "rtype", "dest"]+ Just (ResolvedString _) -> foldM (\r n -> mandatory n r) res ["owner", "rclass", "rtype", "dest", "ttl"]+ Just x -> Left $ "Can't use this for the rtype parameter " ++ show x
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.6+Version: 0.1.7 -- A short (one-line) description of the package. Synopsis: Tools to parse and evaluate the Puppet DSL.@@ -53,13 +53,15 @@ -- Modules exported by the library. Exposed-modules: Puppet.DSL.Parser, Puppet.DSL.Printer, Puppet.Daemon, Puppet.Init, Puppet.DSL.Loader, Puppet.Printers, Puppet.NativeTypes, Puppet.DSL.Types, Puppet.Interpreter.Types, Puppet.Interpreter.Catalog, Puppet.NativeTypes.Helpers- + -- Packages needed in order to build this package.- Build-depends: base >=3 && <5,parsec,MissingH,containers,pretty,mtl,unix,hslogger,filepath,Glob,regexpr,process,bytestring,cryptohash,base16-bytestring- + Build-depends: base >=3 && <5,parsec,MissingH,containers,pretty,mtl,unix,hslogger,filepath,Glob,regexpr,process,bytestring,cryptohash,base16-bytestring,regex-pcre-builtin+ -- Modules not exported by this package. Other-modules: Puppet.Interpreter.Functions, Puppet.NativeTypes.File, Erb.Compute, SafeProcess, Paths_language_puppet, Erb.Parser, Erb.Ruby, Erb.Evaluate- + Puppet.NativeTypes.ZoneRecord, Puppet.NativeTypes.Cron, Puppet.NativeTypes.Exec, Puppet.NativeTypes.Group, Puppet.NativeTypes.Host+ Puppet.NativeTypes.Mount+ -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: