diff --git a/Erb/Evaluate.hs b/Erb/Evaluate.hs --- a/Erb/Evaluate.hs +++ b/Erb/Evaluate.hs @@ -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" diff --git a/Erb/Parser.hs b/Erb/Parser.hs --- a/Erb/Parser.hs +++ b/Erb/Parser.hs @@ -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 diff --git a/Puppet/DSL/Parser.hs b/Puppet/DSL/Parser.hs --- a/Puppet/DSL/Parser.hs +++ b/Puppet/DSL/Parser.hs @@ -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 "{" diff --git a/Puppet/Interpreter/Catalog.hs b/Puppet/Interpreter/Catalog.hs --- a/Puppet/Interpreter/Catalog.hs +++ b/Puppet/Interpreter/Catalog.hs @@ -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 diff --git a/Puppet/Interpreter/Functions.hs b/Puppet/Interpreter/Functions.hs --- a/Puppet/Interpreter/Functions.hs +++ b/Puppet/Interpreter/Functions.hs @@ -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 diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -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"] diff --git a/Puppet/NativeTypes.hs b/Puppet/NativeTypes.hs --- a/Puppet/NativeTypes.hs +++ b/Puppet/NativeTypes.hs @@ -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) diff --git a/Puppet/NativeTypes/Cron.hs b/Puppet/NativeTypes/Cron.hs new file mode 100644 --- /dev/null +++ b/Puppet/NativeTypes/Cron.hs @@ -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 diff --git a/Puppet/NativeTypes/Exec.hs b/Puppet/NativeTypes/Exec.hs new file mode 100644 --- /dev/null +++ b/Puppet/NativeTypes/Exec.hs @@ -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 + diff --git a/Puppet/NativeTypes/File.hs b/Puppet/NativeTypes/File.hs --- a/Puppet/NativeTypes/File.hs +++ b/Puppet/NativeTypes/File.hs @@ -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 diff --git a/Puppet/NativeTypes/Group.hs b/Puppet/NativeTypes/Group.hs new file mode 100644 --- /dev/null +++ b/Puppet/NativeTypes/Group.hs @@ -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 + diff --git a/Puppet/NativeTypes/Helpers.hs b/Puppet/NativeTypes/Helpers.hs --- a/Puppet/NativeTypes/Helpers.hs +++ b/Puppet/NativeTypes/Helpers.hs @@ -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 + diff --git a/Puppet/NativeTypes/Host.hs b/Puppet/NativeTypes/Host.hs new file mode 100644 --- /dev/null +++ b/Puppet/NativeTypes/Host.hs @@ -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 + diff --git a/Puppet/NativeTypes/Mount.hs b/Puppet/NativeTypes/Mount.hs new file mode 100644 --- /dev/null +++ b/Puppet/NativeTypes/Mount.hs @@ -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 + diff --git a/Puppet/NativeTypes/ZoneRecord.hs b/Puppet/NativeTypes/ZoneRecord.hs new file mode 100644 --- /dev/null +++ b/Puppet/NativeTypes/ZoneRecord.hs @@ -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 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.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: