language-puppet 0.1.7 → 0.1.7.2
raw patch · 16 files changed
+313/−102 lines, 16 filesdep +aesondep +attoparsecdep +http-conduit
Dependencies added: aeson, attoparsec, http-conduit, http-types, iconv, text, unordered-containers, vector
Files
- Puppet/DSL/Parser.hs +43/−34
- Puppet/Daemon.hs +1/−1
- Puppet/Interpreter/Catalog.hs +125/−44
- Puppet/Interpreter/Functions.hs +35/−1
- Puppet/Interpreter/Types.hs +25/−2
- Puppet/NativeTypes/Cron.hs +1/−1
- Puppet/NativeTypes/Exec.hs +1/−1
- Puppet/NativeTypes/File.hs +1/−1
- Puppet/NativeTypes/Group.hs +1/−1
- Puppet/NativeTypes/Helpers.hs +8/−7
- Puppet/NativeTypes/Host.hs +1/−1
- Puppet/NativeTypes/Mount.hs +1/−1
- Puppet/NativeTypes/ZoneRecord.hs +1/−1
- Puppet/Printers.hs +8/−3
- PuppetDB/Rest.hs +57/−0
- language-puppet.cabal +4/−3
Puppet/DSL/Parser.hs view
@@ -23,6 +23,9 @@ import Text.Parsec.Language (emptyDef) import Data.List.Utils import Puppet.DSL.Types+import qualified Data.Map as Map+import Puppet.NativeTypes+import Control.Monad (when) def = emptyDef { P.commentStart = "/*"@@ -30,8 +33,8 @@ , P.commentLine = "#" , P.nestedComments = True , P.identStart = letter- , P.identLetter = alphaNum <|> oneOf "_"- , P.reservedNames = ["if", "else", "case", "elsif", "and", "or", "in", "import", "include", "define", "require", "class", "node"]+ , P.identLetter = alphaNum <|> char '_'+ , P.reservedNames = ["if", "else", "case", "elsif", "default", "import", "define", "class", "node", "inherits", "true", "false", "undef"] , P.reservedOpNames= ["=>","=","+","-","/","*","+>","->","~>","!"] , P.caseSensitive = True }@@ -59,21 +62,21 @@ , [ Prefix ( symbol "-" >> return NegOperation ) ] , [ Prefix ( symbol "!" >> return NotOperation ) ] , [ Infix ( reserved "in" >> return IsElementOperation ) AssocLeft ]- , [ Infix ( reserved "and" >> return AndOperation ) AssocLeft - , Infix ( reserved "or" >> return OrOperation ) AssocLeft ]- , [ Infix ( reservedOp "<<" >> return ShiftLeftOperation ) AssocLeft - , Infix ( reservedOp ">>" >> return ShiftRightOperation ) AssocLeft ]- , [ Infix ( reservedOp "/" >> return DivOperation ) AssocLeft + , [ Infix ( reservedOp "/" >> return DivOperation ) AssocLeft , Infix ( reservedOp "*" >> return MultiplyOperation ) AssocLeft ]- , [ Infix ( reservedOp "+" >> return PlusOperation ) AssocLeft + , [ Infix ( reservedOp "+" >> return PlusOperation ) AssocLeft , Infix ( reservedOp "-" >> return MinusOperation ) AssocLeft ]- , [ Infix ( reservedOp "==" >> return EqualOperation ) AssocLeft + , [ Infix ( reservedOp "<<" >> return ShiftLeftOperation ) AssocLeft+ , Infix ( reservedOp ">>" >> return ShiftRightOperation ) AssocLeft ]+ , [ Infix ( reservedOp "==" >> return EqualOperation ) AssocLeft , Infix ( reservedOp "!=" >> return DifferentOperation ) AssocLeft ]- , [ Infix ( reservedOp ">" >> return AboveOperation ) AssocLeft + , [ Infix ( reservedOp ">" >> return AboveOperation ) AssocLeft , Infix ( reservedOp ">=" >> return AboveEqualOperation ) AssocLeft- , Infix ( reservedOp "<=" >> return UnderEqualOperation ) AssocLeft + , Infix ( reservedOp "<=" >> return UnderEqualOperation ) AssocLeft , Infix ( reservedOp "<" >> return UnderOperation ) AssocLeft ]- , [ Infix ( reservedOp "=~" >> return RegexpOperation ) AssocLeft + , [ Infix ( reserved "and" >> return AndOperation ) AssocLeft+ , Infix ( reserved "or" >> return OrOperation ) AssocLeft ]+ , [ Infix ( reservedOp "=~" >> return RegexpOperation ) AssocLeft , Infix ( reservedOp "!~" >> return NotRegexpOperation ) AssocLeft ] ] term = parens exprparser@@ -95,18 +98,19 @@ ; return e } -puppetVariableOrHashLookup = do { v <- puppetVariable- ; whiteSpace- ; hashlist <- many hashRef- ; case hashlist of+puppetVariableOrHashLookup = do+ v <- puppetVariable+ whiteSpace+ hashlist <- many hashRef+ when (v == "string") $ unexpected "You are not allowed to name variables $string."+ case hashlist of [] -> return $ Value (VariableReference v) _ -> return $ makeLookupOperation v hashlist- } makeLookupOperation :: String -> [Expression] -> Expression makeLookupOperation name exprs = foldl LookupOperation (LookupOperation (Value (VariableReference name)) (head exprs)) (tail exprs) -identstring = many1 (alphaNum <|> oneOf "-_")+identstring = many1 (alphaNum <|> char '_') identifier = do { x <- identstring@@ -207,13 +211,14 @@ , do { s <- option "" (string "::") ; o <- identstring `sepBy` (try $ string "::") ; return $ s ++ (join "::" o) } ] -variableAssignment = do { pos <- getPosition- ; varname <- puppetVariable- ; whiteSpace- ; symbol "="- ; e <- exprparser- ; return [VariableAssignment varname e pos]- }+variableAssignment = do+ pos <- getPosition+ varname <- puppetVariable+ whiteSpace+ symbol "="+ e <- exprparser+ when (varname == "string") $ unexpected "You are not allowed to name variables $string."+ return [VariableAssignment varname e pos] -- types de base -- puppetLiteral : toutes les strings puppet@@ -252,6 +257,7 @@ puppetInterpolableString = do { char '"' ; v <- many ( try ( do { x <- puppetVariable+ ; when (x == "string") $ unexpected "You are not allowed to name variables $string." ; return $ VariableReference x } ) <|> do { x <- doubleQuotedStringContent@@ -355,6 +361,7 @@ ; e <- exprparser ; return e } )+ ; when (varname == "string") $ unexpected "You are not allowed to name variables $string." ; return (varname, defaultvalue) } @@ -375,15 +382,17 @@ ; return [ClassDeclaration cname cparent params (concat st) pos] } -puppetDefine = do { pos <- getPosition- ; try $ reserved "define"- ; cname <- puppetQualifiedName- ; params <- option [] puppetClassParameters- ; symbol "{"- ; st <- many stmtparser- ; symbol "}"- ; return [DefineDeclaration cname params (concat st) pos]- }+puppetDefine = do+ pos <- getPosition+ try $ reserved "define"+ cname <- puppetQualifiedName+ params <- option [] puppetClassParameters+ symbol "{"+ st <- many stmtparser+ symbol "}"+ case Map.lookup cname nativeTypes of+ Just _ -> unexpected "Can't use a native type name for a define."+ Nothing -> return [DefineDeclaration cname params (concat st) pos] puppetIfStyleCondition = do { cond <- exprparser <?> "Conditional expression" ; symbol "{"
Puppet/Daemon.hs view
@@ -13,7 +13,7 @@ import Control.Monad.State import Control.Monad.Error import qualified System.Log.Logger as LOG-import Data.List +import Data.List import Data.Either (rights, lefts) import Data.Foldable (foldlM) import qualified Data.List.Utils as DLU
Puppet/Interpreter/Catalog.hs view
@@ -6,10 +6,27 @@ Here is a list of known discrepencies with Puppet : -* Resources references using the <| |> syntax are not yet supported.+* 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.++* Amending attributes with a reference will not cause an error when done out of+an inherited class.++* Variables $0 to $9, set after regexp matching, are not handled.++* Tags work like regular parameters, and are not automatically populated or inherited.++* Modules, nodes, classes and type names starting with _ are allowed.++* Arrows between resource declarations or collectors are not yet handled.++* Reversed form arrows are not handled.++* Node inheritance is not handled, and class inheritance seems to work well,+but is probably not Puppet-perfect.+ -} module Puppet.Interpreter.Catalog ( getCatalog@@ -20,17 +37,17 @@ import Puppet.NativeTypes.Helpers import Puppet.Interpreter.Functions import Puppet.Interpreter.Types+import Puppet.Printers import System.IO.Unsafe import Data.List-import Data.Char (isDigit,toLower,toUpper, isAlpha, isAlphaNum)+import Data.Char (isDigit,toLower,toUpper, isAlpha, isAlphaNum, isSpace) import Data.Maybe (isJust, fromJust, catMaybes) import Data.Either (lefts, rights, partitionEithers) import Data.Ord (comparing) 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 @@ -47,11 +64,6 @@ qualified [] = False qualified str = isPrefixOf "::" str || qualified (tail str) -throwPosError msg = do- p <- getPos- st <- liftIO currentCallStack- throwError (msg ++ " at " ++ show p ++ intercalate "\n\t" st )- -- Int handling stuff isInt :: String -> Bool isInt = all isDigit@@ -60,17 +72,6 @@ then return (read x) else throwPosError $ "Expected an integer instead of '" ++ x -modifyScope f sc = sc { curScope = f $ curScope sc }-modifyVariables f sc = sc { curVariables = f $ curVariables sc }-modifyClasses f sc = sc { curClasses = f $ curClasses sc }-modifyDefaults f sc = sc { curDefaults = f $ curDefaults sc }-incrementResId sc = sc { curResId = curResId sc + 1 }-setStatePos npos sc = sc { curPos = npos }-emptyDefaults sc = sc { curDefaults = [] }-pushWarning t sc = sc { getWarnings = getWarnings sc ++ [t] }-pushCollect r sc = sc { curCollect = r : curCollect sc }-pushUnresRel r sc = sc { unresolvedRels = r : unresolvedRels sc }- getCatalog :: (TopLevelType -> String -> IO (Either String Statement)) -- ^ The \"get statements\" function. Given a top level type and its name it -- should return the corresponding statement.@@ -100,7 +101,7 @@ -- this validates the resolved resources -- it should only be called with native types or the validatefunction lookup with abord with an error finalizeResource :: CResource -> CatalogMonad (ResIdentifier, RResource)-finalizeResource (CResource cid cname ctype cparams _ cpos) = do+finalizeResource cr@(CResource cid cname ctype cparams _ cpos) = do setPos cpos rname <- resolveGeneralString cname rparams <- mapM (\(a,b) -> do { ra <- resolveGeneralString a; rb <- resolveGeneralValue b; return (ra,rb); }) cparams@@ -108,8 +109,10 @@ -- add collected relations -- TODO unless (Map.member ctype nativeTypes) $ throwPosError $ "Can't find native type " ++ ctype+ -- now run the collection checks for overrides+ nparams <- processOverride cr (Map.fromList rparams) let mrrelations = []- prefinalresource = RResource cid rname ctype (Map.fromList rparams) mrrelations cpos+ prefinalresource = RResource cid rname ctype nparams mrrelations cpos validatefunction = puppetvalidate (nativeTypes Map.! ctype) validated = validatefunction prefinalresource case validated of@@ -125,12 +128,34 @@ if crvirtuality res == Normal then return [res] else do- isCollected <- liftM curCollect get >>= mapM (\x -> x res)+ -- Note that amending attributes with a collector does collect virtual+ -- values. Hence no filtering on the collectors is done here.+ isCollected <- liftM curCollect get >>= mapM (\(x, _) -> x res) case (or isCollected, crvirtuality res) of (True, Exported) -> return [res { crvirtuality = Normal }, res] (True, _) -> return [res { crvirtuality = Normal } ] (False, _) -> return [res ] +processOverride :: CResource -> Map.Map String ResolvedValue -> CatalogMonad (Map.Map String ResolvedValue)+processOverride cr prms =+ let applyOverride :: CResource -> Map.Map String ResolvedValue -> (CResource -> CatalogMonad Bool, [(GeneralString, GeneralValue)]) -> CatalogMonad (Map.Map String ResolvedValue)+ -- this checks if the collection function matches+ applyOverride c prm (func, overs) = do+ check <- func c+ if check+ then foldM tryReplace prm overs+ else return prm+ tryReplace :: Map.Map String ResolvedValue -> (GeneralString, GeneralValue) -> CatalogMonad (Map.Map String ResolvedValue)+ -- if it does, this resolves the override and applies it+ -- this is obviously wasteful+ tryReplace curmap (gs, gv) = do+ rs <- resolveGeneralString gs+ rv <- resolveGeneralValue gv+ return $ Map.insert rs rv curmap+ -- Collectors are filtered so that only those with overrides are passed to the fold.+ in liftM (filter (not . null . snd) . curCollect) get >>= foldM (applyOverride cr) prms++ finalResolution :: Catalog -> CatalogMonad FinalCatalog finalResolution cat = do --liftIO $ putStrLn $ "FINAL RESOLUTION"@@ -180,7 +205,6 @@ put $ incrementResId curscope return (curResId curscope) setPos = modify . setStatePos-getPos = liftM curPos get -- qualifies a variable k depending on the context cs qualify k cs | qualified k || (cs == "::") = cs ++ k@@ -269,7 +293,7 @@ applyDefaults' :: CResource -> ResDefaults -> CatalogMonad CResource applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (RDefaults dtype rdefs dpos) = do srname <- resolveGeneralString rname- let (nparams, nrelations) = mergeParams rparams rdefs False + let (nparams, nrelations) = mergeParams rparams rdefs False if dtype == rtype then do addUnresRel (nrelations, (rtype, Right srname), UDefault, dpos)@@ -311,7 +335,7 @@ putVariable "title" (expr, rpos) putVariable "name" (expr, rpos) mapM_ (loadClassVariable rpos mparams) args- + -- parse statements res <- mapM evaluateStatements dstmts nres <- handleDelayedActions (concat res)@@ -326,8 +350,8 @@ 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 and define resolution) handleDelayedActions :: Catalog -> CatalogMonad Catalog handleDelayedActions res = do@@ -405,16 +429,18 @@ -- <<| |>> evaluateStatements (ResourceCollection rtype expr overrides position) = do setPos position- unless (null overrides) (throwPosError "Collection overrides not handled")+ when (not $ null overrides) $ throwPosError $ "Amending attributes with a Collector only works with <| |>, not <<| |>>." func <- collectionFunction Exported rtype expr- addCollect func+ addCollect (func, []) return [] -- <| |>+-- TODO : check that this is a native type when overrides are defined.+-- The behaviour is not explained in the documentation, so I won't support it. evaluateStatements (VirtualResourceCollection rtype expr overrides position) = do setPos position- unless (null overrides) (throwPosError "Collection overrides not handled") func <- collectionFunction Virtual rtype expr- addCollect func+ prms <- mapM resolveParams overrides+ addCollect (func, prms) return [] evaluateStatements (VariableAssignment vname vexpr position) = do@@ -470,7 +496,7 @@ Nothing -> pushScope [classname] -- sets the scope Just ac -> pushScope [classname, ac] mapM_ (loadClassVariable position inputparams) parameters -- add variables for parametrized classes- + -- load inherited classes inherited <- case inherits of Just parentclass -> do@@ -530,6 +556,18 @@ tryResolveGeneralValue n@(Left (UnderEqualOperation a b)) = compareGeneralValue n a b [LT,EQ] tryResolveGeneralValue n@(Left (UnderOperation a b)) = compareGeneralValue n a b [LT] tryResolveGeneralValue n@(Left (DifferentOperation a b)) = compareGeneralValue n a b [LT,GT]+tryResolveGeneralValue n@(Left (RegexpOperation a b)) = do+ ra <- tryResolveExpression a+ rb <- tryResolveExpression b+ case (ra, rb) of+ (Right (ResolvedString src), Right (ResolvedRegexp reg)) -> do+ m <- liftIO $ regmatch src reg+ case m of+ Right x -> return $ Right $ ResolvedBool x+ Left err -> throwPosError $ "Error with regexp " ++ show reg ++ ": " ++ err+ (Right x, _) -> throwPosError $ "Was expecting a string to match to a regexp, not " ++ show x+ (_, Right x) -> throwPosError $ "Was expecting a regexp, not " ++ show x+ _ -> return n tryResolveGeneralValue n@(Left (OrOperation a b)) = do ra <- tryResolveBoolean $ Left a if( ra == Right (ResolvedBool True) )@@ -574,6 +612,8 @@ (_, Left y) -> throwPosError ("Could not resolve index " ++ show y) (Left x, _) -> throwPosError ("Could not resolve lookup " ++ show x) (Right x, _) -> throwPosError ("Could not resolve something that is not an array nor a hash, but " ++ show x)+-- TODO : for hashes, checks the keys+-- for strings, substrings tryResolveGeneralValue o@(Left (IsElementOperation b a)) = do ra <- tryResolveExpression a rb <- tryResolveExpressionString b@@ -666,11 +706,14 @@ else return $ case head matching of (x,_) -> x -tryResolveValue n@(Interpolable x) = do+tryResolveValue (Interpolable x) = do resolved <- mapM tryResolveValueString x if null $ lefts resolved then return $ Right $ ResolvedString $ concat $ rights resolved- else return $ Left $ Value n+ -- if it is not resolved, we will try to store it as resolved as+ -- possible, so as not to lose the context+ else fmap (Left . Value . Interpolable)+ (mapM tryResolveValue x >>= mapM generalValue2Value) tryResolveValue n@(PuppetHash (Parameters x)) = do resolvedKeys <- mapM (tryResolveExpressionString . fst) x@@ -696,6 +739,22 @@ Just w -> return $ Right $ ResolvedString w Nothing -> throwPosError $ "Function call generate for command " ++ cmdname ++ " (" ++ show cmdargs ++ ") failed" +tryResolveValue n@(FunctionCall "pdbresourcequery" (query:xs)) = do+ rkey <- case xs of+ [key] -> do+ r <- tryResolveExpression key+ case r of+ Right (ResolvedString keyname) -> return $ Right $ Just keyname+ Right x -> throwPosError $ "The pdbresourcequery function expects a string as the second argument, not " ++ showValue x+ Left y -> return $ Left $ y+ [] -> return $ Right Nothing+ _ -> throwPosError "Bad number of arguments for function pdbresourcequery"+ rquery <- tryResolveExpression query+ case (rquery, rkey) of+ (Right a@(ResolvedArray _), Right keyname) -> fmap Right (pdbresourcequery (showValue a) keyname)+ (Right a, Right _) -> throwPosError $ "The pdbresourcequery function expects an array as the first argument, not " ++ showValue a+ _ -> return $ Left $ Value n+ tryResolveValue n@(FunctionCall "is_domain_name" [x]) = do rx <- tryResolveExpressionString x case rx of@@ -770,6 +829,16 @@ tryResolveValue (FunctionCall "regsubst" [str, src, dst]) = tryResolveValue (FunctionCall "regsubst" [str, src, dst, Value $ Literal ""]) tryResolveValue (FunctionCall "regsubst" args) = throwPosError ("Bad argument count for regsubst " ++ show args) +tryResolveValue n@(FunctionCall "chomp" [str]) = do+ let mychomp = reverse . dropWhile isSpace . reverse+ mmychomp (ResolvedString s) = return $ ResolvedString (mychomp s)+ mmychomp r = throwPosError $ "The chomp function expects strings or arrays of strings, not this: " ++ show r+ rstr <- tryResolveExpression str+ case rstr of+ Left _ -> return $ Left $ Value n+ Right (ResolvedArray arr) -> fmap (Right . ResolvedArray) (mapM mmychomp arr)+ Right x -> fmap Right (mmychomp x)+ tryResolveValue n@(FunctionCall "split" [str, reg]) = do rstr <- tryResolveExpressionString str rreg <- tryResolveExpressionString reg@@ -834,7 +903,7 @@ myfunction (CResource _ mcrname mcrtype _ _ _) = do srname <- resolveGeneralString mcrname return ((srname == rname) && (mcrtype == rtype))- addCollect myfunction+ addCollect (myfunction, []) return () pushRealize (ResolvedRReference _ x) = throwPosError (show x ++ " was not resolved to a string") pushRealize x = throwPosError ("A reference was expected instead of " ++ show x)@@ -849,7 +918,7 @@ _ -> throwPosError $ "Resource type must be a string and not " ++ show mrtype arghash <- case rdefs of ResolvedHash x -> return x- _ -> throwPosError $ "Resource definition must be a hash, and not " ++ show rdefs + _ -> throwPosError $ "Resource definition must be a hash, and not " ++ show rdefs position <- getPos let prestatements = map (\(rname, rargs) -> (Value $ Literal rname, resolved2expression rargs)) arghash resources <- mapM (\(resname, pval) -> do@@ -927,19 +996,17 @@ 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+ Right (ResolvedRReference _ _) -> 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" Left (EqualOperation (Value (VariableReference _)) (Value (Literal "false"))) -> return $ Right $ ResolvedBool True -- case where a variable was not resolved and compared to the string "false" _ -> return rv- + resolveBoolean :: GeneralValue -> CatalogMonad Bool resolveBoolean v = do rv <- tryResolveBoolean v@@ -964,7 +1031,7 @@ rb <- resolveExpression b paramname <- case ra of ResolvedString pname -> return pname- _ -> throwPosError "We only support collection of the form 'parameter == value'" + _ -> throwPosError "We only support collection of the form 'parameter == value'" defstatement <- checkDefine mrtype paramset <- case defstatement of Nothing -> case Map.lookup mrtype nativeTypes of@@ -975,20 +1042,34 @@ 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)+ let param = filter (\x -> fst x == Right paramname) (crparams r) :: [(GeneralString, GeneralValue)] if null param then return False else do cmp <- resolveGeneralValue $ snd (head param)- return (cmp == rb)+ case (paramname, cmp) of+ ("tag", ResolvedArray xs) ->+ let filtered = filter (compareRValues rb) xs+ in return $ not $ null filtered+ _ -> return $ compareRValues cmp rb ) x -> throwPosError $ "TODO : implement collection function for " ++ show x- return (\res ->- if (crtype res == mrtype) && (crvirtuality res == virt)+ return (\res -> do+ -- <| |> matches Normal resources+ if (crtype res == mrtype) && ( ((virt == Virtual) && (crvirtuality res == Normal)) || (crvirtuality res == virt)) then finalfunc res else return False ) ++generalValue2Expression :: GeneralValue -> Expression+generalValue2Expression (Left x) = x+generalValue2Expression (Right y) = resolved2expression y++generalValue2Value :: GeneralValue -> CatalogMonad Value+generalValue2Value x = case (generalValue2Expression x) of+ (Value z) -> return z+ y -> throwPosError $ "Could not downgrade this to a value: " ++ show y resolved2expression :: ResolvedValue -> Expression resolved2expression (ResolvedString str) = Value $ Literal str
Puppet/Interpreter/Functions.hs view
@@ -9,19 +9,25 @@ ,puppetSHA1 ,puppetMD5 ,generate+ ,pdbresourcequery ) where +import PuppetDB.Rest+import Puppet.Printers+import Puppet.Interpreter.Types+ import Data.Hash.MD5 import qualified Crypto.Hash.SHA1 as SHA1 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 import qualified Data.ByteString.Base16 as B16 import SafeProcess+import Data.Either (lefts, rights)+import Data.List (intercalate) puppetMD5 = md5s . Str puppetSHA1 = BS.unpack . B16.encode . SHA1.hash . BS.pack@@ -105,3 +111,31 @@ case cmdout of Just (Right x) -> return $ Just x _ -> return Nothing++pdbresourcequery :: String -> Maybe String -> CatalogMonad ResolvedValue+pdbresourcequery query key = do+ let+ extractSubHash :: String -> [ResolvedValue] -> Either String ResolvedValue+ extractSubHash k vals = let o = map (extractSubHash' k) vals+ in if (null $ lefts o)+ then Right $ ResolvedArray $ rights o+ else Left $ "Something wrong happened while extracting the subhashes for key " ++ k ++ ": " ++ Data.List.intercalate ", " (lefts o)+ extractSubHash' :: String -> ResolvedValue -> Either String ResolvedValue+ extractSubHash' k (ResolvedHash hs) = let f = map snd $ filter ( (==k) . fst ) hs+ in case f of+ [o] -> Right o+ [] -> Left "Key not found"+ _ -> Left "More than one result, this is extremely bad."+ extractSubHash' _ x = Left $ "Expected a hash, not " ++ showValue x+ v <- liftIO $ rawRequest "http://localhost:8080" "resources" query+ rv <- case v of+ Right rh@(ResolvedArray _) -> return rh+ Right wtf -> throwPosError $ "Expected an array from PuppetDB, not " ++ showValue wtf+ Left err -> throwPosError $ "Error during Puppet query: " ++ err+ case (key, rv) of+ (Nothing, _) -> return rv+ (Just k , ResolvedArray ar) -> case extractSubHash k ar of+ Right x -> return x+ Left r -> throwPosError r+ _ -> throwPosError $ "Can't happen at pdbresourcequery"+
Puppet/Interpreter/Types.hs view
@@ -6,6 +6,8 @@ import Control.Monad.Error import qualified Data.Map as Map import qualified Data.Set as Set+import GHC.Exts+import Data.List -- | This is the potentially unsolved list of resources in the catalog. type Catalog =[CResource]@@ -68,8 +70,8 @@ rrelations :: ![Relation], -- ^ Resource relations. rrpos :: !SourcePos -- ^ Source code position of the resource definition. } deriving(Show, Ord, Eq)- + type FinalCatalog = Map.Map ResIdentifier RResource type ScopeName = String@@ -116,9 +118,11 @@ -- ^ This is a function that, given the type of a top level statement and -- its name, should return it. getWarnings :: ![String], -- ^ List of warnings.- curCollect :: ![CResource -> CatalogMonad Bool],+ curCollect :: ![(CResource -> CatalogMonad Bool, [(GeneralString, GeneralValue)])], -- ^ A bit complicated, this stores the collection functions. These are -- functions that determine whether a resource should be collected or not.+ -- It can optionally store overrides, which will be applied in the end on+ -- all resources. unresolvedRels :: ![([(LinkType, GeneralValue, GeneralValue)], (String, GeneralString), RelUpdateType, SourcePos)], -- ^ This stores unresolved relationships, because the original string name -- can't be resolved. Fieds are [ ( [dstrelations], srcresource, type, pos ) ]@@ -141,4 +145,23 @@ -- |This is the set of meta parameters metaparameters = Set.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule"]++getPos = liftM curPos get+modifyScope f sc = sc { curScope = f $ curScope sc }+modifyVariables f sc = sc { curVariables = f $ curVariables sc }+modifyClasses f sc = sc { curClasses = f $ curClasses sc }+modifyDefaults f sc = sc { curDefaults = f $ curDefaults sc }+incrementResId sc = sc { curResId = curResId sc + 1 }+setStatePos npos sc = sc { curPos = npos }+emptyDefaults sc = sc { curDefaults = [] }+pushWarning t sc = sc { getWarnings = getWarnings sc ++ [t] }+pushCollect r sc = sc { curCollect = r : curCollect sc }+pushUnresRel r sc = sc { unresolvedRels = r : unresolvedRels sc }++throwPosError :: String -> CatalogMonad a+throwPosError msg = do+ p <- getPos+ st <- liftIO currentCallStack+ throwError (msg ++ " at " ++ show p ++ intercalate "\n\t" st )+
Puppet/NativeTypes/Cron.hs view
@@ -19,7 +19,7 @@ ,("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])+ ,("name" , [nameval]) ,("provider" , [defaultvalue "crontab", string, values ["crontab"]]) ,("special" , [string]) ,("target" , [string])
Puppet/NativeTypes/Exec.hs view
@@ -9,7 +9,7 @@ -- 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])+ [("command" , [nameval]) ,("creates" , [rarray, strings, fullyQualifieds]) ,("cwd" , [string, fullyQualified]) ,("environment" , [rarray, strings])
Puppet/NativeTypes/File.hs view
@@ -22,7 +22,7 @@ ,("links" , [string]) ,("mode" , [integer]) ,("owner" , [string])- ,("path" , [nameval, string, mandatory, fullyQualified])+ ,("path" , [nameval, fullyQualified]) ,("provider" , [values ["posix","windows"]]) ,("purge" , [string, values ["true","false"]]) ,("recurse" , [string, values ["inf","true","false","remote"]])
Puppet/NativeTypes/Group.hs view
@@ -17,7 +17,7 @@ ,("gid" , [integer]) ,("ia_load_module" , [string]) ,("members" , [strings])- ,("name" , [string]) -- auto nameval+ ,("name" , [nameval]) ,("provider" , [string, values ["aix","directoryservice","groupadd","ldap","pw","window_adsi"]]) ,("system" , [string, defaultvalue "false", values ["true","false"]]) ]
Puppet/NativeTypes/Helpers.hs view
@@ -40,12 +40,12 @@ setdiff = Set.difference keyset (Set.union metaparameters validparameters) -- | This validator always accept the resources, but add the default parameters--- (such as title and name).+-- (such as title). addDefaults :: PuppetTypeValidate addDefaults res = Right (res { rrparams = newparams } ) where newparams = Map.filter (/= ResolvedUndefined) $ Map.union (rrparams res) defaults- defaults = Map.fromList [("name", nm),("title", nm)]+ defaults = Map.fromList [("title", nm)] nm = ResolvedString $ rrname res -- | Helper function that runs a validor on a ResolvedArray@@ -112,14 +112,15 @@ ResolvedInt _ -> Right res _ -> Left $ "Parameter " ++ param ++ " must be an integer" --- | Copies the "name" value into this if this is not set.+-- | Copies the "name" value into the parameter if this is not set. It implies+-- the `string` validator. 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."+ case Map.lookup "title" (rrparams res) of+ Just (ResolvedString nm) -> defaultvalue nm prm nres >>= string prm+ Just x -> Left $ "The title should be a string, and not " ++ show x+ Nothing -> Left "The title is not set. Not sure how that could ever happen." -- | Checks that a given parameter is set. mandatory :: String -> PuppetTypeValidate
Puppet/NativeTypes/Host.hs view
@@ -16,7 +16,7 @@ ,("ensure" , [defaultvalue "present", string, values ["present","absent"]]) ,("host_aliases" , [rarray, strings, checkhostname]) ,("ip" , [string, mandatory, ipaddr])- ,("name" , [string, checkhostname]) -- auto nameval+ ,("name" , [nameval, checkhostname]) ,("provider" , [string, values ["parsed"]]) ,("target" , [string, fullyQualified]) ]
Puppet/NativeTypes/Mount.hs view
@@ -14,7 +14,7 @@ ,("dump" , [integer, inrange 0 2]) ,("ensure" , [defaultvalue "present", string, values ["present","absent","mounted"]]) ,("fstype" , [string, mandatory])- ,("name" , [string])+ ,("name" , [nameval]) ,("options" , [string]) ,("pass" , [defaultvalue "0", integer]) ,("provider" , [defaultvalue "parsed", string, values ["parsed"]])
Puppet/NativeTypes/ZoneRecord.hs view
@@ -11,7 +11,7 @@ -- 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+ [("name" , [nameval]) ,("owner" , [string]) ,("dest" , [string]) ,("rtype" , [string, defaultvalue "A", values ["SOA", "A", "AAAA", "MX", "NS", "CNAME", "PTR", "SRV"]])
Puppet/Printers.hs view
@@ -2,6 +2,7 @@ showRes , showRRes , showFCatalog+ , showValue ) where import Puppet.Interpreter.Types@@ -28,23 +29,27 @@ showValue :: ResolvedValue -> String showValue (ResolvedString x) = show x showValue (ResolvedInt x) = show x+showValue (ResolvedDouble x) = show x showValue (ResolvedBool True) = "true" showValue (ResolvedBool False) = "false" showValue (ResolvedRReference rt rn) = rt ++ "[" ++ showValue rn ++ "]" showValue (ResolvedArray ar) = "[" ++ commasep (map showValue ar) ++ "]" showValue (ResolvedHash h) = "{" ++ commasep (map (\(k,v) -> k ++ " => " ++ showValue v) h) ++ "}"+showValue (ResolvedRegexp r) = "/" ++ r ++ "/" showValue (ResolvedUndefined) = "undef" showuniqueres :: [RResource] -> String showuniqueres res = mrtype ++ " {\n" ++ concatMap showrres res ++ "}\n" where showrres (RResource _ rname _ params rels mpos) =- " " ++ show rname ++ ":" ++ " #" ++ show mpos ++ "\n"- ++ commaretsep (map showparams (Map.toList $ Map.delete "title" params))+ let paramlist = (Map.toList $ Map.delete "title" params) :: [(String, ResolvedValue)]+ maxlen = maximum (map (length . fst) paramlist) :: Int+ in " " ++ show rname ++ ":" ++ " #" ++ show mpos ++ "\n"+ ++ commaretsep (map (showparams maxlen) paramlist) ++ commareqs (null rels || Map.null params) ++ commaretsep (map showrequire (sort rels)) ++ ";\n" commareqs c | c = "" | otherwise = ",\n"- showparams (name, val) = " " ++ name ++ " => " ++ showValue val+ showparams mxl (name, val) = " " ++ name ++ replicate (mxl - length name) ' ' ++ " => " ++ showValue val showrequire (ltype, dst) = " " ++ show ltype ++ " " ++ show dst mrtype = rrtype (head res)
+ PuppetDB/Rest.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE OverloadedStrings #-}++module PuppetDB.Rest where++import Puppet.Interpreter.Types+import Puppet.Printers++import Network.HTTP.Conduit+import qualified Network.HTTP.Types as W+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Char8 as BC+import qualified Data.Vector as V+import Data.Aeson+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import Data.Attoparsec.Number+import qualified Codec.Text.IConv as IConv++instance FromJSON ResolvedValue where+ parseJSON Null = return ResolvedUndefined+ parseJSON (Number x) = return $ case x of+ (I n) -> ResolvedInt n+ (D d) -> ResolvedDouble d+ parseJSON (String s) = return $ ResolvedString $ T.unpack s+ parseJSON (Array a) = fmap ResolvedArray (mapM parseJSON (V.toList a))+ parseJSON (Object o) = fmap ResolvedHash (mapM (\(a,b) -> do {+ b' <- parseJSON b ;+ return (T.unpack a,b') }+ ) (HM.toList o))+ parseJSON (Bool b) = return $ ResolvedBool b++toAndQuery = undefined++simpleNodeQuery :: String -> [(String, String)] -> IO (Either String ResolvedValue)+simpleNodeQuery url query = rawRequest url "nodes" (toAndQuery query)++simpleResourceQuery :: String -> [(String, String)] -> IO (Either String ResolvedValue)+simpleResourceQuery url query = rawRequest url "resources" (toAndQuery query)++rawRequest :: String -> String -> String -> IO (Either String ResolvedValue)+rawRequest url querytype query = do+ let q = BC.unpack $ W.renderSimpleQuery False [("query", BC.pack query)]+ pfunc = parseUrl (url ++ "/" ++ querytype ++ "?" ++ q)+ eInitReq <- case querytype of+ "resources" -> fmap Right pfunc+ "nodes" -> fmap Right pfunc+ _ -> return $ Left $ "Invalid query type " ++ querytype+ case eInitReq of+ Right initReq -> do+ let req = initReq { requestHeaders = [("Accept", "application/json")] }+ o <- withManager (\manager -> fmap responseBody $ httpLbs req manager) :: IO L.ByteString+ let utf8 = IConv.convert "LATIN1" "UTF-8" o+ case decode' utf8 :: Maybe ResolvedValue of+ Just x@(ResolvedArray _) -> return $ Right x+ Just x -> return $ Left $ "PuppetDB should have returned an array, not " ++ showValue x+ Nothing -> return $ Left "Json decoding has failed"+ Left err -> return $ Left err
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.7+Version: 0.1.7.2 -- A short (one-line) description of the package. Synopsis: Tools to parse and evaluate the Puppet DSL.@@ -52,10 +52,11 @@ ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-unused-do-bind -funbox-strict-fields -- 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+ Puppet.Interpreter.Types, Puppet.Interpreter.Catalog, Puppet.NativeTypes.Helpers, PuppetDB.Rest -- 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,regex-pcre-builtin+ Build-depends: base >=3 && <5,parsec,MissingH,containers,pretty,mtl,unix,hslogger,filepath,Glob,regexpr,process,bytestring,cryptohash,base16-bytestring,regex-pcre-builtin,+ iconv, text, unordered-containers, aeson, vector, http-types, http-conduit, attoparsec -- 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