language-puppet 0.3.2 → 0.4.0
raw patch · 40 files changed
+2059/−951 lines, 40 filesdep +pcre-utilsdep −MissingHdep −directorydep −filepathdep ~bytestring
Dependencies added: pcre-utils
Dependencies removed: MissingH, directory, filepath, monad-loops, regexpr
Dependency ranges changed: bytestring
Files
- Erb/Compute.hs +91/−67
- Erb/Evaluate.hs +21/−18
- Erb/Parser.hs +7/−6
- Erb/Ruby.hs +4/−2
- Puppet/DSL/Loader.hs +2/−1
- Puppet/DSL/Parser.hs +37/−18
- Puppet/DSL/Printer.hs +18/−14
- Puppet/DSL/Types.hs +34/−29
- Puppet/Daemon.hs +72/−73
- Puppet/Init.hs +22/−15
- Puppet/Interpreter/Catalog.hs +422/−273
- Puppet/Interpreter/Functions.hs +97/−96
- Puppet/Interpreter/RubyRandom.hs +118/−0
- Puppet/Interpreter/Types.hs +142/−35
- Puppet/JsonCatalog.hs +18/−18
- Puppet/NativeTypes.hs +8/−2
- Puppet/NativeTypes/Cron.hs +15/−13
- Puppet/NativeTypes/Exec.hs +10/−1
- Puppet/NativeTypes/File.hs +7/−5
- Puppet/NativeTypes/Group.hs +1/−0
- Puppet/NativeTypes/Helpers.hs +62/−49
- Puppet/NativeTypes/Host.hs +14/−12
- Puppet/NativeTypes/Mount.hs +1/−0
- Puppet/NativeTypes/Package.hs +107/−0
- Puppet/NativeTypes/SshSecure.hs +37/−0
- Puppet/NativeTypes/User.hs +49/−0
- Puppet/NativeTypes/ZoneRecord.hs +3/−1
- Puppet/Plugins.hs +24/−26
- Puppet/Printers.hs +34/−29
- Puppet/Stats.hs +4/−4
- Puppet/Testing.hs +247/−43
- Puppet/Utils.hs +179/−0
- PuppetDB/Query.hs +25/−14
- PuppetDB/Rest.hs +12/−63
- PuppetDB/TestDB.hs +76/−0
- SafeProcess.hs +10/−7
- language-puppet.cabal +13/−9
- ruby/calcerb.rb +3/−0
- test/expr.hs +1/−1
- test/interpreter.hs +12/−7
Erb/Compute.hs view
@@ -1,12 +1,13 @@-{-# LANGUAGE BangPatterns #-} module Erb.Compute(computeTemplate, getTemplateFile, initTemplateDaemon) where -import Data.List import Puppet.Interpreter.Types import Puppet.Init+import Puppet.Stats+import Puppet.Utils import SafeProcess++import Data.List import System.IO-import qualified Data.List.Utils as DLU import Control.Monad.Error import Control.Concurrent import System.Posix.Files@@ -15,109 +16,132 @@ import Erb.Evaluate import qualified Data.Map as Map import Debug.Trace-import qualified Data.ByteString.Lazy.Char8 as BS-import qualified Data.ByteString.Builder as BB-import Data.Monoid import qualified System.Log.Logger as LOG-import Puppet.Stats+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Text.Lazy.IO as TL+import qualified Data.Text.Lazy.Builder as T+import qualified Data.Text.Lazy.Builder.Int as T+import Text.Parsec+import qualified Data.Foldable as F -type TemplateQuery = (Chan TemplateAnswer, String, String, Map.Map String GeneralValue)-type TemplateAnswer = Either String String+type TemplateQuery = (Chan TemplateAnswer, Either T.Text T.Text, T.Text, Map.Map T.Text GeneralValue)+type TemplateAnswer = Either String T.Text -initTemplateDaemon :: Prefs -> MStats -> IO (String -> String -> Map.Map String GeneralValue -> IO (Either String String))+initTemplateDaemon :: Prefs -> MStats -> IO (Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> IO (Either String T.Text)) initTemplateDaemon (Prefs _ modpath templatepath _ _ ps _ _) mvstats = do controlchan <- newChan replicateM_ ps (forkIO (templateDaemon modpath templatepath controlchan mvstats)) return (templateQuery controlchan) -templateQuery :: Chan TemplateQuery -> String -> String -> Map.Map String GeneralValue -> IO (Either String String)+templateQuery :: Chan TemplateQuery -> Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> IO (Either String T.Text) templateQuery qchan filename scope variables = do rchan <- newChan writeChan qchan (rchan, filename, scope, variables) readChan rchan -templateDaemon :: String -> String -> Chan TemplateQuery -> MStats -> IO ()+templateDaemon :: T.Text -> T.Text -> Chan TemplateQuery -> MStats -> IO () templateDaemon modpath templatepath qchan mvstats = do- (respchan, filename, scope, variables) <- readChan qchan- let parts = DLU.split "/" filename- searchpathes | length parts > 1 = [modpath ++ "/" ++ head parts ++ "/templates/" ++ (DLU.join "/" (tail parts)), templatepath ++ "/" ++ filename]- | otherwise = [templatepath ++ "/" ++ filename]- acceptablefiles <- filterM fileExist searchpathes- if(null acceptablefiles)- then writeChan respchan (Left $ "Can't find template file for " ++ filename ++ ", looked in " ++ show searchpathes)- else measure mvstats ("total - " ++ filename) (computeTemplate (head acceptablefiles) scope variables mvstats) >>= writeChan respchan+ (respchan, fileinfo, scope, variables) <- readChan qchan+ case fileinfo of+ Right filename -> do+ let parts = T.splitOn "/" filename+ searchpathes | length parts > 1 = [modpath <> "/" <> head parts <> "/templates/" <> T.intercalate "/" (tail parts), templatepath <> "/" <> filename]+ | otherwise = [templatepath <> "/" <> filename]+ acceptablefiles <- filterM (fileExist . T.unpack) searchpathes+ if null acceptablefiles+ then writeChan respchan (Left $ "Can't find template file for " ++ T.unpack filename ++ ", looked in " ++ show searchpathes)+ else measure mvstats ("total - " <> filename) (computeTemplate (Right (head acceptablefiles)) scope variables mvstats) >>= writeChan respchan+ Left _ -> measure mvstats "total - inline" (computeTemplate fileinfo scope variables mvstats) >>= writeChan respchan templateDaemon modpath templatepath qchan mvstats -computeTemplate :: String -> String -> Map.Map String GeneralValue -> MStats -> IO TemplateAnswer-computeTemplate filename curcontext variables mstats = do- parsed <- measure mstats ("parsing - " ++ filename) $ parseErbFile filename+computeTemplate :: Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> MStats -> IO TemplateAnswer+computeTemplate fileinfo curcontext variables mstats = do+ let (filename, ufilename) = case fileinfo of+ Left _ -> ("inline", "inline")+ Right x -> (x, T.unpack x)+ parsed <- case fileinfo of+ Right _ -> measure mstats ("parsing - " <> filename) $ parseErbFile ufilename+ Left content -> measure mstats ("parsing - " <> filename) (return (runParser erbparser () "inline" (T.unpack content))) case parsed of Left err -> do- let !msg = "template " ++ filename ++ " could not be parsed " ++ show err+ let !msg = "template " ++ ufilename ++ " could not be parsed " ++ show err traceEventIO msg LOG.debugM "Erb.Compute" msg- measure mstats ("ruby - " ++ filename) $ computeTemplateWRuby filename curcontext variables+ measure mstats ("ruby - " <> filename) $ computeTemplateWRuby fileinfo curcontext variables Right ast -> case rubyEvaluate variables curcontext ast of Right ev -> return (Right ev) Left err -> do- let !msg = "template " ++ filename ++ " evaluation failed " ++ show err+ let !msg = "template " ++ ufilename ++ " evaluation failed " ++ show err traceEventIO msg LOG.debugM "Erb.Compute" msg- measure mstats ("ruby efail - " ++ filename) $ computeTemplateWRuby filename curcontext variables+ measure mstats ("ruby efail - " <> filename) $ computeTemplateWRuby fileinfo curcontext variables -computeTemplateWRuby :: String -> String -> Map.Map String GeneralValue -> IO TemplateAnswer-computeTemplateWRuby filename curcontext variables = do- let rubyvars = BB.string8 "{\n" <> mconcat (intersperse (BB.string8 ",\n") (concatMap toRuby (Map.toList variables))) <> BB.string8 "\n}\n" :: BB.Builder- input = BB.stringUtf8 curcontext <> BB.charUtf8 '\n' <> BB.stringUtf8 filename <> BB.charUtf8 '\n' <> rubyvars :: BB.Builder+saveTmpContent :: T.Text -> IO FilePath+saveTmpContent cnt = do+ (name, h) <- openTempFile "/tmp" "inline_template.erb"+ T.putStrLn cnt+ hClose h+ return name++computeTemplateWRuby :: Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> IO TemplateAnswer+computeTemplateWRuby fileinfo curcontext variables = do+ (temp, filename) <- case fileinfo of+ Right x -> return (Nothing, x)+ Left cnt -> do+ tmpfile <- saveTmpContent cnt+ return (Just tmpfile, "inline")+ let rubyvars = "{\n" <> mconcat (intersperse ",\n" (concatMap toRuby (Map.toList variables))) <> "\n}\n" :: T.Builder+ input = T.fromText curcontext <> "\n" <> T.fromText filename <> "\n" <> rubyvars :: T.Builder+ ufilename = T.unpack filename rubyscriptpath <- do- cabalPath <- getDataFileName "ruby/calcerb.rb"+ let rubybin = "calcerb.rb"+ cabalPath <- getDataFileName $ "ruby/" ++ T.unpack rubybin exists <- fileExist cabalPath- case exists of- True -> return cabalPath- False -> return "calcerb.rb"- traceEventIO ("start running ruby" ++ filename)- !ret <- safeReadProcessTimeout "ruby" [rubyscriptpath] (BB.toLazyByteString input) 1000- traceEventIO ("finished running ruby" ++ filename)+ if exists+ then return cabalPath+ else do+ path <- fmap (takeDirectory . T.pack) mGetExecutablePath+ let fullpath = path <> "/" <> rubybin+ lexists <- fileExist cabalPath+ return $ T.unpack $ if lexists+ then fullpath+ else rubybin+ traceEventIO ("start running ruby" ++ ufilename)+ !ret <- safeReadProcessTimeout "ruby" [rubyscriptpath] (T.toLazyText input) 1000+ traceEventIO ("finished running ruby" ++ ufilename)+ F.forM_ temp removeLink case ret of- Just (Right x) -> return $! Right (BS.unpack x)+ Just (Right x) -> return $! Right x Just (Left er) -> do (tmpfilename, tmphandle) <- openTempFile "/tmp" "templatefail"- BS.hPut tmphandle (BB.toLazyByteString input)+ TL.hPutStr tmphandle (T.toLazyText input) hClose tmphandle- return $ Left $ er ++ " - for template " ++ filename ++ " input in " ++ tmpfilename- Nothing -> do- return $ Left "Process did not terminate"+ return $ Left $ er ++ " - for template " ++ ufilename ++ " input in " ++ tmpfilename+ Nothing -> return $ Left "Process did not terminate" -minterc :: BB.Builder -> [BB.Builder] -> BB.Builder+minterc :: T.Builder -> [T.Builder] -> T.Builder minterc _ [] = mempty minterc _ [a] = a minterc !sep !(x:xs) = x <> foldl' minterc' mempty xs where minterc' !curbuilder !b = curbuilder <> sep <> b -getTemplateFile :: String -> CatalogMonad String-getTemplateFile rawpath = do- throwError rawpath-renderString :: String -> BB.Builder-renderString x = let !y = BB.stringUtf8 (show x) in y-{--renderString cs = BB.char8 '"' <> foldMap escape cs <> BB.char8 '"'- where- escape '\\' = BB.string8 "\\\\"- escape '\"' = BB.string8 "\\\""- escape '\n' = BB.string8 "\\n"- escape c = BB.charUtf8 c--}+getTemplateFile :: T.Text -> CatalogMonad T.Text+getTemplateFile = throwError+renderString :: T.Text -> T.Builder+renderString x = let !y = T.fromString (show x) in y++toRuby :: (T.Text, GeneralValue) -> [T.Builder] toRuby (_, Left _) = [] toRuby (_, Right ResolvedUndefined) = []-toRuby (varname, Right varval) = [BB.charUtf8 '\t' <> renderString varname <> BB.string8 " => " <> toRuby' varval]+toRuby (varname, Right varval) = ["\t" <> renderString varname <> " => " <> toRuby' varval] toRuby' (ResolvedString str) = renderString str-toRuby' (ResolvedInt i) = BB.charUtf8 '\'' <> BB.intDec (fromIntegral i) <> BB.charUtf8 '\''-toRuby' (ResolvedBool True) = BB.string8 "true"-toRuby' (ResolvedBool False) = BB.string8 "false"---toRuby' (ResolvedArray rr) = BB.charUtf8 '[' <> mconcat (intercalate [BB.string8 ", "] (map (return . toRuby') rr)) <> BB.charUtf8 ']'---toRuby' (ResolvedHash hh) = BB.string8 "{ " <> mconcat (intercalate [BB.string8 ", "] (map (\(varname, varval) -> [renderString varname <> BB.string8 " => " <> toRuby' varval]) hh)) <> BB.string8 " }"-toRuby' (ResolvedArray rr) = BB.charUtf8 '[' <> minterc (BB.string8 ", ") (map toRuby' rr) <> BB.charUtf8 ']'-toRuby' (ResolvedHash hh) = BB.string8 "{ " <> minterc (BB.string8 ", ") (map (\(varname, varval) -> renderString varname <> BB.string8 " => " <> toRuby' varval) hh) <> BB.string8 " }"-toRuby' ResolvedUndefined = BB.string8 ":undef"-toRuby' x = BB.string8 $ show x+toRuby' (ResolvedInt i) = "\'" <> T.decimal i <> "\'"+toRuby' (ResolvedBool True) = "true"+toRuby' (ResolvedBool False) = "false"+toRuby' (ResolvedArray rr) = "[" <> minterc ", " (map toRuby' rr) <> "]"+toRuby' (ResolvedHash hh) = "{ " <> minterc ", " (map (\(varname, varval) -> renderString varname <> " => " <> toRuby' varval) hh) <> " }"+toRuby' ResolvedUndefined = ":undef"+toRuby' (ResolvedRReference rtype (ResolvedString rname)) = renderString ( rtype <> "[" <> rname <> "]" )+toRuby' x = T.fromString $ show x
Erb/Evaluate.hs view
@@ -6,18 +6,19 @@ import Data.Maybe (catMaybes) import Data.Either (rights) import Control.Monad.Error-import Data.Char+import qualified Data.Text as T+import Puppet.Utils -rubyEvaluate :: Map.Map String GeneralValue -> String -> [RubyStatement] -> Either String String+rubyEvaluate :: Map.Map T.Text GeneralValue -> T.Text -> [RubyStatement] -> Either String T.Text rubyEvaluate vars ctx = foldl (evalruby vars ctx) (Right "") -evalruby :: Map.Map String GeneralValue -> String -> Either String String -> RubyStatement -> Either String String+evalruby :: Map.Map T.Text GeneralValue -> T.Text -> Either String T.Text -> RubyStatement -> Either String T.Text evalruby _ _ (Left err) _ = Left err evalruby mp ctx (Right curstr) (Puts e) = case evalExpression mp ctx e of Left err -> Left err- Right ex -> Right (curstr ++ ex)+ Right ex -> Right (curstr <> ex) -evalExpression :: Map.Map String GeneralValue -> String -> Expression -> Either String String+evalExpression :: Map.Map T.Text GeneralValue -> T.Text -> Expression -> Either String T.Text evalExpression mp ctx (LookupOperation varname varindex) = do rvname <- evalExpression mp ctx varname rvindx <- evalExpression mp ctx varindex@@ -25,35 +26,37 @@ case varvalue of ResolvedArray arr -> do case (a2i rvindx) of- Nothing -> throwError $ "Can't convert index to integer when resolving " ++ rvname ++ "[" ++ rvindx ++ "]"+ Nothing -> throwError $ "Can't convert index to integer when resolving " ++ T.unpack rvname ++ "[" ++ T.unpack rvindx ++ "]" Just i -> if length arr <= i- then throwError $ "Array out of bound " ++ rvname ++ "[" ++ rvindx ++ "]"+ then throwError $ "Array out of bound " ++ T.unpack rvname ++ "[" ++ T.unpack rvindx ++ "]" else return $ arr !! i return "x" ResolvedHash hs -> case (filter (\(a,_) -> a == rvindx) hs) of- [] -> throwError $ "No index " ++ rvindx ++ " for variable " ++ show varname+ [] -> throwError $ "No index " ++ T.unpack rvindx ++ " for variable " ++ show varname (_,x):_ -> evalValue $ Right x x -> throwError $ "Can't index variable " ++ show varname ++ ", it is " ++ show x evalExpression _ _ (Value (Literal x)) = Right x evalExpression mp ctx (Object (Value (Literal x))) = getVariable mp ctx x >>= evalValue . Right evalExpression _ _ x = Left $ "Can't evaluate " ++ show x -getVariable :: Map.Map String GeneralValue -> String -> String -> Either String ResolvedValue+getVariable :: Map.Map T.Text GeneralValue -> T.Text -> T.Text -> Either String ResolvedValue getVariable mp ctx rvname =- let vars = map (\x -> Map.lookup x mp) [rvname, ctx ++ "::" ++ rvname, "::" ++ rvname]+ let vars = map (\x -> Map.lookup x mp) [rvname, ctx <> "::" <> rvname, "::" <> rvname] jsts = catMaybes vars rghts = rights jsts in do- when (null jsts) (throwError $ "ERB: can't resolve variable " ++ rvname)- when (null rghts) (throwError $ "ERB: variable " ++ rvname ++ " value is not resolved")+ when (null jsts) (throwError $ "ERB: can't resolve variable " ++ T.unpack rvname)+ when (null rghts) (throwError $ "ERB: variable " ++ T.unpack rvname ++ " value is not resolved") return (head rghts) -evalValue :: GeneralValue -> Either String String+evalValue :: GeneralValue -> Either String T.Text evalValue (Left _) = Left $ "Can't evaluate a value" evalValue (Right (ResolvedString x)) = Right x-evalValue (Right (ResolvedInt x)) = Right $ show x-evalValue (Right x) = Right $ show x+evalValue (Right (ResolvedInt x)) = Right $ tshow x+evalValue (Right x) = Right $ tshow x -a2i :: String -> Maybe Int-a2i x | all isDigit x = read x- | otherwise = Nothing+a2i :: T.Text -> Maybe Int+a2i x = case readDecimal x of+ Right y -> Just y+ _ -> Nothing+
Erb/Parser.hs view
@@ -8,6 +8,7 @@ import Erb.Ruby import Text.Parsec.Expr import qualified Text.Parsec.Token as P+import qualified Data.Text as T def = emptyDef@@ -72,16 +73,16 @@ stringLiteral = doubleQuoted <|> singleQuoted -doubleQuoted = fmap (Value . Literal) $ between (char '"') (char '"') (many $ noneOf "\"")-singleQuoted = fmap (Value . Literal) $ between (char '\'') (char '\'') (many $ noneOf "'")+doubleQuoted = fmap (Value . Literal . T.pack) $ between (char '"') (char '"') (many $ noneOf "\"")+singleQuoted = fmap (Value . Literal . T.pack) $ between (char '\'') (char '\'') (many $ noneOf "'") objectterm = do- methodname <- identifier >>= return . Value . Literal+ methodname <- identifier >>= return . Value . Literal . T.pack nc <- lookAhead anyChar case nc of '{' -> do symbol "{"- b <- blockinfo+ b <- fmap T.pack blockinfo symbol "}" return $ MethodCall methodname (BlockOperation b) '(' -> do@@ -89,7 +90,7 @@ return $ MethodCall methodname (Value $ Array args) _ -> return $ Object methodname -variablereference = identifier >>= return . Object . Value . Literal+variablereference = identifier >>= return . Object . Value . Literal . T.pack rubystatement = rubyexpression >>= return . Puts @@ -99,7 +100,7 @@ let ns = case c of Just x -> x:s Nothing -> s- returned = Puts $ Value $ Literal ns+ returned = Puts $ Value $ Literal $ T.pack ns isend <- optionMaybe eof case isend of Just _ -> return [returned]
Erb/Ruby.hs view
@@ -1,7 +1,9 @@ module Erb.Ruby where +import qualified Data.Text as T+ data Value- = Literal !String+ = Literal !T.Text | Array ![Expression] deriving (Show, Ord, Eq) @@ -28,7 +30,7 @@ | ConditionalValue !Expression !Expression | Object !Expression | MethodCall !Expression !Expression- | BlockOperation !String+ | BlockOperation !T.Text | Value !Value | BTrue | BFalse
Puppet/DSL/Loader.hs view
@@ -4,11 +4,12 @@ import Puppet.DSL.Types import Puppet.DSL.Parser import Control.Monad.Error+import qualified Data.Text.IO as T -- | Helper function that takes a filename and parses its content in the 'ErrorT' monad. parseFile :: FilePath -> ErrorT String IO [Statement] parseFile fpath = do- result <- liftIO $ readFile fpath+ result <- liftIO $ T.readFile fpath case (runParser mparser () fpath result) of Left err -> throwError (show err) Right st -> return st
Puppet/DSL/Parser.hs view
@@ -16,18 +16,21 @@ exprparser ) where +import Puppet.DSL.Types+import Puppet.Utils+ import Data.Char-import Text.Parsec+import qualified Text.Parsec as TP+import Text.Parsec hiding (string)+import Text.Parsec.Text import qualified Text.Parsec.Token as P import Text.Parsec.Expr-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)+import qualified Data.Text as T -def = emptyDef+def = P.LanguageDef { P.commentStart = "/*" , P.commentEnd = "*/" , P.commentLine = "#"@@ -37,21 +40,25 @@ , P.reservedNames = ["if", "else", "case", "elsif", "default", "import", "define", "class", "node", "inherits", "true", "false", "undef"] , P.reservedOpNames= ["=>","=","+","-","/","*","+>","->","~>","!"] , P.caseSensitive = True+ , P.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"+ , P.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" } lexer = P.makeTokenParser def parens = P.parens lexer --braces = P.braces lexer --operator = P.operator lexer-symbol = P.symbol lexer+symbol = fmap T.pack . P.symbol lexer reservedOp = P.reservedOp lexer reserved = P.reserved lexer whiteSpace = P.whiteSpace lexer -- stringLiteral = P.stringLiteral lexer naturalOrFloat = P.naturalOrFloat lexer+string = fmap T.pack . TP.string -lowerFirstChar :: String -> String-lowerFirstChar x = toLower (head x) : tail x+lowerFirstChar :: T.Text -> T.Text+lowerFirstChar "" = ""+lowerFirstChar x = T.cons (toLower (T.head x)) (T.tail x) -- expression parser {-| This is a parser for Puppet 'Expression's. -}@@ -87,11 +94,15 @@ <|> puppetNumeric <|> puppetArray <|> puppetHash+ <|> puppetBool <|> try puppetResourceReference <|> try puppetFunctionCall <|> puppetLiteralValue <?> "Expression terminal" +puppetBool = fmap (Value . PuppetBool) ((reserved "true" >> return True) <|> (reserved "false" >> return False))++ hashRef = do { symbol "[" ; e <- exprparser ; symbol "]"@@ -107,11 +118,14 @@ [] -> return $ Value (VariableReference v) _ -> return $ makeLookupOperation v hashlist -makeLookupOperation :: String -> [Expression] -> Expression+makeLookupOperation :: T.Text -> [Expression] -> Expression+makeLookupOperation _ [] = error "Error in makeLookupOperation: empty list" makeLookupOperation name exprs = foldl LookupOperation (LookupOperation (Value (VariableReference name)) (head exprs)) (tail exprs) -identstring = many1 (alphaNum <|> char '_')+identstring :: Parser T.Text+identstring = fmap T.pack $ many1 (alphaNum <|> char '_') +identifier :: Parser T.Text identifier = do { x <- identstring ; whiteSpace@@ -154,14 +168,14 @@ ; firstletter <- lower ; parts <- identstring `sepBy` (try $ string "::") ; whiteSpace- ; return $ [firstletter] ++ (join "::" parts)+ ; return $ T.cons firstletter (T.intercalate "::" parts) } puppetQualifiedReference = do { optional (string "::") ; firstletter <- upper <?> "Uppercase letter for a reference" ; parts <- identstring `sepBy` (string "::") ; whiteSpace- ; return $ [toLower firstletter] ++ (join "::" $ map lowerFirstChar parts)+ ; return $ T.cons (toLower firstletter) (T.intercalate "::" $ map lowerFirstChar parts) } puppetFunctionCall = do { funcname <- identifier@@ -204,11 +218,12 @@ } -- no trailing whiteSpace+puppetVariable :: Parser T.Text puppetVariable = do char '$' choice- [ do { char '{' ; o <- many1 $ noneOf "}" ; char '}' ; return o }- , do { s <- option "" (string "::") ; o <- identstring `sepBy` (try $ string "::") ; return $ s ++ (join "::" o) }+ [ do { char '{' ; o <- many1 $ noneOf "}" ; char '}' ; return (T.pack o) }+ , do { s <- option "" (string "::") ; o <- identstring `sepBy` (try $ string "::") ; return (s <> (T.intercalate "::" o)) } ] variableAssignment = do@@ -223,6 +238,7 @@ -- types de base -- puppetLiteral : toutes les strings puppet +puppetLiteral :: Parser T.Text puppetLiteral = doubleQuotedString <|> singleQuotedString <|> puppetQualifiedName@@ -232,10 +248,11 @@ ; return (Value (Literal v)) } +puppetRegexp :: Parser T.Text puppetRegexp = do { char '/' ; v <- many ( do { char '\\' ; x <- anyChar; return ['\\', x] } <|> many1 (noneOf "/\\") ) ; symbol "/"- ; return $ concat v+ ; return $ T.pack $ concat v } puppetRegexpExpr = puppetRegexp >>= return . Value . PuppetRegexp@@ -244,7 +261,7 @@ ; v <- many ( do { char '\\' ; x <- anyChar; if x=='\'' then return "'" else return ['\\',x] } <|> many1 (noneOf "'\\") ) ; char '\'' ; whiteSpace- ; return $ concat v+ ; return $ T.pack $ concat v } doubleQuotedString = do { char '"'@@ -274,7 +291,7 @@ } doubleQuotedStringContent = do { x <- many1 (do { char '\\' ; x <- anyChar; return [stringEscape x] } <|> many1 (noneOf "\"\\$") )- ; return $ concat x+ ; return $ T.pack $ concat x } stringEscape 'n' = '\n'@@ -485,7 +502,8 @@ ; let refToPair (Value (ResourceReference rtype name)) = (rtype, name) refToPair x = error $ "Could not run refToPair on " ++ show x ; let pairs = map refToPair refs- ; let refpairs = zip pairs (tail pairs)+ ; let refpairs | null pairs = []+ | otherwise = zip pairs (tail pairs) ; return $ map (\((n1,v1),(n2,v2)) -> DependenceChain (n1,v1) (n2,v2) pos) refpairs } @@ -512,6 +530,7 @@ <|> puppetMainFunctionCall <?> "Statement" +mparser :: Parser [Statement] mparser = do { whiteSpace ; result <- many stmtparser
Puppet/DSL/Printer.hs view
@@ -7,23 +7,27 @@ import Puppet.DSL.Types import qualified Data.Map as Map import Text.Parsec.Pos+import qualified Data.Text as T -- | This shows the parsed AST a bit like the original syntax. showAST :: [Statement] -> String showAST x = render (vcat (map showStatement x)) +ttext :: T.Text -> Doc+ttext = text . T.unpack+ showStatement :: Statement -> Doc-showStatement (Node name x _) = text "node" <+> text name <+> lbrace $$ nest 4 (vcat (map showStatement x)) $$ rbrace-showStatement (VariableAssignment name x _) = text "$" <> text name <+> text "=" <+> showExpression x+showStatement (Node name x _) = text "node" <+> ttext name <+> lbrace $$ nest 4 (vcat (map showStatement x)) $$ rbrace+showStatement (VariableAssignment name x _) = text "$" <> ttext name <+> text "=" <+> showExpression x showStatement (Include inc _) = text("include") <+> showExpression inc-showStatement (Require req _) = text("require " ++ req)-showStatement (Resource rtype rname params Normal _) = text (rtype) <+> lbrace <+> showExpression rname <> text ":" $$ nest 4 ( showAssignments params ) <> text ";" $$ rbrace +showStatement (Require req _) = text "require" <+> ttext req+showStatement (Resource rtype rname params Normal _) = ttext rtype <+> lbrace <+> showExpression rname <> text ":" $$ nest 4 ( showAssignments params ) <> text ";" $$ rbrace showStatement (Resource rtype rname params Virtual p) = text "@" <> showStatement (Resource rtype rname params Normal p) showStatement (Resource rtype rname params Exported p) = text "@@" <> showStatement (Resource rtype rname params Normal p)-showStatement (ResourceDefault rtype params _) = text (rtype) <+> braces (showAssignments params)-showStatement (ClassDeclaration cname Nothing params statements _) = text "class" <+> text cname <+> parens ( hcat (punctuate (text ",") (map showOptionalParameter params)) ) <+> lbrace $$ nest 4 (vcat (map showStatement statements)) $$ rbrace-showStatement (ClassDeclaration cname (Just parent) params statements _) = text "class" <+> text cname <> parens ( hcat (punctuate (text ",") (map showOptionalParameter params)) ) <+> text "inherits" <+> text parent <+> lbrace $$ nest 4 (vcat (map showStatement statements)) $$ rbrace-showStatement (DefineDeclaration cname params statements _) = text "define" <+> text cname <+> parens ( hcat (punctuate (text ",") (map showOptionalParameter params)) ) <+> lbrace $$ nest 4 (vcat (map showStatement statements)) $$ rbrace+showStatement (ResourceDefault rtype params _) = ttext rtype <+> braces (showAssignments params)+showStatement (ClassDeclaration cname Nothing params statements _) = text "class" <+> ttext cname <+> parens ( hcat (punctuate (text ",") (map showOptionalParameter params)) ) <+> lbrace $$ nest 4 (vcat (map showStatement statements)) $$ rbrace+showStatement (ClassDeclaration cname (Just parent) params statements _) = text "class" <+> ttext cname <> parens ( hcat (punctuate (text ",") (map showOptionalParameter params)) ) <+> text "inherits" <+> ttext parent <+> lbrace $$ nest 4 (vcat (map showStatement statements)) $$ rbrace+showStatement (DefineDeclaration cname params statements _) = text "define" <+> ttext cname <+> parens ( hcat (punctuate (text ",") (map showOptionalParameter params)) ) <+> lbrace $$ nest 4 (vcat (map showStatement statements)) $$ rbrace showStatement (ConditionalStatement x _) = text "CONDITION LIST" $$ nest 4 ( vcat (map showCondition x) ) showStatement x = text (show x) @@ -31,9 +35,9 @@ showCondition (BTrue, []) = empty showCondition (e, stmts) = showExpression e <+> text "{" $$ nest 4 ( vcat (map showStatement stmts)) $$ text "}" -showOptionalParameter :: (String, Maybe Expression) -> Doc-showOptionalParameter (param, Nothing) = text "$" <> text param-showOptionalParameter (param, (Just e)) = text "$" <> text param <+> text "=" <+> showExpression e+showOptionalParameter :: (T.Text, Maybe Expression) -> Doc+showOptionalParameter (param, Nothing) = text "$" <> ttext param+showOptionalParameter (param, (Just e)) = text "$" <> ttext param <+> text "=" <+> showExpression e showExpressionBuilder :: String -> Expression -> Expression -> Doc showExpressionBuilder symb a b = char '(' <> showExpression a <+> text symb <+> showExpression b <> char ')'@@ -66,10 +70,10 @@ showValue :: Value -> Doc showValue (Literal x) = text( show x )-showValue (VariableReference x) = text "$" <> text x-showValue (FunctionCall funcname args) = text funcname <> parens ( hcat (map showExpression args ) )+showValue (VariableReference x) = text "$" <> ttext x+showValue (FunctionCall funcname args) = ttext funcname <> parens ( hcat (map showExpression args ) ) showValue (PuppetArray x) = brackets ( hcat ( punctuate (text ", ") (map showExpression x)))-showValue (ResourceReference rtype rname) = text rtype <> brackets (showExpression rname)+showValue (ResourceReference rtype rname) = ttext rtype <> brackets (showExpression rname) showValue (PuppetHash (Parameters params)) = hang lbrace 2 (showAssignments params) $$ rbrace showValue (Integer x) = integer x showValue x = text (show x)
Puppet/DSL/Types.hs view
@@ -3,10 +3,9 @@ module Puppet.DSL.Types where import Text.Parsec.Pos-import Data.List (intercalate) import Data.Char (toUpper)-import Data.String.Utils (split)-+import qualified Data.Text as T+import Data.String data Parameters = Parameters ![(Expression, Expression)] deriving(Show, Ord, Eq) @@ -28,7 +27,7 @@ -- |This function returns the 'TopLevelType' of a statement if it is either a -- node, class or define. It returns Nothing otherwise.-convertTopLevel :: Statement -> Either Statement (TopLevelType, String, Statement)+convertTopLevel :: Statement -> Either Statement (TopLevelType, T.Text, Statement) convertTopLevel x@(Node name _ _) = Right (TopNode, name, x) convertTopLevel x@(ClassDeclaration name _ _ _ _) = Right (TopClass, name, x) convertTopLevel x@(DefineDeclaration name _ _ _) = Right (TopDefine, name, x)@@ -38,46 +37,50 @@ -- 'Expression' data Value -- |String literal.- = Literal !String+ = Literal !T.Text -- |An interpolable string, represented as a 'Value' list. | Interpolable ![Value] -- |A Puppet Regexp. This is very hackish as it alters the behaviour of some -- functions (such as conditional values).- | PuppetRegexp !String+ | PuppetRegexp !T.Text | Double !Double | Integer !Integer -- |Reference to a variable. The string contains what is acutally typed in -- the manifest.- | VariableReference !String+ | VariableReference !T.Text | Empty- | ResourceReference !String !Expression -- restype resname+ | ResourceReference !T.Text !Expression -- restype resname | PuppetArray ![Expression] | PuppetHash !Parameters- | FunctionCall !String ![Expression]+ | FunctionCall !T.Text ![Expression]+ | PuppetBool Bool -- |This is special and quite hackish too. | Undefined deriving(Show, Ord, Eq) +instance IsString Value where+ fromString = Literal . fromString+ data Virtuality = Normal | Virtual | Exported deriving(Show, Ord, Eq) -- | The actual puppet statements data Statement- = Node String ![Statement] !SourcePos -- ^ This holds the node name and list of statements.+ = Node T.Text ![Statement] !SourcePos -- ^ This holds the node name and list of statements. -- | This holds the variable name and the expression that it represents.- | VariableAssignment !String !Expression !SourcePos+ | VariableAssignment !T.Text !Expression !SourcePos | Include !Expression !SourcePos- | Import !String !SourcePos- | Require !String !SourcePos+ | Import !T.Text !SourcePos+ | Require !T.Text !SourcePos -- | This holds the resource type, name, parameter list and virtuality.- | Resource !String !Expression ![(Expression, Expression)] !Virtuality !SourcePos+ | Resource !T.Text !Expression ![(Expression, Expression)] !Virtuality !SourcePos {-| This is a resource default declaration, such as File {owner => \'root\'; }. It holds the resource type and the list of default parameters. -}- | ResourceDefault !String ![(Expression, Expression)] !SourcePos+ | ResourceDefault !T.Text ![(Expression, Expression)] !SourcePos {-| This works like 'Resource', but the 'Expression' holds the resource name. -}- | ResourceOverride !String !Expression ![(Expression, Expression)] !SourcePos+ | ResourceOverride !T.Text !Expression ![(Expression, Expression)] !SourcePos {-| The pairs hold on the left a value that is resolved as a boolean, and on the right the list of statements that correspond to this. This will be generated by if\/then\/else statement, but also by the case statement.@@ -87,28 +90,28 @@ class it inherits from, a list of parameters with optional default values, and the list of statements it contains. -}- | ClassDeclaration !String !(Maybe String) ![(String, Maybe Expression)] ![Statement] !SourcePos+ | ClassDeclaration !T.Text !(Maybe T.Text) ![(T.Text, Maybe Expression)] ![Statement] !SourcePos {-| The define declaration is like the 'ClassDeclaration' except it can't inherit from anything. -}- | DefineDeclaration !String ![(String, Maybe Expression)] ![Statement] !SourcePos+ | DefineDeclaration !T.Text ![(T.Text, Maybe Expression)] ![Statement] !SourcePos {-| This is the resource collection syntax (\<\<\| \|\>\>). It holds the conditional expression, and an eventual list of overrides. This is important as the same token conveys two distinct Puppet concepts : resource collection and resource overrides. -}- | ResourceCollection !String !Expression ![(Expression, Expression)] !SourcePos+ | ResourceCollection !T.Text !Expression ![(Expression, Expression)] !SourcePos -- |Same as 'ResourceCollection', but for \<\| \|\>.- | VirtualResourceCollection !String !Expression ![(Expression, Expression)] !SourcePos- | DependenceChain !(String,Expression) !(String,Expression) !SourcePos- | MainFunctionCall !String ![Expression] !SourcePos+ | VirtualResourceCollection !T.Text !Expression ![(Expression, Expression)] !SourcePos+ | DependenceChain !(T.Text,Expression) !(T.Text,Expression) !SourcePos+ | MainFunctionCall !T.Text ![Expression] !SourcePos {-| This is a magic statement that is used to hold the spurious top level statements that comes in the same file as the correct top level statement that is stored in the second field. The first field contains pairs of filenames and statements. This is designed so that the interpreter can know whether it has already been evaluated. -}- | TopContainer ![(String, Statement)] !Statement -- magic statement that is used to embody the spurious top level statements+ | TopContainer ![(T.Text, Statement)] !Statement -- magic statement that is used to embody the spurious top level statements deriving(Show, Ord, Eq) -- | Expressions will be described with a and b being the first and second field@@ -138,18 +141,20 @@ | ConditionalValue !Expression !Expression -- ^ a ? b (b should be a 'PuppetHash') | Value !Value -- ^ 'Value' terminal- | ResolvedResourceReference !String !String -- ^ Resolved resource reference+ | ResolvedResourceReference !T.Text !T.Text -- ^ Resolved resource reference | BTrue -- ^ True expression, this could have been better to use a 'Value' | BFalse -- ^ False expression- | Error !String -- ^ Not used anymore. deriving(Show, Ord, Eq) +instance IsString Expression where+ fromString = Value . fromString+ -- function that capitalizes types so that they look good-capitalizeResType :: String -> String-capitalizeResType = intercalate "::" . map capitalize' . split "::"+capitalizeResType :: T.Text -> T.Text+capitalizeResType = T.intercalate "::" . map capitalize' . T.splitOn "::" -capitalize' :: String -> String+capitalize' :: T.Text -> T.Text capitalize' "" = ""-capitalize' (x:xs) = toUpper x : xs+capitalize' t = T.cons (toUpper (T.head t)) (T.tail t)
Puppet/Daemon.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} module Puppet.Daemon (initDaemon) where import Puppet.Init@@ -6,34 +5,33 @@ import Puppet.Interpreter.Catalog import Puppet.DSL.Types import Puppet.DSL.Loader-import PuppetDB.Rest+import Puppet.Utils import Erb.Compute import Control.Concurrent import System.Posix.Files import System.FilePath.Glob (globDir, compile)-import System.FilePath.Posix (takeDirectory) import Control.Monad.State import Control.Monad.Error import qualified System.Log.Logger as LOG import Data.List import Data.Either (rights, lefts) import Data.Foldable (foldlM)-import qualified Data.List.Utils as DLU import qualified Data.Map as Map import Text.Parsec.Pos (initialPos) import Puppet.Stats import Debug.Trace+import qualified Data.Text as T -- this daemon returns a catalog when asked for a node and facts data DaemonMessage- = QCatalog (String, Facts, Chan DaemonMessage)+ = QCatalog (T.Text, Facts, Chan DaemonMessage) | RCatalog (Either String (FinalCatalog, EdgeMap, FinalCatalog)) -logDebug = LOG.debugM "Puppet.Daemon"-logInfo = LOG.infoM "Puppet.Daemon"-logWarning = LOG.warningM "Puppet.Daemon"-logError = LOG.errorM "Puppet.Daemon"+logDebug = LOG.debugM "Puppet.Daemon" . T.unpack+logInfo = LOG.infoM "Puppet.Daemon" . T.unpack+logWarning = LOG.warningM "Puppet.Daemon" . T.unpack+logError = LOG.errorM "Puppet.Daemon" . T.unpack {-| This is a high level function, that will initialize the parsing and interpretation infrastructure from the 'Prefs' structure, and will return a@@ -75,7 +73,7 @@ is not existent. This will need fixing. -}-initDaemon :: Prefs -> IO ( String -> Facts -> IO(Either String (FinalCatalog, EdgeMap, FinalCatalog)), IO StatsTable, IO StatsTable, IO StatsTable )+initDaemon :: Prefs -> IO ( T.Text -> Facts -> IO(Either String (FinalCatalog, EdgeMap, FinalCatalog)), IO StatsTable, IO StatsTable, IO StatsTable ) initDaemon prefs = do logDebug "initDaemon" traceEventIO "initDaemon"@@ -90,21 +88,18 @@ master :: Prefs -> Chan DaemonMessage- -> (TopLevelType -> String -> IO (Either String Statement))- -> (String -> String -> Map.Map String GeneralValue -> IO (Either String String))+ -> (TopLevelType -> T.Text -> IO (Either String Statement))+ -> (Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> IO (Either String T.Text)) -> MStats -> IO () master prefs chan getstmts gettemplate mstats = do message <- readChan chan case message of QCatalog (nodename, facts, respchan) -> do- logDebug ("Received query for node " ++ nodename)- traceEventIO ("Received query for node " ++ nodename)- let pdbfunc = case (puppetDBurl prefs) of- Just x -> Just (pdbResRequest x)- Nothing -> Nothing- (!stmts, !warnings) <- measure mstats nodename $ getCatalog getstmts gettemplate pdbfunc nodename facts (Just $ modules prefs) (natTypes prefs)- traceEventIO ("getCatalog finished for " ++ nodename)+ logDebug ("Received query for node " <> nodename)+ traceEventIO ("Received query for node " <> T.unpack nodename)+ (!stmts, !warnings) <- measure mstats nodename $ getCatalog getstmts gettemplate (puppetDBquery prefs) nodename facts (Just $ modules prefs) (natTypes prefs)+ traceEventIO ("getCatalog finished for " <> T.unpack nodename) mapM_ logWarning warnings case stmts of Left x -> writeChan respchan (RCatalog $ Left x)@@ -112,7 +107,7 @@ _ -> logError "Bad message type for master" master prefs chan getstmts gettemplate mstats -gCatalog :: Chan DaemonMessage -> String -> Facts -> IO (Either String (FinalCatalog, EdgeMap, FinalCatalog))+gCatalog :: Chan DaemonMessage -> T.Text -> Facts -> IO (Either String (FinalCatalog, EdgeMap, FinalCatalog)) gCatalog channel nodename facts = do respchan <- newChan writeChan channel $ QCatalog (nodename, facts, respchan)@@ -123,11 +118,11 @@ -- this daemon returns a list of statements when asked for a top class/define name data ParserMessage- = QStatement (TopLevelType, String, Chan ParserMessage)+ = QStatement (TopLevelType, T.Text, Chan ParserMessage) | RStatement (Either String Statement) initParserDaemon :: Prefs -> MStats -> IO- ( TopLevelType -> String -> IO (Either String Statement)+ ( TopLevelType -> T.Text -> IO (Either String Statement) ) initParserDaemon prefs mstats = do logDebug "initParserDaemon"@@ -164,25 +159,27 @@ Just nfstatus -> return (extractFStatus nfstatus == extractFStatus fstatus) Nothing -> return False -compilefilelist :: Prefs -> TopLevelType -> String -> [FilePath]-compilefilelist prefs TopNode _ = [manifest prefs ++ "/site.pp"]+compilefilelist :: Prefs -> TopLevelType -> T.Text -> [T.Text]+compilefilelist prefs TopNode _ = [manifest prefs <> "/site.pp"] compilefilelist prefs _ name = moduleInfo where- moduleInfo | length nameparts == 1 = [modules prefs ++ "/" ++ name ++ "/manifests/init.pp"]- | otherwise = [modules prefs ++ "/" ++ head nameparts ++ "/manifests/" ++ DLU.join "/" (tail nameparts) ++ ".pp"]- nameparts = DLU.split "::" name+ moduleInfo | length nameparts == 1 = [modules prefs <> "/" <> name <> "/manifests/init.pp"]+ | null nameparts = ["no name parts, error in compilefilelist"]+ | otherwise = [modules prefs <> "/" <> head nameparts <> "/manifests/" <> T.intercalate "/" (tail nameparts) <> ".pp"]+ nameparts = T.splitOn "::" name :: [T.Text] -findFile :: Prefs -> TopLevelType -> String -> ErrorT String IO (FilePath, FileStatus)+findFile :: Prefs -> TopLevelType -> T.Text -> ErrorT String IO (FilePath, FileStatus) findFile prefs qtype resname = do- let filelist = compilefilelist prefs qtype resname+ let filelist = map T.unpack $ compilefilelist prefs qtype resname fileinfo <- liftIO $ foldlM getFirstFileInfo Nothing filelist case fileinfo of Just x -> return x- Nothing -> throwError ("Could not find file for " ++ show qtype ++ " " ++ resname ++ " when looking in " ++ show filelist)+ Nothing -> throwError ("Could not find file for " ++ show qtype ++ " " ++ T.unpack resname ++ " when looking in " ++ show filelist) globImport :: FilePath -> Statement -> ErrorT String IO [FilePath]-globImport origfile (Import importname ipos) = do- importedfiles <- liftM (concat . fst) (liftIO $ globDir [compile importname] (takeDirectory origfile))+globImport origfile (Import timportname ipos) = do+ let importname = T.unpack timportname+ importedfiles <- liftM (concat . fst) (liftIO $ globDir [compile importname] (T.unpack $ takeDirectory $ T.pack origfile)) if null importedfiles then throwError $ "Could not import " ++ importname ++ " at " ++ show ipos else return importedfiles@@ -193,9 +190,10 @@ it must also parse all required files and store everything about them before returning -}-loadUpdateFile :: FilePath -> FileStatus -> (TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse ) -> ErrorT String IO ([Statement], [(TopLevelType, String, Statement)])+loadUpdateFile :: FilePath -> FileStatus -> (TopLevelType -> T.Text -> CacheEntry -> IO ParsedCacheResponse ) -> ErrorT String IO ([Statement], [(TopLevelType, T.Text, Statement)]) loadUpdateFile fname fstatus updatepinfo = do- liftIO $ logDebug ("Loading file " ++ fname)+ let tfname = T.pack fname+ liftIO $ logDebug ("Loading file " <> tfname) parsed <- parseFile fname let toplevels = map convertTopLevel parsed oktoplevels = rights toplevels@@ -203,33 +201,33 @@ (imports, spurioustoplevels) = partition isImport othertoplevels isImport (Import _ _) = True isImport _ = False- relatedtops <- liftM concat (mapM (globImport fname) imports)+ relatedtops <- liftM (map T.pack . concat) (mapM (globImport fname) imports) -- save this spurious top levels unless (null spurioustoplevels) $ do- liftIO $ void ( updatepinfo TopSpurious fname (ClassDeclaration "::" Nothing [] spurioustoplevels (initialPos fname), fname, fstatus, relatedtops) )- liftIO $ logWarning ("Spurious top level statement in file " ++ fname ++ ", expect bugs in case you modify them" )+ liftIO $ void ( updatepinfo TopSpurious tfname (ClassDeclaration "::" Nothing [] spurioustoplevels (initialPos fname), tfname, fstatus, relatedtops) )+ liftIO $ logWarning ("Spurious top level statement in file " <> tfname <> ", expect bugs in case you modify them" ) -- saves all good top levels- liftIO $ mapM (\(rtype, resname, resstatement) -> updatepinfo rtype resname (resstatement, fname, fstatus, relatedtops)) oktoplevels+ liftIO $ mapM (\(rtype, resname, resstatement) -> updatepinfo rtype resname (resstatement, tfname, fstatus, relatedtops)) oktoplevels return (imports, oktoplevels) -reparseStatements :: Prefs -> (TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse ) -> TopLevelType -> String -> ErrorT String IO Statement+reparseStatements :: Prefs -> (TopLevelType -> T.Text -> CacheEntry -> IO ParsedCacheResponse ) -> TopLevelType -> T.Text -> ErrorT String IO Statement reparseStatements prefs updatepinfo qtype nodename = do (fname, fstatus) <- findFile prefs qtype nodename reparseFile fname fstatus updatepinfo qtype nodename -reparseFile :: FilePath -> FileStatus -> (TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse ) -> TopLevelType -> String -> ErrorT String IO Statement+reparseFile :: FilePath -> FileStatus -> (TopLevelType -> T.Text -> CacheEntry -> IO ParsedCacheResponse ) -> TopLevelType -> T.Text -> ErrorT String IO Statement reparseFile fname fstatus updatepinfo qtype nodename = do (imports, oktoplevels) <- loadUpdateFile fname fstatus updatepinfo imported <- liftM concat (mapM (loadImport updatepinfo fname) imports) let searchstatement = find (\(qt,nm,_) -> (qt == qtype) && (nm == nodename)) (oktoplevels ++ imported) case searchstatement of Just (_,_,x) -> return x- Nothing -> throwError ("Could not find correct top level statement for " ++ show qtype ++ " " ++ nodename)+ Nothing -> throwError ("Could not find correct top level statement for " ++ show qtype ++ " " ++ T.unpack nodename) {- Given a base file name and an import statement, will load these imports. This is not as obvious as it seems because you need to load imported's imports. -}-loadImport :: (TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse ) -> FilePath -> Statement -> ErrorT String IO [(TopLevelType, String, Statement)]+loadImport :: (TopLevelType -> T.Text -> CacheEntry -> IO ParsedCacheResponse ) -> FilePath -> Statement -> ErrorT String IO [(TopLevelType, T.Text, Statement)] loadImport updatepinfo fdir mimport = do matched <- globImport fdir mimport fileinfos <- liftIO $ mapM getFileInfo matched@@ -245,10 +243,10 @@ mapM_ (\(fname, mimports) -> mapM_ (\stmt -> loadImport updatepinfo fname stmt) mimports) limports return $ reloaded -loadRelated :: - ( TopLevelType -> String -> ErrorT String IO (Maybe CacheEntry) )- -> FilePath- -> ErrorT String IO [(String, Statement)]+loadRelated ::+ ( TopLevelType -> T.Text -> ErrorT String IO (Maybe CacheEntry) )+ -> T.Text+ -> ErrorT String IO [(T.Text, Statement)] loadRelated getpinfo filename = do res <- getpinfo TopSpurious filename case res of@@ -258,22 +256,23 @@ return $ (filename,stmts):relstatements handlePRequest :: Prefs ->- ( TopLevelType -> String -> ErrorT String IO (Maybe CacheEntry)- , TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse- , String -> IO ParsedCacheResponse- ) -> TopLevelType -> String -> ErrorT String IO Statement+ ( TopLevelType -> T.Text -> ErrorT String IO (Maybe CacheEntry)+ , TopLevelType -> T.Text -> CacheEntry -> IO ParsedCacheResponse+ , T.Text -> IO ParsedCacheResponse+ ) -> TopLevelType -> T.Text -> ErrorT String IO Statement handlePRequest prefs (getpinfo, updatepinfo, invalidateinfo) qtype nodename = do res <- getpinfo qtype nodename case res of- Just (stmts, fpath, fstatus, related) -> do+ Just (stmts, tfpath, fstatus, related) -> do -- for this to work, everything must be cached -- this is buggy as the required stuff will not be invalidated properly- relstatements <- liftM concat (mapM (loadRelated getpinfo) (fpath:related))+ let fpath = T.unpack tfpath+ relstatements <- liftM concat (mapM (loadRelated getpinfo) (tfpath:related)) isfileinfoaccurate <- checkFileInfo fpath fstatus statements <- if isfileinfoaccurate then return stmts else do- liftIO $ invalidateinfo fpath+ liftIO $ invalidateinfo tfpath finfo <- liftIO $ getFileInfo fpath case finfo of Just fstat -> reparseFile fpath fstat updatepinfo qtype nodename@@ -284,9 +283,9 @@ Nothing -> reparseStatements prefs updatepinfo qtype nodename >> handlePRequest prefs (getpinfo, updatepinfo, invalidateinfo) qtype nodename pmaster :: Prefs -> Chan ParserMessage ->- ( TopLevelType -> String -> ErrorT String IO (Maybe CacheEntry)- , TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse- , String -> IO ParsedCacheResponse+ ( TopLevelType -> T.Text -> ErrorT String IO (Maybe CacheEntry)+ , TopLevelType -> T.Text -> CacheEntry -> IO ParsedCacheResponse+ , T.Text -> IO ParsedCacheResponse ) -> IO () pmaster prefs chan cachefuncs = do pmessage <- readChan chan@@ -299,7 +298,7 @@ _ -> logError "Bad message type received by Puppet.Daemon.pmaster" pmaster prefs chan cachefuncs -getStatements :: Chan ParserMessage -> TopLevelType -> String -> IO (Either String Statement)+getStatements :: Chan ParserMessage -> TopLevelType -> T.Text -> IO (Either String Statement) getStatements channel qtype classname = do respchan <- newChan writeChan channel $ QStatement (qtype, classname, respchan)@@ -310,22 +309,22 @@ -- this is a cache entry, it stores a top level statement, the path of the corresponding file and its status -- it also stores a list of top level statements that are related-type CacheEntry = (Statement, FilePath, FileStatus, [FilePath])+type CacheEntry = (Statement, T.Text, FileStatus, [T.Text]) data ParsedCacheQuery- = GetParsedData TopLevelType String (Chan ParsedCacheResponse)- | UpdateParsedData TopLevelType String CacheEntry (Chan ParsedCacheResponse)- | InvalidateCacheFile String (Chan ParsedCacheResponse)+ = GetParsedData TopLevelType T.Text (Chan ParsedCacheResponse)+ | UpdateParsedData TopLevelType T.Text CacheEntry (Chan ParsedCacheResponse)+ | InvalidateCacheFile T.Text (Chan ParsedCacheResponse) data ParsedCacheResponse- = CacheError String+ = CacheError T.Text | RCacheEntry CacheEntry | NoCacheEntry | CacheUpdated -- this one is singleton, and is used to cache de parsed values, along with the file names they depend on initParsedDaemon :: Prefs -> MStats -> IO- ( TopLevelType -> String -> ErrorT String IO (Maybe CacheEntry)- , TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse- , String -> IO ParsedCacheResponse+ ( TopLevelType -> T.Text -> ErrorT String IO (Maybe CacheEntry)+ , TopLevelType -> T.Text -> CacheEntry -> IO ParsedCacheResponse+ , T.Text -> IO ParsedCacheResponse ) initParsedDaemon prefs mstats = do logDebug "initParsedDaemon"@@ -333,7 +332,7 @@ forkIO ( evalStateT (parsedmaster prefs controlChan mstats) (Map.empty, Map.empty) ) return (getParsedInformation controlChan, updateParsedInformation controlChan, invalidateCachedFile controlChan) -getParsedInformation :: Chan ParsedCacheQuery -> TopLevelType -> String -> ErrorT String IO (Maybe CacheEntry)+getParsedInformation :: Chan ParsedCacheQuery -> TopLevelType -> T.Text -> ErrorT String IO (Maybe CacheEntry) getParsedInformation cchan qtype name = do respchan <- liftIO newChan liftIO $ writeChan cchan $ GetParsedData qtype name respchan@@ -341,16 +340,16 @@ case out of RCacheEntry x -> return $ Just x NoCacheEntry -> return Nothing- CacheError x -> throwError x+ CacheError x -> throwError (T.unpack x) _ -> throwError "Unknown cache response type" -updateParsedInformation :: Chan ParsedCacheQuery -> TopLevelType -> String -> CacheEntry -> IO ParsedCacheResponse+updateParsedInformation :: Chan ParsedCacheQuery -> TopLevelType -> T.Text -> CacheEntry -> IO ParsedCacheResponse updateParsedInformation pchannel qtype name centry = do respchan <- newChan writeChan pchannel $ UpdateParsedData qtype name centry respchan readChan respchan -invalidateCachedFile :: Chan ParsedCacheQuery -> String -> IO ParsedCacheResponse+invalidateCachedFile :: Chan ParsedCacheQuery -> T.Text -> IO ParsedCacheResponse invalidateCachedFile pchannel name = do respchan <- newChan writeChan pchannel $ InvalidateCacheFile name respchan@@ -358,8 +357,8 @@ -- state : (parsed statements map, file association map, nbrequests) parsedmaster :: Prefs -> Chan ParsedCacheQuery -> MStats -> StateT - ( Map.Map (TopLevelType, String) CacheEntry- , Map.Map FilePath (FileStatus, [(TopLevelType, String)])+ ( Map.Map (TopLevelType, T.Text) CacheEntry+ , Map.Map T.Text (FileStatus, [(TopLevelType, T.Text)]) ) IO () parsedmaster prefs controlchan mstats = do curmsg <- liftIO $ readChan controlchan@@ -370,7 +369,7 @@ Just x -> liftIO $ measure mstats "hit" (writeChan respchan (RCacheEntry x)) Nothing -> liftIO $ measure mstats "miss" (writeChan respchan NoCacheEntry) UpdateParsedData qtype name val@(_, filepath, filestatus, _) respchan -> do- liftIO $ logInfo ("Updating parsed cache for " ++ show qtype ++ " " ++ name)+ liftIO $ logInfo ("Updating parsed cache for " <> tshow qtype <> " " <> name) (mp, fm) <- get let -- retrieve the current status@@ -386,7 +385,7 @@ put (statementmap, fileassocmap) liftIO $ measure mstats "update" (writeChan respchan CacheUpdated) InvalidateCacheFile fname respchan -> do- liftIO $ logDebug $ "Invalidating files for " ++ fname+ liftIO $ logDebug $ "Invalidating files for " <> fname (mp, fm) <- get let nfm = Map.delete fname fm
Puppet/Init.hs view
@@ -5,35 +5,42 @@ import Puppet.NativeTypes import Puppet.NativeTypes.Helpers import Puppet.Plugins+import qualified PuppetDB.Query as PDB+import Puppet.Utils +import Data.Aeson import qualified Data.Map as Map+import qualified Data.Vector as V+import qualified Data.Text as T data Prefs = Prefs {- manifest :: FilePath, -- ^ The path to the manifests.- modules :: FilePath, -- ^ The path to the modules.- templates :: FilePath, -- ^ The path to the template.+ manifest :: T.Text, -- ^ The path to the manifests.+ modules :: T.Text, -- ^ The path to the modules.+ templates :: T.Text, -- ^ The path to the template. compilepoolsize :: Int, -- ^ Size of the compiler pool.- parsepoolsize :: Int, -- ^ Size of the parser pool.- erbpoolsize :: Int, -- ^ Size of the template pool.- puppetDBurl :: Maybe String, -- ^ Url of the PuppetDB connector (must be cleartext).- natTypes :: Map.Map PuppetTypeName PuppetTypeMethods -- ^ The list of native types.+ parsepoolsize :: Int, -- ^ Size of the parser pool.+ erbpoolsize :: Int, -- ^ Size of the template pool.+ puppetDBquery :: T.Text -> PDB.Query -> IO (Either String Value), -- ^ A function that takes a query type, a query and might return stuff+ natTypes :: Map.Map PuppetTypeName PuppetTypeMethods -- ^ The list of native types. } -- | Generates the 'Prefs' structure from a single path. -- -- > genPrefs "/etc/puppet"-genPrefs :: String -> IO Prefs+genPrefs :: T.Text -> IO Prefs genPrefs basedir = do- let manifestdir = basedir ++ "/manifests"- modulesdir = basedir ++ "/modules"- templatedir = basedir ++ "/templates"- typenames <- fmap (map getBasename) (getFiles modulesdir "lib/puppet/type" ".rb")+ let manifestdir = basedir <> "/manifests"+ modulesdir = basedir <> "/modules"+ templatedir = basedir <> "/templates"+ typenames <- fmap (map takeBaseName) (getFiles modulesdir "lib/puppet/type" ".rb") let loadedTypes = Map.fromList (map defaulttype typenames)- return $ Prefs manifestdir modulesdir templatedir 1 1 1 Nothing (Map.union baseNativeTypes loadedTypes)+ cstpdb :: T.Text -> PDB.Query -> IO (Either String Value)+ cstpdb _ _ = return (Right (Array V.empty))+ return $ Prefs manifestdir modulesdir templatedir 1 1 1 cstpdb (Map.union baseNativeTypes loadedTypes) -- | Generates 'Facts' from pairs of strings. -- -- > genFacts [("hostname","test.com")]-genFacts :: [(String,String)] -> Facts-genFacts = Map.fromList . concatMap (\(a,b) -> [(a, ResolvedString b), ("::" ++ a, ResolvedString b)])+genFacts :: [(T.Text,T.Text)] -> Facts+genFacts = Map.fromList . concatMap (\(a,b) -> [(a, ResolvedString b), ("::" <> a, ResolvedString b)])
Puppet/Interpreter/Catalog.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-| This module exports the 'getCatalog' function, that computes catalogs from parsed manifests. The behaviour of this module is probably non canonical on many details. The problem is that most of Puppet behaviour is undocumented or@@ -39,12 +38,14 @@ import Puppet.Printers import Puppet.Plugins import qualified PuppetDB.Query as PDB+import Puppet.Utils +import qualified Data.Aeson as JSON import System.IO.Unsafe-import Control.Arrow (first)+import Control.Arrow (first,(***)) import Data.List-import Data.Char (isDigit,toLower,toUpper, isAlpha, isAlphaNum, isSpace)-import Data.Maybe (isJust, fromJust, catMaybes, isNothing)+import Data.Char (isAlpha, isAlphaNum)+import Data.Maybe (isJust, fromJust, catMaybes, isNothing, mapMaybe) import Data.Either (lefts, rights, partitionEithers) import Data.Ord (comparing) import Text.Parsec.Pos@@ -55,47 +56,44 @@ import qualified Data.Traversable as DT import qualified Data.Graph as Graph import qualified Data.Tree as Tree---import qualified Data.Graph.Inductive as Graph---import Data.Graph.Analysis.Algorithms.Common (cyclesIn)+import qualified Data.Text as T -qualified [] = False-qualified str = isPrefixOf "::" str || qualified (tail str)+qualified :: T.Text -> Bool+qualified = T.isInfixOf "::" -- Int handling stuff-isInt :: String -> Bool-isInt = all isDigit-readint :: String -> CatalogMonad Integer-readint x = if isInt x- then return (read x)- else throwPosError $ "Expected an integer instead of '" ++ x+readint :: T.Text -> CatalogMonad Integer+readint x = case readDecimal x of+ Right y -> return y+ Left _ -> throwPosError $ "Expected an integer instead of '" <> x -- | This function returns an error, or the 'FinalCatalog' of resources to -- apply, the map of all edges between resources, and the 'FinalCatalog' of -- exported resources.-getCatalog :: (TopLevelType -> String -> IO (Either String Statement))+getCatalog :: (TopLevelType -> T.Text -> IO (Either String Statement)) -- ^ The \"get statements\" function. Given a top level type and its name it -- should return the corresponding statement.- -> (String -> String -> Map.Map String GeneralValue -> IO (Either String String))+ -> (Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> IO (Either String T.Text)) -- ^ The \"get template\" function. Given a file name, a scope name and a -- list of variables, it should return the computed template.- -> Maybe (String -> PDB.Query -> IO (Either String [CResource]))+ -> (T.Text -> PDB.Query -> IO (Either String JSON.Value)) -- ^ The \"puppetDB Rest API\" function. Given the machine fqdn, a request -- type (resources, nodes, facts, ..) and a query, it returns a- -- ResolvedValue, or some error.- -> String -- ^ Name of the node.+ -- JSON value, or some error.+ -> T.Text -- ^ Name of the node. -> Facts -- ^ Facts of this node.- -> Maybe String -- ^ Path to the modules, for user plugins. If set to Nothing, plugins are disabled.+ -> Maybe T.Text -- ^ Path to the modules, for user plugins. If set to Nothing, plugins are disabled. -> Map.Map PuppetTypeName PuppetTypeMethods -- ^ The list of native types- -> IO (Either String (FinalCatalog, EdgeMap, FinalCatalog), [String])+ -> IO (Either String (FinalCatalog, EdgeMap, FinalCatalog), [T.Text]) getCatalog getstatements gettemplate puppetdb nodename facts modules ntypes = do let convertedfacts = Map.map (\fval -> (Right fval, initialPos "FACTS")) facts (luastate, userfunctions) <- case modules of- Just m -> fmap (\(a,b) -> (Just a, b)) (initLua m)+ Just m -> fmap (first Just) (initLua m) Nothing -> return (Nothing, []) (!output, !finalstate) <- runStateT ( runErrorT ( computeCatalog getstatements nodename ) )- (ScopeState+ ScopeState { curScope = [["::"]] , curVariables = convertedfacts , curClasses = Map.empty@@ -114,29 +112,29 @@ , nativeTypes = ntypes , definedResources = Map.singleton ("node",nodename) (newPos "site.pp" 0 0) , currentDependencyStack = [("node",nodename)]- } )+ } case luastate of Just l -> closeLua l Nothing -> return () case output of- Left x -> return (Left x, getWarnings finalstate)- Right _ -> return (output, getWarnings finalstate)+ Left x -> return (Left (T.unpack x), getWarnings finalstate)+ Right x -> return (Right x, getWarnings finalstate) -computeCatalog :: (TopLevelType -> String -> IO (Either String Statement)) -> String -> CatalogMonad (FinalCatalog, EdgeMap, FinalCatalog)+computeCatalog :: (TopLevelType -> T.Text -> IO (Either String Statement)) -> T.Text -> CatalogMonad (FinalCatalog, EdgeMap, FinalCatalog) computeCatalog getstatements nodename = do nodestatements <- liftIO $ getstatements TopNode nodename case nodestatements of- Left x -> throwError x+ Left x -> throwError (T.pack x) Right nodestmts -> evaluateStatements nodestmts >>= finalResolution resolveResource :: CResource -> CatalogMonad (ResIdentifier, RResource)-resolveResource cr@(CResource cid cname ctype cparams _ cpos) = do+resolveResource cr@(CResource cid cname ctype cparams _ scopes cpos) = do setPos cpos rname <- resolveGeneralString cname rparams <- mapM (\(a,b) -> do { ra <- resolveGeneralString a; rb <- resolveGeneralValue b; return (ra,rb); }) (Map.toList cparams) nparams <- processOverride cr (Map.fromList rparams) let mrrelations = []- prefinalresource = RResource cid rname ctype nparams mrrelations cpos+ prefinalresource = RResource cid rname ctype nparams mrrelations scopes cpos return ((ctype, rname), prefinalresource) -- this validates the resolved resources@@ -146,14 +144,24 @@ ((_, rname), prefinalresource) <- extractRelations cr >>= resolveResource let ctype = rrtype prefinalresource cpos = rrpos prefinalresource+ saveAlias :: ResolvedValue -> CatalogMonad ()+ saveAlias (ResolvedString al) | al == rname = return ()+ | otherwise = addDefinedResource (ctype, al) cpos+ saveAlias x = throwPosError ("This alias is not a string:" <> tshow x)+ setPos cpos ntypes <- fmap nativeTypes get- unless (Map.member ctype ntypes) $ throwPosError $ "Can't find native type " ++ ctype+ unless (Map.member ctype ntypes) $ throwPosError $ "Can't find native type " <> ctype -- now run the collection checks for overrides let validatefunction = puppetvalidate (ntypes Map.! ctype) validated = validatefunction prefinalresource case validated of- Left err -> throwError (err ++ " for resource " ++ ctype ++ "[" ++ rname ++ "] at " ++ show cpos)- Right finalresource -> return ((ctype, rname), finalresource)+ Left err -> throwPosError (T.pack err <> " for resource " <> ctype <> "[" <> rname <> "]")+ Right finalresource -> do+ case Map.findWithDefault (ResolvedArray []) "alias" (rrparams finalresource) of+ (ResolvedArray aliases) -> mapM_ saveAlias aliases+ s@(ResolvedString _) -> saveAlias s+ x -> throwPosError ("Aliases should be arrays of strings, not " <> tshow x)+ return ((ctype, rname), finalresource) -- This checks if a resource is to be collected. -- This returns a list as it can either return the original@@ -172,16 +180,16 @@ (True, _) -> return [res { crvirtuality = Normal } ] (False, _) -> return [res ] -processOverride :: CResource -> Map.Map String ResolvedValue -> CatalogMonad (Map.Map String ResolvedValue)+processOverride :: CResource -> Map.Map T.Text ResolvedValue -> CatalogMonad (Map.Map T.Text ResolvedValue) processOverride cr prms =- let applyOverride :: CResource -> Map.Map String ResolvedValue -> (CResource -> CatalogMonad Bool, Map.Map GeneralString GeneralValue, Maybe PDB.Query) -> CatalogMonad (Map.Map String ResolvedValue)+ let applyOverride :: CResource -> Map.Map T.Text ResolvedValue -> (CResource -> CatalogMonad Bool, Map.Map GeneralString GeneralValue, Maybe PDB.Query) -> CatalogMonad (Map.Map T.Text ResolvedValue) -- this checks if the collection function matches applyOverride c prm (func, overs, _) = do check <- func c if check then foldM tryReplace prm (Map.toList overs) else return prm- tryReplace :: Map.Map String ResolvedValue -> (GeneralString, GeneralValue) -> CatalogMonad (Map.Map String ResolvedValue)+ tryReplace :: Map.Map T.Text ResolvedValue -> (GeneralString, GeneralValue) -> CatalogMonad (Map.Map T.Text ResolvedValue) -- if it does, this resolves the override and applies it -- this is obviously wasteful tryReplace curmap (gs, gv) = do@@ -194,85 +202,115 @@ retrieveRemoteResources :: (PDB.Query -> IO (Either String [CResource])) -> PDB.Query -> CatalogMonad [CResource] retrieveRemoteResources f q = do res <- liftIO $ f q- hashes <- case res of+ case res of Right h -> return h- Left err -> throwError $ "PuppetDB error: " ++ err- return hashes+ Left err -> throwError $ "PuppetDB error: " <> T.pack err extractRelations :: CResource -> CatalogMonad CResource extractRelations cr = do- let (params, relations) = partitionParamsRelations (crparams cr)- addUnresRel (relations, (crtype cr, crname cr), UNormal, pos cr)+ setPos (pos cr)+ (params, relations) <- partitionParamsRelations (crparams cr)+ addUnresRel (relations, (crtype cr, crname cr), UNormal, pos cr, crscope cr) return cr { crparams = params } -- resolves a single relationship-resolveRelationship :: ([(LinkType, GeneralValue, GeneralValue)], (String, GeneralString), RelUpdateType, SourcePos)- -> CatalogMonad ([(LinkType, ResIdentifier)], ResIdentifier, RelUpdateType, SourcePos)-resolveRelationship (udsts, (stype, usname), uptype, spos) = do+resolveRelationship :: ([(LinkType, GeneralValue, GeneralValue)], (T.Text, GeneralString), RelUpdateType, SourcePos, [[ScopeName]])+ -> CatalogMonad ([(LinkType, ResIdentifier)], ResIdentifier, RelUpdateType, SourcePos, [[ScopeName]])+resolveRelationship (udsts, (stype, usname), uptype, spos, scop) = do let resolveSrcRel (ltype, udtype, udname) = do dtype <- resolveGeneralValue udtype >>= rstring- dname <- resolveGeneralValue udname >>= rstring- return (ltype, (dtype, dname))- dsts <- mapM resolveSrcRel udsts+ resolveGeneralValue udname >>= rstrings >>= mapM (\dname -> return (ltype, (dtype, dname)))+ dsts <- fmap concat (mapM resolveSrcRel udsts) sname <- resolveGeneralString usname- return (dsts, (stype, sname), uptype, spos)+ return (dsts, (stype, sname), uptype, spos, scop) -- this does all the relation stuff finalizeRelations :: FinalCatalog -> FinalCatalog -> CatalogMonad (FinalCatalog, EdgeMap) finalizeRelations exported cat = do grels <- fmap unresolvedRels get >>= mapM resolveRelationship drs <- fmap definedResources get- let extr :: ([(LinkType, ResIdentifier)], ResIdentifier, RelUpdateType, SourcePos)+ let extr :: ([(LinkType, ResIdentifier)], ResIdentifier, RelUpdateType, SourcePos, [[ScopeName]]) -> [(ResIdentifier, ResIdentifier, LinkInfo)]- extr (dsts, src, rutype, spos) = do+ extr (dsts, src, rutype, spos, scp) = do (ltype, dst) <- dsts- return (dst, src, (ltype, rutype, spos))+ return (dst, src, (ltype, rutype, spos, scp)) !rels = concatMap extr grels :: [(ResIdentifier, ResIdentifier, LinkInfo)] checkRelationExists :: (ResIdentifier, ResIdentifier, LinkInfo) -> CatalogMonad (Maybe (ResIdentifier, ResIdentifier, LinkInfo))- checkRelationExists !o@(!src, !dst, (!ltype,!lutype,!lpos)) = do+ checkRelationExists !o@(!src, !dst, (!ltype,!lutype,!lpos,!lscope)) = -- if the source of the relation doesn't exist (is exported), -- then when drop this relation case (Map.member src drs, Map.member dst drs, Map.member src exported, Map.member dst exported) of (_, _, _, True) -> return Nothing -- we have a good relation, reorder it so that all arrows point the same way (True, True,_ , _) -> case ltype of- RNotify -> return $ Just (dst, src, (RSubscribe, lutype,lpos))- RBefore -> return $ Just (dst, src, (RRequire , lutype,lpos))+ RNotify -> return $ Just (dst, src, (RSubscribe, lutype,lpos,lscope))+ RBefore -> return $ Just (dst, src, (RRequire , lutype,lpos,lscope)) _ -> return (Just o)- (False, _, _, _) -> throwError $ "Unknown resources " ++ show src ++ " used in a relation at " ++ show lpos ++ " debug: " ++ show (Map.member src drs, Map.member dst drs, Map.member src exported, Map.member dst exported)- (_, False, _, _) -> throwError $ "Unknown resources " ++ show dst ++ " used in a relation at " ++ show lpos ++ " debug: " ++ show (Map.member src drs, Map.member dst drs, Map.member src exported, Map.member dst exported)+ (False, _, _, _) -> throwError $ "Unknown resources " <> tshow src <> " used as source (destination: " <> tshow dst <> ") in a relation at " <> tshow lpos <> " debug: " <> tshow (Map.member src drs, Map.member dst drs, Map.member src exported, Map.member dst exported) <> " " <> showScope lscope+ (_, False, _, _) -> throwError $ "Unknown resources " <> tshow dst <> " used as destination (source: " <> tshow src <> ") in a relation at " <> tshow lpos <> " debug: " <> tshow (Map.member src drs, Map.member dst drs, Map.member src exported, Map.member dst exported) <> " " <> showScope lscope -- now look for cycles in the graph checkedrels <- fmap catMaybes $ mapM checkRelationExists rels let !edgeMap = Map.fromList (map (\(d,s,i) -> ((s,d),i)) checkedrels) :: EdgeMap -- warning, in the edgemap we have (src, dst), contrary to all other uses !nodeRel = Map.fromListWith (++) (map (\(d,s,_) -> (s,[d])) checkedrels) :: Map.Map ResIdentifier [ResIdentifier] !(relgraph,qfunc) = Graph.graphFromEdges' $ map (\(a,b) -> (a,a,b)) $ Map.toList nodeRel !cycles = map (map ((\(a,_,_) -> a) . qfunc) . Tree.flatten) $ filter (not . null . Tree.subForest) $ Graph.scc relgraph :: [[ResIdentifier]]- describe :: [ResIdentifier] -> String+ describe :: [ResIdentifier] -> T.Text+ describe [] = "[]" describe x = let rx = map (\i -> (i, drs Map.! i)) x- in intercalate "\n\t\t" (showRRef (head x) : map describe' (zip x (tail rx)))- describe' :: (ResIdentifier, (ResIdentifier, SourcePos)) -> String- describe' (src,(dst,dpos)) = " -> " ++ showRRef dst ++ " [" ++ show dpos ++ "] link is " ++ show (Map.lookup (src,dst) edgeMap)+ in T.intercalate "\n\t\t" (showRRef (head x) : zipWith describe' x (tail rx))+ describe' :: ResIdentifier -> (ResIdentifier, SourcePos) -> T.Text+ describe' src (dst,dpos) = " -> " <> showRRef dst <> " [" <> tshow dpos <> "] link is " <> tshow (Map.lookup (src,dst) edgeMap) if null cycles then return (cat, edgeMap)- else throwError $ "The following cycles have been found:\n\t" ++ intercalate "\n\t" (map describe cycles)+ else throwError $ "The following cycles have been found:\n\t" <> T.intercalate "\n\t" (map describe cycles) finalResolution :: Catalog -> CatalogMonad (FinalCatalog, EdgeMap, FinalCatalog) finalResolution cat = do pdbfunction <- fmap puppetDBFunction get fqdnr <- getVariable "::fqdn"- collectedRemote <- case pdbfunction of- Just f -> do- fqdn <- case fqdnr of- Just (Right (ResolvedString f'), _) -> return f'- _ -> throwError "Could not get FQDN during final resolution"- remoteCollects <- fmap (catMaybes . map (\(_,_,x) -> x) . curCollect) get- fmap concat (mapM (retrieveRemoteResources (f fqdn)) remoteCollects)- Nothing -> return []+ collectedRemote <- do+ fqdn <- case fqdnr of+ Just (Right (ResolvedString f'), _) -> return f'+ _ -> throwError "Could not get FQDN during final resolution"+ remoteCollects <- fmap (mapMaybe (\(_,_,x) -> x) . curCollect) get+ let+ isNotLocal :: CResource -> Bool+ isNotLocal cr = case Map.lookup (Right "EXPORTEDSOURCE") (crparams cr) of+ Just (Right (ResolvedString x)) -> x /= fqdn+ _ -> True+ toCR :: Either String JSON.Value -> Either String [CResource]+ toCR (Left r) = Left r+ toCR (Right x) = case json2puppet x of+ Left rr -> Left rr+ Right s -> Right $ filter isNotLocal s+ fmap concat (mapM (retrieveRemoteResources (fmap toCR . pdbfunction "resources")) remoteCollects)+ let -- this adds the collected remote defines to the index of know resources, so that the dependencies check+ addCollectedDefines cr = do+ let rtype = crtype cr+ rname <- resolveGeneralString (crname cr)+ isdef <- checkDefine rtype+ case isdef of+ Just _ -> addDefinedResource (rtype, rname) (pos cr)+ Nothing -> return () collectedRemote' <- mapM extractRelations collectedRemote- collectedLocal <- fmap concat (mapM collectionChecks cat)- collected <- mapM evaluateDefine (collectedLocal ++ collectedRemote')- let (real, allvirtual) = partition (\x -> crvirtuality x == Normal) (concat collected)+ mapM_ addCollectedDefines collectedRemote'+ collectedLocal <- fmap concat $ mapM collectionChecks cat+ collectedLocalD <- fmap concat $ mapM evaluateDefine collectedLocal+ collectedRemoteD <- fmap concat $ mapM evaluateDefine collectedRemote'+ -- collectedRemoteD resource names SHOULD be resolved (coming from+ -- PuppetDB)+ let addCollectedRemoteResource :: CResource -> CatalogMonad ()+ addCollectedRemoteResource (CResource _ (Right cn) ct prms _ _ cp) = do+ addDefinedResource (ct, cn) cp+ case Map.lookup (Right "alias") prms of+ Just (Right (ResolvedString s)) -> addDefinedResource (ct, s) cp+ Just x -> throwPosError ("Alias must be a single string, not " <> tshow x)+ _ -> return ()+ addCollectedRemoteResource x = throwPosError $ "finalResolution/addCollectedRemoteResource the remote resource name was not properly defined: " <> tshow (crname x)+ mapM_ addCollectedRemoteResource collectedRemoteD+ let collected = collectedLocalD ++ collectedRemoteD+ (real, allvirtual) = partition (\x -> crvirtuality x == Normal) collected (_, exported) = partition (\x -> crvirtuality x == Virtual) allvirtual rexported <- mapM resolveResource exported let !exportMap = Map.fromList rexported@@ -287,23 +325,24 @@ createResourceMap :: [(ResIdentifier, RResource)] -> CatalogMonad FinalCatalog createResourceMap = foldM insertres Map.empty where+ insertres :: FinalCatalog -> (ResIdentifier, RResource) -> CatalogMonad FinalCatalog insertres curmap (resid, res) = let oldres = Map.lookup resid curmap newmap = Map.insert resid res curmap in case (rrtype res, oldres) of ("class", _) -> return newmap- (_, Just r ) -> throwError $ "Resource already defined:"- ++ "\n\t" ++ rrtype r ++ "[" ++ rrname r ++ "] at " ++ show (rrpos r)- ++ "\n\t" ++ rrtype res ++ "[" ++ rrname res ++ "] at " ++ show (rrpos res)+ (_, Just r ) -> throwError ("Resource already defined:"+ <> "\n\t" <> rrtype r <> "[" <> rrname r <> "] at " <> tshow (rrpos r) <> " " <> showScope (rrscope r)+ <> "\n\t" <> rrtype res <> "[" <> rrname res <> "] at " <> tshow (rrpos res) <> " " <> showScope (rrscope res) :: T.Text) (_, Nothing) -> return newmap -getstatement :: TopLevelType -> String -> CatalogMonad Statement+getstatement :: TopLevelType -> T.Text -> CatalogMonad Statement getstatement qtype name = do curcontext <- get let stmtsfunc = getStatementsFunction curcontext estatement <- liftIO $ stmtsfunc qtype name case estatement of- Left x -> throwPosError x+ Left x -> throwPosError (T.pack x) Right y -> return y -- State alteration functions@@ -333,15 +372,21 @@ Nothing -> return [] Just x -> return x +pushDependency :: ResIdentifier -> CatalogMonad () pushDependency = modify . modifyDeps . (:)+popDependency :: CatalogMonad () popDependency = modify (modifyDeps tail)+pushScope :: [ScopeName] -> CatalogMonad () pushScope = modify . modifyScope . (:)+popScope :: CatalogMonad () popScope = modify (modifyScope tail)+getScope :: CatalogMonad [T.Text] getScope = do scope <- liftM curScope get if null scope then throwError "empty scope, shouldn't happen" else return $ head scope+addLoaded :: T.Text -> SourcePos -> CatalogMonad () addLoaded name = modify . modifyClasses . Map.insert name getNextId = do curscope <- get@@ -350,14 +395,26 @@ setPos = modify . setStatePos -- qualifies a variable k depending on the context cs-qualify k cs | qualified k || (cs == "::") = cs ++ k- | otherwise = cs ++ "::" ++ k+qualify k cs | qualified k || (cs == "::") = cs <> k+ | otherwise = cs <> "::" <> k -- This is a bit convoluted and misses a critical feature. -- It adds the variable to all the scopes that are currently active. -- BUG TODO : check that a variable is not already defined. putVariable k v = getScope >>= mapM_ (\x -> modify (modifyVariables (Map.insert (qualify k x) v))) +-- Saves the current module name+setModuleName :: T.Text -> CatalogMonad ()+setModuleName str = do+ let (amodulename, remain) = T.break (==':') str+ modulename = if T.null remain+ then "topmodule"+ else amodulename+ cpos <- getPos+ vars <- fmap curVariables get+ let nvars = Map.insert "::caller_module_name" (Right (ResolvedString modulename), cpos) vars+ saveVariables nvars+ getVariable vname = liftM (Map.lookup vname . curVariables) get -- BUG TODO : top levels are qualified only with the head of the scopes@@ -373,15 +430,17 @@ ntop = Map.insert (rtype, nname) nstatement ctop nstate = curstate { nestedtoplevels = ntop } put nstate+addWarning :: T.Text -> CatalogMonad () addWarning = modify . pushWarning addCollect ((func, query), overrides) = modify $ pushCollect (func, overrides, query) -- this pushes the relations only if they exist -- the parameter is of the form -- ( [dstrelations], srcresource, type, pos )-addUnresRel ncol@(rels, _, _, _) = unless (null rels) (modify (pushUnresRel ncol))+addUnresRel :: ([(LinkType, GeneralValue, GeneralValue)], (T.Text, GeneralString), RelUpdateType, SourcePos, [[ScopeName]]) -> CatalogMonad ()+addUnresRel ncol@(rels, _, _, _, _) = unless (null rels) (modify (pushUnresRel ncol)) -- finds out if a resource name refers to a define-checkDefine :: String -> CatalogMonad (Maybe Statement)+checkDefine :: T.Text -> CatalogMonad (Maybe Statement) checkDefine dname = fmap nativeTypes get >>= \nt -> if Map.member dname nt then return Nothing else do@@ -394,7 +453,7 @@ Nothing -> do def1 <- liftIO $ getsmts TopDefine dname case def1 of- Left err -> throwPosError ("Could not find the definition of " ++ dname ++ " err = " ++ err)+ Left err -> throwPosError ("Could not find the definition of " <> dname <> " err = " <> T.pack err) Right s -> return $ Just s {-@@ -402,20 +461,25 @@ Those that define relationship must be properly resolved or hell will break loose. This is a BUG. -}-partitionParamsRelations :: Map.Map GeneralString GeneralValue -> (Map.Map GeneralString GeneralValue, [(LinkType, GeneralValue, GeneralValue)])-partitionParamsRelations rparameters = (realparams, relations)- where realparams = filteredparams :: Map.Map GeneralString GeneralValue- relations = concatMap convertrelation (Map.toList filteredrelations) :: [(LinkType, GeneralValue, GeneralValue)]- convertrelation :: (GeneralString, GeneralValue) -> [(LinkType, GeneralValue, GeneralValue)]- convertrelation (_, Right ResolvedUndefined) = []- convertrelation (reltype, Right (ResolvedArray rs)) = concatMap (\x -> convertrelation (reltype, Right x)) rs- convertrelation (reltype, Right (ResolvedRReference rt rv)) = [(fromJust $ getRelationParameterType reltype, Right $ ResolvedString rt, Right rv)]- convertrelation (reltype, Right (ResolvedString "undef")) = [(fromJust $ getRelationParameterType reltype, Right $ ResolvedString "undef", Right $ ResolvedString "undef")]- convertrelation (_, Left x) = error ("partitionParamsRelations unresolved : " ++ show x)- convertrelation x = error ("partitionParamsRelations error : " ++ show x)- (filteredrelations, filteredparams) = Map.partitionWithKey (const . isJust . getRelationParameterType) rparameters -- filters relations with actual parameters+partitionParamsRelations :: Map.Map GeneralString GeneralValue -> CatalogMonad (Map.Map GeneralString GeneralValue, [(LinkType, GeneralValue, GeneralValue)])+partitionParamsRelations rparameters = do+ let realparams = filteredparams :: Map.Map GeneralString GeneralValue+ convertrelation :: (GeneralString, GeneralValue) -> CatalogMonad [(LinkType, GeneralValue, GeneralValue)]+ convertrelation (_, Right ResolvedUndefined) = return []+ convertrelation (reltype, Right (ResolvedArray rs)) = fmap concat $ mapM (\x -> convertrelation (reltype, Right x)) rs+ convertrelation (reltype, Right (ResolvedRReference rt rv)) = return [(fromJust $ getRelationParameterType reltype, Right $ ResolvedString rt, Right rv)]+ convertrelation (reltype, Right (ResolvedString "undef")) = return [(fromJust $ getRelationParameterType reltype, Right $ ResolvedString "undef", Right $ ResolvedString "undef")]+ convertrelation (reltype, Right (ResolvedString x)) = case parseResourceReference x of+ Just rr -> convertrelation (reltype, Right rr)+ Nothing -> throwPosError ("partitionParamsRelations unknown string error : " <> tshow x)+ convertrelation (_, Left x) = throwPosError ("partitionParamsRelations unresolved : " <> tshow x)+ convertrelation x = throwPosError ("partitionParamsRelations error : " <> tshow x)+ (filteredrelations, filteredparams) = Map.partitionWithKey (const . isJust . getRelationParameterType) rparameters -- filters relations with actual parameters+ relations <- fmap concat (mapM convertrelation (Map.toList filteredrelations)) :: CatalogMonad [(LinkType, GeneralValue, GeneralValue)]+ return (realparams, relations) -- TODO check whether parameters changed+checkLoaded :: T.Text -> CatalogMonad Bool checkLoaded name = do curscope <- get case Map.lookup name (curClasses curscope) of@@ -431,13 +495,13 @@ -- safely insert parameters, checking they are not already defined addParameters :: Map.Map GeneralString GeneralValue -> [(Expression, Expression)] -> CatalogMonad (Map.Map GeneralString GeneralValue)-addParameters m p = foldM rp m p+addParameters = foldM rp where rp :: Map.Map GeneralString GeneralValue -> (Expression, Expression) -> CatalogMonad (Map.Map GeneralString GeneralValue) rp curmap prm = do (k, v) <- resolveParams prm case Map.lookup k curmap of- Just _ -> throwPosError $ "Parameter " ++ show k ++ " had been declared twice!"+ Just _ -> throwPosError $ "Parameter " <> tshow k <> " had been declared twice!" Nothing -> return (Map.insert k v curmap) -- apply default values to a resource@@ -445,33 +509,32 @@ applyDefaults res = getCurDefaults >>= foldM applyDefaults' res applyDefaults' :: CResource -> ResDefaults -> CatalogMonad CResource-applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (RDefaults dtype rdefs _) = do+applyDefaults' r@(CResource i rname rtype rparams rvirtuality scopes rpos) (RDefaults dtype rdefs _) = let nparams = mergeParams rparams rdefs False- if dtype == rtype- then return $ CResource i rname rtype nparams rvirtuality rpos- else return r-applyDefaults' r@(CResource i rname rtype rparams rvirtuality rpos) (ROverride dtype dname rdefs _) = do+ in return $ if dtype == rtype+ then CResource i rname rtype nparams rvirtuality scopes rpos+ else r+applyDefaults' r@(CResource i rname rtype rparams rvirtuality scopes rpos) (ROverride dtype dname rdefs _) = do srname <- resolveGeneralString rname sdname <- resolveGeneralString dname let nparams = mergeParams rparams rdefs True- if (dtype == rtype) && (srname == sdname)- then return $ CResource i rname rtype nparams rvirtuality rpos- else return r+ return $ if (dtype == rtype) && (srname == sdname)+ then CResource i rname rtype nparams rvirtuality scopes rpos+ else r -- merge defaults and actual parameters depending on the override flag mergeParams :: Map.Map GeneralString GeneralValue -> Map.Map GeneralString GeneralValue -> Bool -> Map.Map GeneralString GeneralValue mergeParams srcprm defs override = if override- then Map.union defs srcprm- else Map.union srcprm defs+ then defs `Map.union` srcprm+ else srcprm `Map.union` defs -- The actual meat evaluateDefine :: CResource -> CatalogMonad [CResource]-evaluateDefine r@(CResource _ rname rtype rparams rvirtuality rpos) = let+evaluateDefine r@(CResource _ rname rtype rparams rvirtuality _ rpos) = let evaluateDefineDeclaration dtype args dstmts dpos = do- --oldpos <- getPos- pushScope ["#DEFINE#" ++ dtype] rexpr <- resolveGeneralString rname+ pushScope ["#DEFINE#" <> dtype <> "/" <> rexpr] pushDependency (dtype, rexpr) -- add variables mparams <- fmap Map.fromList $ mapM (\(gs, gv) -> do { rgs <- resolveGeneralString gs; rgv <- tryResolveGeneralValue gv; return (rgs, (rgv, dpos)); }) (Map.toList rparams)@@ -479,15 +542,16 @@ defineparamset = Set.fromList $ map fst args mandatoryparams = Set.fromList $ map fst $ filter (isNothing . snd) args resourceparamset = Map.keysSet mparams- extraparams = Set.difference resourceparamset (Set.union defineparamset metaparameters)+ extraparams = Set.difference resourceparamset (defineparamset `Set.union` metaparameters) unsetparams = Set.difference mandatoryparams resourceparamset- unless (Set.null extraparams) $ throwPosError $ "Spurious parameters set for " ++ dtype ++ ": " ++ intercalate ", " (Set.toList extraparams)- unless (Set.null unsetparams) $ throwPosError $ "Unset parameters set for " ++ dtype ++ ": " ++ intercalate ", " (Set.toList unsetparams)+ unless (Set.null extraparams) $ throwPosError $ "Spurious parameters set for " <> dtype <> ": " <> T.intercalate ", " (Set.toList extraparams)+ unless (Set.null unsetparams) $ throwPosError $ "Unset parameters set for " <> dtype <> ": " <> T.intercalate ", " (Set.toList unsetparams) putVariable "title" (expr, rpos) putVariable "name" (expr, rpos) mapM_ (loadClassVariable rpos mparams) args setPos dpos+ setModuleName dtype -- parse statements res <- mapM evaluateStatements dstmts nres <- handleDelayedActions (concat res)@@ -512,20 +576,25 @@ emptyDefaults return dres -addResource :: String -> [(Expression, Expression)] -> Virtuality -> SourcePos -> GeneralValue -> CatalogMonad [CResource]+addResource :: T.Text -> [(Expression, Expression)] -> Virtuality -> SourcePos -> GeneralValue -> CatalogMonad [CResource] addResource rtype parameters virtuality position grname = do resid <- getNextId rparameters <- addParameters Map.empty parameters- srname <- case grname of+ case grname of Right e -> do- rse <- rstring e- getPos >>= addDefinedResource (rtype, rse)- return $ Right rse- Left e -> return $ Left e- (curdeptype, curdepname) <- fmap (head . currentDependencyStack) get- let defaultdependency = (RRequire, Right (ResolvedString curdeptype), Right (ResolvedString curdepname))- addUnresRel ([defaultdependency], (rtype, srname), UNormal, position)- return [CResource resid srname rtype rparameters virtuality position]+ rse <- rstring e+ curpos <- getPos+ addDefinedResource (rtype, rse) curpos+ case Map.lookup (Right "alias") rparameters of+ Just (Right (ResolvedString s)) -> addDefinedResource (rtype, s) curpos+ Just x -> throwPosError ("Alias must be a single string, not " <> tshow x)+ _ -> return ()+ (curdeptype, curdepname) <- fmap (head . currentDependencyStack) get+ let defaultdependency = (RRequire, Right (ResolvedString curdeptype), Right (ResolvedString curdepname))+ scopes <- fmap curScope get+ addUnresRel ([defaultdependency], (rtype, Right rse), UNormal, position, scopes)+ return [CResource resid (Right rse) rtype rparameters virtuality scopes position]+ Left r -> throwPosError ("Could not determine the current resource name: " <> tshow r) -- node evaluateStatements :: Statement -> CatalogMonad Catalog@@ -557,7 +626,7 @@ rparameters <- fmap Map.fromList $ mapM (\(a,b) -> do { pa <- resolveExpressionString a; pb <- tryResolveExpression b; return (pa, pb) } ) parameters classname <- resolveExpressionString rname topstatement <- getstatement TopClass classname- let classparameters = Map.map (\pvalue -> (pvalue, position)) rparameters :: Map.Map String (GeneralValue, SourcePos)+ let classparameters = Map.map (\pvalue -> (pvalue, position)) rparameters :: Map.Map T.Text (GeneralValue, SourcePos) evaluateClass topstatement classparameters Nothing _ -> do srname <- tryResolveExpression rname@@ -578,12 +647,13 @@ setPos position gdstname <- tryResolveExpression dstname gsrcname <- tryResolveExpressionString srcname- addUnresRel ( [(RRequire, Right $ ResolvedString dsttype, gdstname)], (srctype, gsrcname), UPlus, position )+ scp <- fmap curScope get+ addUnresRel ( [(RRequire, Right $ ResolvedString dsttype, gdstname)], (srctype, gsrcname), UPlus, position, scp) return [] -- <<| |>> evaluateStatements (ResourceCollection rtype expr overrides position) = do setPos position- when (not $ null overrides) $ throwPosError $ "Amending attributes with a Collector only works with <| |>, not <<| |>>."+ unless (null overrides) $ throwPosError "Amending attributes with a Collector only works with <| |>, not <<| |>>." func <- collectionFunction Exported rtype expr addCollect (func, Map.empty) return []@@ -612,16 +682,16 @@ mapM_ (\(fname, stmt) -> evaluateClass stmt Map.empty (Just fname)) toplevels evaluateStatements curstatement -evaluateStatements x = throwError ("Can't evaluate " ++ show x)+evaluateStatements x = throwError ("Can't evaluate " <> tshow x) -- function used to load defines / class variables into the global context-loadClassVariable :: SourcePos -> Map.Map String (GeneralValue, SourcePos) -> (String, Maybe Expression) -> CatalogMonad (String, GeneralValue)+loadClassVariable :: SourcePos -> Map.Map T.Text (GeneralValue, SourcePos) -> (T.Text, Maybe Expression) -> CatalogMonad (T.Text, GeneralValue) loadClassVariable position inputs (paramname, defvalue) = do let inputvalue = Map.lookup paramname inputs (v, vpos) <- case (inputvalue, defvalue) of (Just x , _ ) -> return x (Nothing, Just y ) -> return (Left y, position)- (Nothing, Nothing) -> throwError $ "Must define parameter " ++ paramname ++ " at " ++ show position+ (Nothing, Nothing) -> throwError $ "Must define parameter " <> paramname <> " at " <> tshow position rv <- tryResolveGeneralValue v putVariable paramname (rv, vpos) return (paramname, rv)@@ -629,7 +699,7 @@ -- class -- ClassDeclaration String (Maybe String) [(String, Maybe Expression)] [Statement] SourcePos -- nom, heritage, parametres, contenu-evaluateClass :: Statement -> Map.Map String (GeneralValue, SourcePos) -> Maybe String -> CatalogMonad Catalog+evaluateClass :: Statement -> Map.Map T.Text (GeneralValue, SourcePos) -> Maybe T.Text -> CatalogMonad Catalog evaluateClass (ClassDeclaration classname inherits parameters statements position) inputparams actualname = do isloaded <- case actualname of Nothing -> checkLoaded classname@@ -641,18 +711,20 @@ addDefinedResource ("class", classname) oldpos -- detection of spurious parameters let classparamset = Set.fromList $ map fst parameters- inputparamset = Set.filter (\x -> getRelationParameterType (Right x) == Nothing) $ Map.keysSet inputparams+ inputparamset = Set.filter (isNothing . getRelationParameterType . Right) $ Map.keysSet inputparams overparams = Set.difference inputparamset (Set.union metaparameters classparamset) -- to insert into the final resource- unless (Set.null overparams) (throwError $ "Spurious parameters " ++ intercalate ", " (Set.toList overparams) ++ " at " ++ show position) + unless (Set.null overparams) (throwError $ "Spurious parameters " <> T.intercalate ", " (Set.toList overparams) <> " at " <> tshow position)+ resid <- getNextId -- get this resource id, for the dummy class that will be used to handle relations- setPos position- pushDependency ("class", classname) case actualname of Nothing -> pushScope [classname] -- sets the scope Just ac -> pushScope [classname, ac] mparameters <- mapM (loadClassVariable position inputparams) parameters -- add variables for parametrized classes+ setPos position -- the setPos is that late so that the error message about missing parameters is about the calling site+ pushDependency ("class", classname)+ setModuleName classname -- load inherited classes inherited <- case inherits of@@ -673,10 +745,11 @@ -- for all resources that do not already depend on a class -- this is probably not puppet perfect with resources that -- depend explicitely on a class+ scopes <- fmap curScope get popScope popDependency return $- [CResource resid (Right classname) "class" (Map.fromList $ map (first Right) mparameters) Normal position]+ [CResource resid (Right classname) "class" (Map.fromList $ map (first Right) mparameters) Normal scopes position] ++ inherited ++ nres @@ -684,13 +757,17 @@ mapM_ (\(n,x) -> evaluateClass x Map.empty (Just n)) topstmts evaluateClass myclass inputparams actualname -evaluateClass x _ _ = throwError ("Someone managed to run evaluateClass against " ++ show x)+evaluateClass x _ _ = throwError ("Someone managed to run evaluateClass against " <> tshow x) -addClassDependency :: String -> CResource -> CatalogMonad ()-addClassDependency cname (CResource _ rname rtype _ _ position) = addUnresRel (- [(RRequire, Right $ ResolvedString "class", Right $ ResolvedString cname)]- , (rtype, rname)- , UPlus, position)+addClassDependency :: T.Text -> CResource -> CatalogMonad ()+addClassDependency cname (CResource _ rname rtype _ _ scp position) =+ addUnresRel (+ [(RRequire, Right $ ResolvedString "class", Right $ ResolvedString cname)]+ , (rtype, rname)+ , UPlus+ , position+ , scp+ ) tryResolveExpression :: Expression -> CatalogMonad GeneralValue tryResolveExpression = tryResolveGeneralValue . Left@@ -701,12 +778,11 @@ tryResolveGeneralValue (Left BFalse) = return $ Right $ ResolvedBool False tryResolveGeneralValue (Left (Value x)) = tryResolveValue x tryResolveGeneralValue n@(Left (ResolvedResourceReference _ _)) = return n-tryResolveGeneralValue (Left (Error x)) = throwPosError x tryResolveGeneralValue (Left (ConditionalValue checkedvalue (Value (PuppetHash (Parameters hash))))) = do rcheck <- resolveExpression checkedvalue rhash <- mapM (\(vn, vv) -> do { rvn <- resolveExpression vn; return (rvn, vv) }) hash case filter (\(a,_) -> (a == ResolvedString "default") || compareRValues a rcheck) rhash of- [] -> throwPosError ("No value could be selected when comparing to " ++ show rcheck)+ [] -> throwPosError ("No value could be selected when comparing to " <> tshow rcheck) ((_,x):_) -> tryResolveExpression x tryResolveGeneralValue n@(Left (EqualOperation a b)) = compareGeneralValue n a b [EQ] tryResolveGeneralValue n@(Left (AboveEqualOperation a b)) = compareGeneralValue n a b [GT,EQ]@@ -722,13 +798,13 @@ 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+ Left err -> throwPosError $ "Error with regexp " <> tshow reg <> ": " <> T.pack err+ (Right x, _) -> throwPosError $ "Was expecting a string to match to a regexp, not " <> tshow x+ (_, Right x) -> throwPosError $ "Was expecting a regexp, not " <> tshow x _ -> return n tryResolveGeneralValue n@(Left (OrOperation a b)) = do ra <- tryResolveBoolean $ Left a- if( ra == Right (ResolvedBool True) )+ if ra == Right (ResolvedBool True) then return $ Right $ ResolvedBool True else do rb <- tryResolveBoolean $ Left b@@ -738,7 +814,7 @@ _ -> return n tryResolveGeneralValue n@(Left (AndOperation a b)) = do ra <- tryResolveBoolean $ Left a- if( ra == Right (ResolvedBool False) )+ if ra == Right (ResolvedBool False) then return $ Right $ ResolvedBool False else do rb <- tryResolveBoolean $ Left b@@ -759,35 +835,31 @@ bnum <- readint num let nnum = fromIntegral bnum if length ar <= nnum- then throwPosError ("Invalid array index " ++ num ++ " " ++ show ar)+ then throwPosError ("Invalid array index " <> num <> " " <> tshow ar) else return $ Right (ar !! nnum) (Right (ResolvedHash ar), Right idx) -> do let filtered = filter (\(x,_) -> x == idx) ar case filtered of [] -> return $ Right ResolvedUndefined [(_,x)] -> return $ Right x- x -> throwPosError ("Hum, WTF tryResolveGeneralValue " ++ show x)- (_, 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)+ x -> throwPosError ("Hum, WTF tryResolveGeneralValue " <> tshow x)+ (_, Left y) -> throwPosError ("Could not resolve index " <> tshow y)+ (Left x, _) -> throwPosError ("Could not resolve lookup " <> tshow x)+ (Right x, _) -> throwPosError ("Could not resolve something that is not an array nor a hash, but " <> tshow x) -- TODO : for hashes, checks the keys -- for strings, substrings tryResolveGeneralValue o@(Left (IsElementOperation b a)) = do ra <- tryResolveExpression a rb <- tryResolveExpressionString b case (ra, rb) of- (Right (ResolvedArray ar), Right idx) -> do+ (Right (ResolvedArray ar), Right idx) -> let filtered = filter (compareRValues (ResolvedString idx)) ar- if null filtered- then return $ Right $ ResolvedBool False- else return $ Right $ ResolvedBool True- (Right (ResolvedHash h), Right idx) -> do+ in return $! Right $! ResolvedBool $! not $! null filtered+ (Right (ResolvedHash h), Right idx) -> let filtered = filter (\(fa,_) -> fa == idx) h- if null filtered- then return $ Right $ ResolvedBool False- else return $ Right $ ResolvedBool True+ in return $! Right $! ResolvedBool $! not $! null filtered (Right (ResolvedString _), Right _) -> throwPosError "in operator not yet implemented for substrings"- (Right ba, Right bb) -> throwPosError $ "Expected a string and a hash, array or string for the in operator, not " ++ show (ba,bb)+ (Right ba, Right bb) -> throwPosError $ "Expected a string and a hash, array or string for the in operator, not " <> tshow (ba,bb) _ -> return o -- horrible hack, because I do not know how to supply a single operator for Int and Float tryResolveGeneralValue o@(Left (PlusOperation a b)) = arithmeticOperation a b (+) (+) o@@ -795,13 +867,13 @@ 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)+tryResolveGeneralValue e = throwPosError ("tryResolveGeneralValue not implemented for " <> tshow e) resolveGeneralValue :: GeneralValue -> CatalogMonad ResolvedValue resolveGeneralValue e = do x <- tryResolveGeneralValue e case x of- Left n -> throwPosError ("Could not resolveGeneralValue " ++ show n)+ Left n -> throwPosError ("Could not resolveGeneralValue " <> tshow n) Right p -> return p tryResolveExpressionString :: Expression -> CatalogMonad GeneralString@@ -811,14 +883,18 @@ Right e -> liftM Right (rstring e) Left e -> return $ Left e -rstring :: ResolvedValue -> CatalogMonad String+rstring :: ResolvedValue -> CatalogMonad T.Text rstring resolved = case resolved of ResolvedString s -> return s- ResolvedInt i -> return (show i)- e -> do- p <- getPos- throwError ("'" ++ show e ++ "' will not resolve to a string at " ++ show p)+ ResolvedInt i -> return (tshow i)+ e -> throwPosError ("'" <> tshow e <> "' will not resolve to a string") +rstrings :: ResolvedValue -> CatalogMonad [T.Text]+rstrings resolved = case resolved of+ ResolvedString s -> return [s]+ ResolvedInt i -> return [tshow i]+ ResolvedArray xs -> mapM rstring xs+ e -> throwPosError ("'" <> tshow e <> "' will not resolve to a string") resolveExpression :: Expression -> CatalogMonad ResolvedValue resolveExpression e = do@@ -827,22 +903,23 @@ Right r -> return r Left x -> do p <- getPos- throwError ("Can't resolve expression '" ++ show x ++ "' at " ++ show p ++ " was '" ++ show e ++ "'")+ throwError ("Can't resolve expression '" <> tshow x <> "' at " <> tshow p <> " was '" <> tshow e <> "'") -resolveExpressionString :: Expression -> CatalogMonad String+resolveExpressionString :: Expression -> CatalogMonad T.Text resolveExpressionString x = do resolved <- resolveExpression x case resolved of ResolvedString s -> return s- ResolvedInt i -> return (show i)+ ResolvedInt i -> return (tshow i) e -> do p <- getPos- throwError ("Can't resolve expression '" ++ show e ++ "' to a string at " ++ show p)+ throwError ("Can't resolve expression '" <> tshow e <> "' to a string at " <> tshow p) tryResolveValue :: Value -> CatalogMonad GeneralValue tryResolveValue (Literal x) = return $ Right $ ResolvedString x tryResolveValue (Integer x) = return $ Right $ ResolvedInt x tryResolveValue (Double x) = return $ Right $ ResolvedDouble x+tryResolveValue (PuppetBool x) = return $ Right $ ResolvedBool x tryResolveValue n@(ResourceReference rtype vals) = do rvals <- tryResolveExpression vals@@ -851,24 +928,25 @@ _ -> return $ Left $ Value n -- special variables first tryResolveValue (VariableReference "module_name") = liftM (\x ->- case (takeWhile (/= ':') . head) x of- '#':'D':'E':'F':'I':'N':'E':'#':xs -> Right $ ResolvedString xs- r -> Right $ ResolvedString r+ let headname = T.takeWhile (/= ':') (head x)+ in Right $ ResolvedString $ if T.isPrefixOf "#DEFINE#" headname+ then T.drop 8 headname+ else headname ) getScope tryResolveValue (VariableReference vname) = do -- TODO check scopes !!! curscp <- getScope let gvarnm sc | qualified vname = vname : remtopscope vname -- scope is explicit- | sc == "::" = ["::" ++ vname] -- we are toplevel- | otherwise = [sc ++ "::" ++ vname, "::" ++ vname] -- check for local scope, then global+ | sc == "::" = ["::" <> vname] -- we are toplevel+ | otherwise = [sc <> "::" <> vname, "::" <> vname] -- check for local scope, then global varnames = concatMap gvarnm curscp- remtopscope (':':':':xs) = [xs]- remtopscope _ = []+ remtopscope x | T.isPrefixOf "::" x = [T.drop 2 x]+ | otherwise = [] matching <- liftM catMaybes (mapM getVariable varnames) if null matching then do position <- getPos- addWarning ("Could not resolveValue variables " ++ show varnames ++ " at " ++ show position)+ addWarning ("Could not resolveValue variables " <> tshow varnames <> " at " <> tshow position) return $ Left $ Value $ VariableReference (head varnames) else return $ case head matching of (x,_) -> x@@ -876,7 +954,7 @@ tryResolveValue (Interpolable x) = do resolved <- mapM tryResolveValueString x if null $ lefts resolved- then return $ Right $ ResolvedString $ concat $ rights resolved+ then return $ Right $ ResolvedString $ T.concat $ rights resolved -- 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)@@ -885,15 +963,15 @@ tryResolveValue n@(PuppetHash (Parameters x)) = do resolvedKeys <- mapM (tryResolveExpressionString . fst) x resolvedValues <- mapM (tryResolveExpression . snd) x- if null (lefts resolvedKeys) && null (lefts resolvedValues)- then return $ Right $ ResolvedHash $ zip (rights resolvedKeys) (rights resolvedValues)- else return $ Left $ Value n+ return $ if null (lefts resolvedKeys) && null (lefts resolvedValues)+ then Right $ ResolvedHash $ zip (rights resolvedKeys) (rights resolvedValues)+ else Left $ Value n tryResolveValue n@(PuppetArray expressions) = do resolvedExpressions <- mapM tryResolveExpression expressions- if null $ lefts resolvedExpressions- then return $ Right $ ResolvedArray $ rights resolvedExpressions- else return $ Left $ Value n+ return $ if null $ lefts resolvedExpressions+ then Right $ ResolvedArray $ rights resolvedExpressions+ else Left $ Value n tryResolveValue (FunctionCall "generate" args) = if null args@@ -904,37 +982,57 @@ gens <- liftIO $ generate cmdname cmdargs case gens of Just w -> return $ Right $ ResolvedString w- Nothing -> throwPosError $ "Function call generate for command " ++ cmdname ++ " (" ++ show cmdargs ++ ") failed"+ Nothing -> throwPosError $ "Function call generate for command " <> cmdname <> " (" <> tshow 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+ let+ rvalue2query :: ResolvedValue -> Either String PDB.Query+ rvalue2query (ResolvedArray (ResolvedString o : nxs)) = case PDB.getOperator o of+ Just PDB.OAnd -> fmap (PDB.Query PDB.OAnd) (mapM rvalue2query nxs)+ Just PDB.OOr -> fmap (PDB.Query PDB.OOr) (mapM rvalue2query nxs)+ Just PDB.ONot -> fmap (PDB.Query PDB.ONot) (mapM rvalue2query nxs)+ Just op -> fmap (PDB.Query op) (mapM rvalue2query' nxs)+ Nothing -> Left $ "Can't resolve operator " ++ T.unpack o+ rvalue2query x = Left $ "Don't know what to do with " ++ T.unpack (showValue x) + rvalue2query' :: ResolvedValue -> Either String PDB.Query+ rvalue2query' (ResolvedArray x) = fmap PDB.Terms (mapM rvalue2string x)+ rvalue2query' x = fmap PDB.Term (rvalue2string x)+ rvalue2string :: ResolvedValue -> Either String T.Text+ rvalue2string (ResolvedString s) = Right s+ rvalue2string (ResolvedBool True) = Right "true"+ rvalue2string (ResolvedBool False) = Right "false"+ rvalue2string x = Left $ "Don't know why we had " ++ T.unpack (showValue x)+ 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) -> case rvalue2query a of+ Right q -> fmap Right (pdbresourcequery q keyname)+ Left rr -> throwPosError ("Could not transform " <> showValue a <> " to a PuppetDB query: " <> T.pack rr)+ (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 Right s -> let- goodpart gs = (length gs < 64) && (not $ null gs) && (isAlpha $ head gs) && (all (\gx -> (gx=='-') || (isAlphaNum gx)) gs)+ goodpart gs = T.length gs < 64 && not (T.null gs) && isAlpha (T.head gs) && (T.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)+ let (b,e) = T.break (=='.') str+ in case (goodpart b, e) of+ (True , "") -> False+ (True , y) -> badparts (T.tail y)+ (False, _) -> True+ bad = T.null s || T.length s > 255 || badparts s -- TODO check the parts are 63 char long in return $ Right $ ResolvedBool $ not bad _ -> return $ Left $ Value n@@ -944,7 +1042,14 @@ else do nargs <- mapM resolveExpressionString args curmax <- readint (head nargs)- liftM (Right . ResolvedInt) (fqdn_rand curmax (tail nargs))+ hostname <- getVariable "::fqdn" >>= \x -> case x of+ Just (Right (ResolvedString g),_) -> return g+ _ -> throwPosError "Can't get fqdn in fqdn_rand?"+ let targs = tail nargs+ rargs = if null targs+ then [hostname, ""]+ else hostname : targs+ liftM (Right . ResolvedInt) (fqdn_rand curmax rargs) tryResolveValue (FunctionCall "mysql_password" args) = if length args /= 1 then throwPosError "mysql_password takes a single argument" else do@@ -955,17 +1060,29 @@ tryResolveValue (FunctionCall "template" [name]) = do fname <- tryResolveExpressionString name case fname of- Left x -> throwPosError $ "Can't resolve template path " ++ show x+ Left x -> throwPosError $ "Can't resolve template path " <> tshow x Right filename -> do vars <- fmap curVariables get >>= DT.mapM (\(v,p) -> fmap (\x -> (x,p)) (tryResolveGeneralValue v)) saveVariables vars scp <- liftM head getScope -- TODO check if that sucks templatefunc <- liftM computeTemplateFunction get- out <- liftIO (templatefunc filename scp (Map.map fst vars))+ out <- liftIO (templatefunc (Right filename) scp (Map.map fst vars)) case out of Right x -> return $ Right $ ResolvedString x- Left err -> throwPosError err-tryResolveValue (FunctionCall "inline_template" _) = return $ Right $ ResolvedString "TODO"+ Left err -> throwPosError (T.pack err)+tryResolveValue (FunctionCall "inline_template" [cnt]) = do+ rcnt <- tryResolveExpressionString cnt+ case rcnt of+ Left x -> throwPosError $ "Can't resolve inline_template content " <> tshow x+ Right content -> do+ vars <- fmap curVariables get >>= DT.mapM (\(v,p) -> fmap (\x -> (x,p)) (tryResolveGeneralValue v))+ saveVariables vars+ scp <- liftM head getScope -- TODO check if that sucks+ templatefunc <- liftM computeTemplateFunction get+ out <- liftIO (templatefunc (Left content) scp (Map.map fst vars))+ case out of+ Right x -> return $ Right $ ResolvedString x+ Left err -> throwPosError (T.pack err) tryResolveValue (FunctionCall "defined" [v]) = do rv <- tryResolveExpression v case rv of@@ -984,7 +1101,7 @@ Right (ResolvedRReference rtype (ResolvedString rname)) -> do defset <- fmap definedResources get return $ Right $ ResolvedBool (Map.member (rtype, rname) defset)- Right x -> throwPosError $ "Can't know if this could be defined : " ++ show x+ Right x -> throwPosError $ "Can't know if this could be defined : " <> tshow x tryResolveValue n@(FunctionCall "regsubst" [str, src, dst, flags]) = do rstr <- tryResolveExpressionString str rsrc <- tryResolveExpressionString src@@ -994,12 +1111,11 @@ (Right sstr, Right ssrc, Right sdst, Right sflags) -> liftM (Right . ResolvedString) (regsubst sstr ssrc sdst sflags) _ -> return $ Left $ Value n 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 (FunctionCall "regsubst" args) = throwPosError ("Bad argument count for regsubst " <> tshow 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+ let mmychomp (ResolvedString s) = return $ ResolvedString (T.stripEnd s)+ mmychomp r = throwPosError $ "The chomp function expects strings or arrays of strings, not this: " <> tshow r rstr <- tryResolveExpression str case rstr of Left _ -> return $ Left $ Value n@@ -1014,11 +1130,11 @@ sp <- liftIO $ puppetSplit sstr sreg case sp of Right o -> return $ Right $ ResolvedArray $ map ResolvedString o- Left r -> throwPosError $ "split error: " ++ show r+ Left r -> throwPosError $ "split error: " <> tshow 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)-tryResolveValue n@(FunctionCall "lowcase" args) = stringTransform args n (map toLower)+tryResolveValue n@(FunctionCall "upcase" args) = stringTransform args n T.toUpper+tryResolveValue n@(FunctionCall "lowcase" args) = stringTransform args n T.toLower tryResolveValue n@(FunctionCall "sha1" args) = stringTransform args n puppetSHA1 tryResolveValue n@(FunctionCall "md5" args) = stringTransform args n puppetMD5 @@ -1036,10 +1152,21 @@ then do content <- liftIO $ file rf case content of- Nothing -> throwPosError $ "Files " ++ show rf ++ " could not be found"+ Nothing -> throwPosError $ "Files " <> tshow rf <> " could not be found" Just x -> return $ Right $ ResolvedString x else return $ Left $ Value n-+tryResolveValue n@(FunctionCall "getvar" [varinfo]) = do+ varname <- tryResolveExpressionString varinfo+ case varname of+ Right s -> tryResolveValue (VariableReference s)+ Left _ -> return $ Left $ Value n+tryResolveValue (FunctionCall "getvar" nn) = throwPosError $ "getvar expects a single argument, not " <> tshow (length nn)+tryResolveValue n@(FunctionCall "is_string" [varinfo]) = do+ varname <- tryResolveExpression varinfo+ case varname of+ Right (ResolvedString _) -> return $ Right $ ResolvedBool True+ Right _ -> return $ Right $ ResolvedBool False+ Left _ -> return $ Left $ Value n tryResolveValue n@(FunctionCall fname args) = do ufunctions <- fmap userFunctions get l <- fmap luaState get@@ -1049,22 +1176,24 @@ if null (lefts rargs) then fmap Right (puppetFunc ls fname (rights rargs)) else return $ Left $ Value n- _ -> throwPosError ("FunctionCall " ++ fname ++ " not implemented")+ _ -> throwPosError ("FunctionCall " <> fname <> " not implemented") tryResolveValue Undefined = return $ Right ResolvedUndefined tryResolveValue (PuppetRegexp x) = return $ Right $ ResolvedRegexp x -tryResolveValue x = throwPosError ("tryResolveValue not implemented for " ++ show x)+tryResolveValue x = throwPosError ("tryResolveValue not implemented for " <> tshow x) tryResolveValueString :: Value -> CatalogMonad GeneralString tryResolveValueString x = do r <- tryResolveValue x case r of- Right (ResolvedString v) -> return $ Right v- Right (ResolvedInt i) -> return $ Right (show i)- Right (ResolvedDouble i) -> return $ Right (show i)- Right v -> throwPosError ("Can't resolve valuestring for " ++ show v)- Left v -> return $ Left v+ Right (ResolvedString v) -> return $ Right v+ Right (ResolvedInt i) -> return $ Right (tshow i)+ Right (ResolvedDouble i) -> return $ Right (tshow i)+ Right (ResolvedBool True) -> return $ Right "True"+ Right (ResolvedBool False) -> return $ Right "False"+ Right v -> throwPosError ("Can't resolve valuestring for " <> tshow v)+ Left v -> return $ Left v getRelationParameterType :: GeneralString -> Maybe LinkType getRelationParameterType (Right "require" ) = Just RRequire@@ -1077,18 +1206,22 @@ pushRealize :: ResolvedValue -> CatalogMonad () pushRealize (ResolvedRReference rtype (ResolvedString rname)) = do let myfunction :: CResource -> CatalogMonad Bool- myfunction (CResource _ mcrname mcrtype _ _ _) = do+ myfunction (CResource _ mcrname mcrtype _ _ _ _) = do srname <- resolveGeneralString mcrname return ((srname == rname) && (mcrtype == rtype)) addCollect ((myfunction, Just $ PDB.queryRealize rtype rname) , Map.empty) return ()-pushRealize (ResolvedRReference _ x) = throwPosError (show x ++ " was not resolved to a string")-pushRealize x = throwPosError ("A reference was expected instead of " ++ show x)+pushRealize (ResolvedRReference _ x) = throwPosError (tshow x <> " was not resolved to a string")+pushRealize x = throwPosError ("A reference was expected instead of " <> tshow x) -executeFunction :: String -> [ResolvedValue] -> CatalogMonad Catalog-executeFunction "fail" [ResolvedString errmsg] = throwPosError ("Error: " ++ errmsg)-executeFunction "fail" args = throwPosError ("Error: " ++ show args)+executeFunction :: T.Text -> [ResolvedValue] -> CatalogMonad Catalog+executeFunction "fail" [ResolvedString errmsg] = throwPosError ("Error: " <> errmsg)+executeFunction "fail" args = throwPosError ("Error: " <> tshow args) executeFunction "realize" rlist = mapM_ pushRealize rlist >> return []+executeFunction "dumpvariables" _ = do+ vars <- fmap curVariables get+ mapM_ (liftIO . print) (Map.toList vars)+ return [] executeFunction "create_resources" (mrtype:rdefs:rest) = do -- applyDefaults' :: CResource -> ResDefaults -> CatalogMonad CResource -- data ResDefaults = RDefaults String [(GeneralString, GeneralValue)] SourcePos@@ -1096,15 +1229,15 @@ -- mrrtype <- case mrtype of ResolvedString x -> return x- _ -> throwPosError $ "Resource type must be a string and not " ++ show mrtype+ _ -> throwPosError $ "Resource type must be a string and not " <> tshow 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 " <> tshow rdefs position <- getPos defaults <- case rest of- [ResolvedHash h] -> return $ RDefaults mrrtype (Map.fromList $ map (\(a,b) -> (Right a, Right b)) h) position+ [ResolvedHash h] -> return $ RDefaults mrrtype (Map.fromList $ map (Right *** Right) h) position [] -> return $ RDefaults mrrtype Map.empty position- _ -> throwPosError ("Bad many arguments to create_resources: " ++ show rest)+ _ -> throwPosError ("Bad many arguments to create_resources: " <> tshow rest) let prestatements = map (\(rname, rargs) -> (Value $ Literal rname, resolved2expression rargs)) arghash resources <- mapM (\(resname, pval) -> do realargs <- case pval of@@ -1113,31 +1246,41 @@ return $ Resource mrrtype resname realargs Normal position ) prestatements liftM concat (mapM evaluateStatements resources) >>= mapM (\r -> applyDefaults' r defaults)-executeFunction "create_resources" x = throwPosError ("Bad arguments to create_resources: " ++ show x)+executeFunction "create_resources" x = throwPosError ("Bad arguments to create_resources: " <> tshow x) executeFunction "validate_array" [x] = case x of ResolvedArray _ -> return []- y -> throwPosError $ show y ++ " is not an array"+ y -> throwPosError $ tshow y <> " is not an array" executeFunction "validate_hash" [x] = case x of ResolvedHash _ -> return []- y -> throwPosError $ show y ++ " is not a hash"+ y -> throwPosError $ tshow y <> " is not a hash" executeFunction "validate_string" [x] = case x of ResolvedString _ -> return []- y -> throwPosError $ show y ++ " is not an string"+ y -> throwPosError $ tshow y <> " is not an string" executeFunction "validate_re" [x,re] = case (x,re) of (ResolvedString z, ResolvedString rre) -> do 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+ Right False -> throwPosError $ tshow x <> " does not match the regexp " <> tshow rre+ Left err -> throwPosError $ "Error with regexp " <> tshow rre <> ": " <> T.pack err+ (y,z) -> throwPosError $ "Can't compare " <> tshow y <> " to regexp " <> tshow z executeFunction "validate_bool" [x] = case x of ResolvedBool _ -> return []- y -> throwPosError $ show y ++ " is not a boolean"-executeFunction a b = do- position <- getPos- addWarning $ "Function " ++ a ++ "(" ++ show b ++ ") not handled at " ++ show position- return []+ y -> throwPosError $ tshow y <> " is not a boolean"+executeFunction fname args = do+ ufunctions <- fmap userFunctions get+ l <- fmap luaState get+ case (l, Set.member fname ufunctions) of+ (Just ls, True) -> do+ o <- puppetFunc ls fname args+ case o of+ ResolvedBool True -> return []+ ResolvedBool False -> throwPosError ("Function " <> fname <> "(" <> tshow args <> ") returned false")+ x -> throwPosError ("Function " <> fname <> "(" <> tshow args <> ") did not return a bool: " <> tshow x)+ _ -> do+ position <- getPos+ addWarning $ "Function " <> fname <> "(" <> tshow args <> ") not handled at " <> tshow position+ return [] compareExpression :: Expression -> Expression -> CatalogMonad (Maybe Ordering) compareExpression a b = do@@ -1161,13 +1304,19 @@ Nothing -> return n Just x -> return $ Right $ ResolvedBool (x `elem` acceptable) compareValues :: ResolvedValue -> ResolvedValue -> Ordering+compareValues (ResolvedString s) (ResolvedBool b) = case (s,b) of+ ("true", True) -> EQ+ ("false", False) -> EQ+ _ -> LT+compareValues a@(ResolvedBool _) b@(ResolvedString _) = compareValues b a 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) = case (unsafePerformIO $ regmatch a b) of- Right True -> EQ- _ -> LT-compareValues (ResolvedString a) (ResolvedString b) = comparing (map toLower) a b+compareValues (ResolvedInt a) (ResolvedString b) = case readDecimal b of+ Right bi -> compare a bi+ _ -> LT+compareValues (ResolvedString a) (ResolvedRegexp b) = case unsafePerformIO (regmatch a b) of+ Right True -> EQ+ _ -> LT+compareValues (ResolvedString a) (ResolvedString b) = comparing T.toCaseFold a b compareValues x y = compare x y compareRValues :: ResolvedValue -> ResolvedValue -> Bool@@ -1197,13 +1346,13 @@ rv <- tryResolveBoolean v case rv of Right (ResolvedBool x) -> return x- n -> throwPosError ("Could not resolve " ++ show n ++ "(was " ++ show rv ++ ") as a boolean")+ n -> throwPosError ("Could not resolve " <> tshow n <> "(was " <> tshow rv <> ") as a boolean") -resolveGeneralString :: GeneralString -> CatalogMonad String+resolveGeneralString :: GeneralString -> CatalogMonad T.Text resolveGeneralString (Right x) = return x resolveGeneralString (Left y) = resolveExpressionString y -collectionFunction :: Virtuality -> String -> Expression -> CatalogMonad (CResource -> CatalogMonad Bool, Maybe PDB.Query)+collectionFunction :: Virtuality -> T.Text -> Expression -> CatalogMonad (CResource -> CatalogMonad Bool, Maybe PDB.Query) collectionFunction virt mrtype exprs = do (finalfunc, pdbquery) <- case exprs of BTrue -> return (\_ -> return True, Just (PDB.collectAll mrtype))@@ -1217,12 +1366,12 @@ paramset <- case defstatement of Nothing -> fmap nativeTypes get >>= \nt -> case Map.lookup mrtype nt of Just (PuppetTypeMethods _ ps) -> return ps- Nothing -> throwPosError $ "Unknown type " ++ mrtype ++ " when trying to collect"+ Nothing -> throwPosError $ "Unknown type " <> mrtype <> " when trying to collect" Just (DefineDeclaration _ params _ _) -> return $ Set.fromList $ map fst params- Just x -> throwPosError $ "Expected a DefineDeclaration here instead of " ++ show x- when (Set.notMember paramname paramset && (not $ Set.member paramname metaparameters)) $- throwPosError $ "Parameter " ++ paramname ++ " is not a valid parameter. It should be in : " ++ show (Set.toList paramset)- return (\r -> do+ Just x -> throwPosError $ "Expected a DefineDeclaration here instead of " <> tshow x+ when (Set.notMember paramname paramset && not (Set.member paramname metaparameters)) $+ throwPosError $ "Parameter " <> paramname <> " is not a valid parameter. It should be in : " <> tshow (Set.toList paramset)+ return (\r -> case Map.lookup (Right paramname) (crparams r) of Nothing -> return False Just prmmatch -> do@@ -1237,13 +1386,13 @@ (param, ResolvedString prmval) -> Just (PDB.collectParam mrtype param prmval) _ -> Nothing )- x -> throwPosError $ "TODO : implement collection function for " ++ show x- return (\res -> do+ x -> throwPosError $ "TODO : implement collection function for " <> tshow x+ return (\res -> -- <| |> matches Normal resources if (crtype res == mrtype) && ( ((virt == Virtual) && (crvirtuality res == Normal)) || (crvirtuality res == virt)) then finalfunc res else return False- , if (virt == Exported)+ , if virt == Exported then pdbquery else Nothing )@@ -1254,9 +1403,9 @@ generalValue2Expression (Right y) = resolved2expression y generalValue2Value :: GeneralValue -> CatalogMonad Value-generalValue2Value x = case (generalValue2Expression x) of+generalValue2Value x = case generalValue2Expression x of (Value z) -> return z- y -> throwPosError $ "Could not downgrade this to a value: " ++ show y+ y -> throwPosError $ "Could not downgrade this to a value: " <> tshow y resolved2expression :: ResolvedValue -> Expression resolved2expression (ResolvedString str) = Value $ Literal str@@ -1282,7 +1431,7 @@ _ -> return def -stringTransform :: [Expression] -> Value -> (String -> String) -> CatalogMonad GeneralValue+stringTransform :: [Expression] -> Value -> (T.Text -> T.Text) -> CatalogMonad GeneralValue stringTransform [u] n f = do r <- tryResolveExpressionString u case r of
Puppet/Interpreter/Functions.hs view
@@ -1,144 +1,145 @@-module Puppet.Interpreter.Functions - (fqdn_rand- ,regsubst- ,mysql_password- ,regmatch- ,versioncmp- ,file- ,puppetSplit- ,puppetSHA1- ,puppetMD5- ,generate- ,pdbresourcequery+module Puppet.Interpreter.Functions+ ( fqdn_rand+ , regsubst+ , mysql_password+ , regmatch+ , versioncmp+ , file+ , puppetSplit+ , puppetSHA1+ , puppetMD5+ , generate+ , pdbresourcequery ) where -import PuppetDB.Rest+import PuppetDB.Query import Puppet.Printers import Puppet.Interpreter.Types+import Puppet.Interpreter.RubyRandom+import Puppet.Utils -import Data.Hash.MD5+import Control.Monad.State+import Prelude hiding (catch)+import Control.Exception 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 Control.Monad.Error-import System.IO+import qualified Crypto.Hash.MD5 as MD5+import Text.Regex.PCRE.ByteString+import Text.Regex.PCRE.ByteString.Utils+import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as B16 import SafeProcess import Data.Either (lefts, rights)-import Data.List (intercalate)-import qualified Data.ByteString.Lazy.Char8 as BSL-import Data.Char (toUpper)+import Data.List (intercalate,foldl')+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import Data.Bits -puppetMD5 = md5s . Str-puppetSHA1 = BS.unpack . B16.encode . SHA1.hash . BS.pack-puppetMysql = BS.unpack . B16.encode . SHA1.hash . SHA1.hash . BS.pack+puppetMD5 :: T.Text -> T.Text+puppetMD5 = T.decodeUtf8 . B16.encode . MD5.hash . T.encodeUtf8+puppetSHA1 :: T.Text -> T.Text+puppetSHA1 = T.decodeUtf8 . B16.encode . SHA1.hash . T.encodeUtf8+puppetMysql :: T.Text -> T.Text+puppetMysql = T.decodeUtf8 . B16.encode . SHA1.hash . SHA1.hash . T.encodeUtf8 {- TODO : achieve compatibility with puppet the first String must be the fqdn -}-fqdn_rand :: Integer -> [String] -> CatalogMonad Integer-fqdn_rand n args = return (hash `mod` n)+fqdn_rand :: Integer -> [T.Text] -> CatalogMonad Integer+fqdn_rand n args = return val where- fullstring = Data.String.Utils.join ":" args- hash = md5i $ Str fullstring+ fullstring = T.intercalate ":" args+ toint = BS.foldl' (\c nx -> c*256 + fromIntegral nx) 0+ myhash = toint (MD5.hash (T.encodeUtf8 fullstring)) :: Integer+ val = fromIntegral (fst (limitedRand (randInit myhash) (fromIntegral n))) -mysql_password :: String -> CatalogMonad String-mysql_password pwd = return $ '*':hash+mysql_password :: T.Text -> CatalogMonad T.Text+mysql_password pwd = return $ T.cons '*' hash where- hash = map toUpper $ puppetMysql pwd+ hash = T.toUpper $ puppetMysql pwd -regsubst :: String -> String -> String -> String -> CatalogMonad String-regsubst str src dst flags = do- let multiline = 'M' `elem` flags- extended = 'E' `elem` flags- insensitive = 'I' `elem` flags- global = 'G' `elem` flags- refunc | global = gsubRegexPR- | otherwise = subRegexPR- when multiline $ throwError "Multiline flag not implemented"- 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"+regsubst :: T.Text -> T.Text -> T.Text -> T.Text -> CatalogMonad T.Text+regsubst str reg dst flags = do+ let multiline = if 'M' `textElem` flags then compMultiline else compBlank+ extended = if 'E' `textElem` flags then compExtended else compBlank+ insensitive = if 'I' `textElem` flags then compCaseless else compBlank+ global = 'G' `textElem` flags -- TODO fix global+ options = multiline .|. extended .|. insensitive+ regexp <- liftIO $ compile options execBlank (T.encodeUtf8 reg)+ case regexp of+ Left rr -> throwPosError (tshow rr)+ Right cr -> do+ res <- liftIO $ substitute cr (T.encodeUtf8 str) (T.encodeUtf8 dst)+ case res of+ Right r -> return (T.decodeUtf8 r)+ Left rr -> throwPosError (T.pack rr) -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+versioncmp :: T.Text -> T.Text -> Integer versioncmp a b | a > b = 1 | a < b = -1 | otherwise = 0 -file :: [String] -> IO (Maybe String)+file :: [T.Text] -> IO (Maybe T.Text) file [] = return Nothing-file (x:xs) = catch (liftM Just (withFile x ReadMode hGetContents)) (\_ -> file xs)--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+-- this is bad, is should be rewritten as a ByteString+file (x:xs) = catch+ (fmap Just (T.readFile (T.unpack x)))+ (\SomeException{} -> file xs) --- 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+puppetSplit :: T.Text -> T.Text -> IO (Either String [T.Text])+puppetSplit str reg = fmap (fmap (map T.decodeUtf8)) (splitCompile (T.encodeUtf8 reg) (T.encodeUtf8 str)) -generate :: String -> [String] -> IO (Maybe String)+generate :: T.Text -> [T.Text] -> IO (Maybe T.Text) generate command args = do- cmdout <- safeReadProcessTimeout command args (BSL.empty) 60000+ cmdout <- safeReadProcessTimeout (T.unpack command) (map T.unpack args) TL.empty 60000 case cmdout of- Just (Right x) -> return $ Just (BSL.unpack x)+ Just (Right x) -> return $ Just x _ -> return Nothing -pdbresourcequery :: String -> Maybe String -> CatalogMonad ResolvedValue+pdbresourcequery :: Query -> Maybe T.Text -> CatalogMonad ResolvedValue pdbresourcequery query key = do let- extractSubHash :: String -> [ResolvedValue] -> Either String ResolvedValue+ extractSubHash :: T.Text -> [ResolvedValue] -> Either String ResolvedValue extractSubHash k vals = let o = map (extractSubHash' k) vals- in if (null $ lefts o)+ 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+ else Left $ "Something wrong happened while extracting the subhashes for key " ++ T.unpack k ++ ": " ++ Data.List.intercalate ", " (lefts o)+ extractSubHash' :: T.Text -> 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+ extractSubHash' _ x = Left $ "Expected a hash, not " ++ T.unpack (showValue x)+ qf <- fmap puppetDBFunction get+ v <- liftIO (qf "resources" query) >>= \r -> case r of+ Left rr -> throwPosError (T.pack rr)+ Right x -> return x+ --v <- liftIO $ rawRequest "http://localhost:8080" "resources" query+ rv <- case json2puppet 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+ Right wtf -> throwPosError $ "Expected an array from PuppetDB, not " <> showValue wtf+ Left err -> throwPosError $ "Error during Puppet query: " <> T.pack 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"+ Left r -> throwPosError (T.pack r)+ _ -> throwPosError "Can't happen at pdbresourcequery"++regmatch :: T.Text -> T.Text -> IO (Either String Bool)+regmatch str reg = do+ icmp <- compile compBlank execBlank (T.encodeUtf8 reg)+ case icmp of+ Right rr -> do+ x <- execute rr (T.encodeUtf8 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
+ Puppet/Interpreter/RubyRandom.hs view
@@ -0,0 +1,118 @@+module Puppet.Interpreter.RubyRandom (rbGenrandInt32, randInit, limitedRand) where++import qualified Data.Vector.Unboxed as V+import qualified Data.Vector.Unboxed.Mutable as VM+import Data.Bits+import Data.List (unfoldr,foldl')++data RandState = RandState { _array :: V.Vector Int+ , _left :: Int+ , _initf :: Int+ , _next :: Int+ } deriving (Show)++mixbits :: Int -> Int -> Int+mixbits u v = (u .&. 0x80000000) .|. (v .&. 0x7fffffff)++twist :: Int -> Int -> Int+twist u v = (mixbits u v `shiftR` 1) `xor` ma+ where+ ma = if (v .&. 1) == 1+ then 0x9908b0df+ else 0++valN :: Int+valN = 624+valM :: Int+valM = 397++initGenrand :: Integer -> RandState+initGenrand rseed = RandState (V.fromList (scanl genfunc seed [1..(valN - 1)])) 1 1 0+ where+ seed = fromIntegral rseed .&. 0xffffffff+ genfunc :: Int -> Int -> Int+ genfunc curval x = (1812433253 * (curval `xor` (curval `shiftR` 30)) + x) .&. 0xffffffff++nextState :: RandState -> RandState+nextState (RandState array _ initf _) = RandState narray valN 1 0+ where+ rarray = if initf == 0+ then _array (initGenrand 5489)+ else array+ narray = V.modify (\v -> twist1 v >> twist2 v >> final v) rarray+ twist1 v = mapM_ (twist' valM v) [0..(valN - valM - 1)]+ twist2 v = mapM_ (twist' (valM - valN) v) [(valN - valM) .. (valN - 2)]+ final v = do+ a <- VM.read v (valN - 1)+ b <- VM.read v 0+ pm <- VM.read v (valM - 1)+ let res = pm `xor` twist a b+ VM.write v (valN - 1) res+ twist' idx v n = do+ a <- VM.read v n+ b <- VM.read v (n+1)+ pm <- VM.read v (idx + n)+ let res = pm `xor` twist a b+ VM.write v n res++-- needs refactoring, too tedious for me+initGenrandBigint :: Integer -> RandState+initGenrandBigint seed =+ let intarray = unfoldr reduce seed+ reduce :: Integer -> Maybe (Integer, Integer)+ reduce 0 = Nothing+ reduce x = Just (x .&. 0xffffffff, x `shiftR` 32)+ initstate = _array (initGenrand 19650218)+ keylist = concat (repeat intarray)+ jlist = concat (repeat [0..(length intarray - 1)])+ kmax = max (length intarray) valN+ state1 = foldl' apply1 initstate (zip3 keylist jlist [1..kmax])+ apply1 :: V.Vector Int -> (Integer, Int, Int) -> V.Vector Int+ apply1 ra (initKey, j, ri) =+ let (a, i, sti, stim) = rollover ra ri+ nsti = ((sti `xor` ((stim `xor` (stim `shiftR` 30)) * 1664525)) + fromIntegral initKey + j) .&. 0xffffffff+ in a V.// [(i,nsti)]+ state2 = foldl' apply2 state1 [2..valN]+ rollover :: V.Vector Int -> Int -> (V.Vector Int, Int, Int, Int)+ rollover ra ri =+ let (a,i) = if ri >= valN+ then (ra V.// [(0, ra V.! (valN-1))],1)+ else (ra,ri)+ in (a,i,a V.! i, a V.! (i-1))+ apply2 :: V.Vector Int -> Int -> V.Vector Int+ apply2 ra ri =+ let (a, i, sti, stim) = rollover ra ri+ nsti = ((sti `xor` ((stim `xor` (stim `shiftR` 30)) * 1566083941)) - i) .&. 0xffffffff+ in a V.// [(i,nsti)]+ in RandState (state2 V.// [(0,0x80000000)]) 1 1 0+++randInit :: Integer -> RandState+randInit x = if x <= 0xffffffff+ then initGenrand x+ else initGenrandBigint x++rbGenrandInt32 :: RandState -> (Int, RandState)+rbGenrandInt32 st =+ let rst = if _left st == 1+ then nextState st+ else st { _left = _left st - 1 }+ next = _next rst+ cv = _array rst V.! next+ nst = rst { _next = next + 1 }+ y1 = cv `xor` (cv `shiftR` 11)+ y2 = y1 `xor` ((y1 `shiftL` 7) .&. 0x9d2c5680)+ y3 = y2 `xor` ((y2 `shiftL` 15) .&. 0xefc60000)+ y4 = y3 `xor` (y3 `shiftR` 18)+ in (y4,nst)++limitedRand :: RandState -> Int -> (Int, RandState)+limitedRand s n = limitedRand' s+ where+ mask = foldl' (\x pow -> x .|. (x `shiftR` pow)) (n - 1) [1,2,4,8,16,32]+ limitedRand' s' =+ let (rval, ns) = rbGenrandInt32 s'+ val = rval .&. mask+ in if n < val+ then limitedRand' ns+ else (val, ns)
Puppet/Interpreter/Types.hs view
@@ -1,6 +1,7 @@ module Puppet.Interpreter.Types where -import Puppet.DSL.Types+import Puppet.DSL.Types hiding (Value) -- conflicts with aeson+import Puppet.Utils import qualified PuppetDB.Query as PDB import qualified Scripting.Lua as Lua@@ -10,47 +11,94 @@ import qualified Data.Map as Map import qualified Data.Set as Set import GHC.Exts-import Data.List+import Data.Aeson+import qualified Data.HashMap.Strict as HM+import Control.Applicative+import qualified Data.Text as T+import Data.Attoparsec.Number+import qualified Text.Parsec.Pos as TPP+import qualified Data.Vector as V+import Control.Arrow ( (***) )+import Data.Maybe (fromMaybe) -- | Types for the native type system.-type PuppetTypeName = String+type PuppetTypeName = T.Text -- |This is a function type than can be bound. It is the type of all subsequent -- validators. type PuppetTypeValidate = RResource -> Either String RResource data PuppetTypeMethods = PuppetTypeMethods { puppetvalidate :: PuppetTypeValidate,- puppetfields :: Set.Set String+ puppetfields :: Set.Set T.Text } -- | This is the potentially unsolved list of resources in the catalog. type Catalog =[CResource]-type Facts = Map.Map String ResolvedValue+type Facts = Map.Map T.Text ResolvedValue -- | Relationship link type. data LinkType = RNotify | RRequire | RBefore | RSubscribe deriving(Show, Ord, Eq)-type LinkInfo = (LinkType, RelUpdateType, SourcePos)+type LinkInfo = (LinkType, RelUpdateType, SourcePos, [[ScopeName]]) -- | 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 -- compared with the 'Value's. data ResolvedValue- = ResolvedString !String- | ResolvedRegexp !String+ = ResolvedString !T.Text+ | ResolvedRegexp !T.Text | ResolvedInt !Integer | ResolvedDouble !Double | ResolvedBool !Bool- | ResolvedRReference !String !ResolvedValue+ | ResolvedRReference !T.Text !ResolvedValue | ResolvedArray ![ResolvedValue]- | ResolvedHash ![(String, ResolvedValue)]+ | ResolvedHash ![(T.Text, ResolvedValue)] | ResolvedUndefined deriving(Show, Eq, Ord) +instance IsString ResolvedValue where+ fromString = ResolvedString . fromString++instance ToJSON ResolvedValue where+ toJSON (ResolvedString s) = String s+ toJSON (ResolvedRegexp r) = String r+ toJSON (ResolvedInt i) = Number (I i)+ toJSON (ResolvedDouble d) = Number (D d)+ toJSON (ResolvedBool b) = Bool b+ toJSON (ResolvedRReference _ _) = Null -- TODO+ toJSON (ResolvedArray rr) = toJSON rr+ toJSON (ResolvedHash hh) = object (map (uncurry (.=)) hh)+ toJSON (ResolvedUndefined) = Null++parseResourceReference :: T.Text -> Maybe ResolvedValue+parseResourceReference instr = case T.splitOn "[" instr of+ [restype, renamee] -> if T.last renamee == ']'+ then Just (ResolvedRReference (T.toLower restype) (ResolvedString (T.init renamee)))+ else Nothing+ _ -> Nothing++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) = case parseResourceReference s of+ Just x -> return x+ Nothing -> return $ ResolvedString s+ parseJSON (Array a) = fmap ResolvedArray (mapM parseJSON (V.toList a))+ parseJSON (Object o) = fmap ResolvedHash (mapM (\(a,b) -> do {+ b' <- parseJSON b ;+ return (a,b') }+ ) (HM.toList o))+ parseJSON (Bool b) = return $ ResolvedBool b++ -- | This type holds a value that is either from the ASL or fully resolved. type GeneralValue = Either Expression ResolvedValue+ -- | This type holds a value that is either from the ASL or a fully resolved -- String.-type GeneralString = Either Expression String+type GeneralString = Either Expression T.Text + {-| This describes the resources before the final resolution. This is required as they must somehow be collected while the 'Statement's are interpreted, but the necessary 'Expression's are not yet available. This is because in Puppet the@@ -62,14 +110,43 @@ data CResource = CResource { crid :: !Int, -- ^ Resource ID, used in the Puppet YAML. crname :: !GeneralString, -- ^ Resource name.- crtype :: !String, -- ^ Resource type.+ crtype :: !T.Text, -- ^ Resource type. crparams :: !(Map.Map GeneralString GeneralValue), -- ^ Resource parameters. crvirtuality :: !Virtuality, -- ^ Resource virtuality.+ crscope :: ![[ScopeName]], -- ^ Resource scope when it was defined pos :: !SourcePos -- ^ Source code position of the resource definition. } deriving(Show) +instance FromJSON CResource where+ parseJSON (Object o) = do+ utitle <- o .: "title"+ params <- o .: "parameters"+ sourcefile <- o .: "sourcefile"+ sourceline <- o .: "sourceline"+ certname <- o .: "certname"+ scope <- o .:? "scope"+ let _ = params :: HM.HashMap T.Text ResolvedValue+ parameters = Map.fromList $ map (Right *** Right) $ ("EXPORTEDSOURCE", ResolvedString certname) : HM.toList params :: Map.Map GeneralString GeneralValue+ position = TPP.newPos (T.unpack sourcefile ++ "(host: " ++ T.unpack certname ++ ")") sourceline 1+ mscope = fromMaybe [["json"]] scope+ CResource <$> pure 0+ <*> pure (Right utitle)+ <*> fmap T.toLower (o .: "type")+ <*> pure parameters+ <*> pure Normal+ <*> pure mscope+ <*> pure position+ parseJSON _ = mzero+++-- | Used for puppetDB queries, converting values to CResources+json2puppet :: (FromJSON a) => Value -> Either String a+json2puppet x = case fromJSON x of+ Error s -> Left s+ Success a -> Right a+ -- | Resource identifier, made of a type, name pair.-type ResIdentifier = (String, String)+type ResIdentifier = (T.Text, T.Text) -- | Resource relation, made of a 'LinkType', 'ResIdentifier' pair. type Relation = (LinkType, ResIdentifier)@@ -78,17 +155,30 @@ -} data RResource = RResource { rrid :: !Int, -- ^ Resource ID.- rrname :: !String, -- ^ Resource name.- rrtype :: !String, -- ^ Resource type.- rrparams :: !(Map.Map String ResolvedValue), -- ^ Resource parameters.+ rrname :: !T.Text, -- ^ Resource name.+ rrtype :: !T.Text, -- ^ Resource type.+ rrparams :: !(Map.Map T.Text ResolvedValue), -- ^ Resource parameters. rrelations :: ![Relation], -- ^ Resource relations.+ rrscope :: ![[ScopeName]], -- ^ Resource scope when it was defined rrpos :: !SourcePos -- ^ Source code position of the resource definition. } deriving(Show, Ord, Eq) +rr2json :: T.Text -> RResource -> Value+rr2json hostname rr =+ let sourcefile = sourceName (rrpos rr)+ sourceline = sourceLine (rrpos rr)+ in object [ "title" .= rrname rr+ , "sourcefile" .= sourcefile+ , "sourceline" .= sourceline+ , "type" .= capitalizeResType (rrtype rr)+ , "certname" .= hostname+ , "scope" .= rrscope rr+ , "parameters" .= rrparams rr+ ] type FinalCatalog = Map.Map ResIdentifier RResource -type ScopeName = String+type ScopeName = T.Text -- | Type of update\/override, so they can be applied in the correct order. This -- part is probably not behaving like vanilla puppet, as it turns out this are@@ -97,8 +187,8 @@ {-| A data type to hold defaults values -}-data ResDefaults = RDefaults String (Map.Map GeneralString GeneralValue) SourcePos- | ROverride String GeneralString (Map.Map GeneralString GeneralValue) SourcePos+data ResDefaults = RDefaults T.Text (Map.Map GeneralString GeneralValue) SourcePos+ | ROverride T.Text GeneralString (Map.Map GeneralString GeneralValue) SourcePos deriving (Show, Ord, Eq) {-| The most important data structure for the interpreter. It stores its@@ -110,11 +200,11 @@ -- be @[[\"::\"]]@. It is a stack of lists of strings. These lists can be -- one element wide (usual case), or two elements (inheritance), so that -- variables could be assigned to both scopes.- curVariables :: !(Map.Map String (GeneralValue, SourcePos)),+ curVariables :: !(Map.Map T.Text (GeneralValue, SourcePos)), -- ^ The list of known variables. It should be noted that the interpreter -- tries to resolve them as soon as it can, so that it can store their -- current scope.- curClasses :: !(Map.Map String SourcePos),+ curClasses :: !(Map.Map T.Text SourcePos), -- ^ The list of classes that have already been included, along with the -- place where this happened. curDefaults :: !(Map.Map [ScopeName] [ResDefaults]),@@ -124,31 +214,31 @@ curPos :: !SourcePos, -- ^ Current position of the evaluated statement. This is mostly used to -- give useful error messages.- nestedtoplevels :: !(Map.Map (TopLevelType, String) Statement),+ nestedtoplevels :: !(Map.Map (TopLevelType, T.Text) Statement), -- ^ List of \"top levels\" that have been parsed inside another top level. -- Their behaviour is curently non canonical as the scoping rules are -- unclear.- getStatementsFunction :: TopLevelType -> String -> IO (Either String Statement),+ getStatementsFunction :: TopLevelType -> T.Text -> IO (Either String Statement), -- ^ This is a function that, given the type of a top level statement and -- its name, should return it.- getWarnings :: ![String], -- ^ List of warnings.+ getWarnings :: ![T.Text], -- ^ List of warnings. curCollect :: ![(CResource -> CatalogMonad Bool, Map.Map GeneralString GeneralValue, Maybe PDB.Query)], -- ^ 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. It can also store a PuppetDB query.- unresolvedRels :: ![([(LinkType, GeneralValue, GeneralValue)], (String, GeneralString), RelUpdateType, SourcePos)],+ unresolvedRels :: ![([(LinkType, GeneralValue, GeneralValue)], (T.Text, GeneralString), RelUpdateType, SourcePos, [[ScopeName]])], -- ^ This stores unresolved relationships, because the original string name -- can't be resolved. Fieds are [ ( [dstrelations], srcresource, type, pos ) ]- computeTemplateFunction :: String -> String -> Map.Map String GeneralValue -> IO (Either String String),- -- ^ Function that takes a filename, the current scope and a list of+ computeTemplateFunction :: Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> IO (Either String T.Text),+ -- ^ Function that takes either a text content or a filename, the current scope and a list of -- variables. It returns an error or the computed template.- puppetDBFunction :: Maybe (String -> PDB.Query -> IO (Either String [CResource])),+ puppetDBFunction :: T.Text -> PDB.Query -> IO (Either String Value), -- ^ Function that takes a request type (resources, nodes, facts, ..), -- a query, and returns a resolved value from puppetDB. luaState :: Maybe Lua.LuaState, -- ^ The Lua state, used for user supplied content.- userFunctions :: !(Set.Set String),+ userFunctions :: !(Set.Set T.Text), -- ^ The list of registered user functions nativeTypes :: !(Map.Map PuppetTypeName PuppetTypeMethods), -- ^ The list of native types.@@ -158,8 +248,12 @@ } -- | The monad all the interpreter lives in. It is 'ErrorT' with a state.-type CatalogMonad = ErrorT String (StateT ScopeState IO)+type CatalogMonad = ErrorT T.Text (StateT ScopeState IO) +instance Error T.Text where+ noMsg = ""+ strMsg = T.pack+ -- | This is the map of all edges associated with the 'FinalCatalog'. -- The key is (source, target). type EdgeMap = Map.Map (ResIdentifier, ResIdentifier) LinkInfo@@ -170,11 +264,12 @@ generalizeValueR = Right generalizeStringE :: Expression -> GeneralString generalizeStringE = Left-generalizeStringS :: String -> GeneralString+generalizeStringS :: T.Text -> GeneralString generalizeStringS = Right -- |This is the set of meta parameters-metaparameters = Set.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"]+metaparameters :: Set.Set T.Text+metaparameters = Set.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"] :: Set.Set T.Text getPos = liftM curPos get modifyScope f sc = sc { curScope = f $ curScope sc }@@ -189,10 +284,22 @@ addDefinedResource r p = modify (\st -> st { definedResources = Map.insert r p (definedResources st) } ) saveVariables vars = modify (\st -> st { curVariables = vars }) -throwPosError :: String -> CatalogMonad a+showScope :: [[ScopeName]] -> T.Text+showScope = tshow . reverse . concatMap (take 1)++throwPosError :: T.Text -> CatalogMonad a throwPosError msg = do p <- getPos- st <- liftIO currentCallStack- throwError (msg ++ " at " ++ show p ++ intercalate "\n\t" st )+ st <- fmap (map T.pack) (liftIO currentCallStack)+ throwError (msg <> " at " <> tshow p <> "\n\t" <> T.intercalate "\n\t" st) +addAlias :: T.Text -> RResource -> Either String RResource+addAlias value res = case Map.lookup "alias" (rrparams res) of+ Nothing -> Right $! insertparam res "alias" (ResolvedArray [ResolvedString value])+ Just a@(ResolvedString _) -> Right $! insertparam res "alias" (ResolvedArray [a,ResolvedString value])+ Just (ResolvedArray ar) -> Right $! insertparam res "alias" (ResolvedArray (ResolvedString value : ar))+ Just x -> Left ("Aliases should be strings or arrays of strings, not " ++ show x)++insertparam :: RResource -> T.Text -> ResolvedValue -> RResource+insertparam res param value = res { rrparams = Map.insert param value (rrparams res) }
Puppet/JsonCatalog.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} module Puppet.JsonCatalog where import Puppet.DSL.Types hiding (Value)@@ -14,7 +13,7 @@ import Text.Parsec.Pos import qualified Data.ByteString.Lazy as BSL -prref = String . T.pack . showRRef+prref = String . showRRef mkJsonCatalog :: T.Text -> Integer -> FinalCatalog -> FinalCatalog -> EdgeMap -> Value mkJsonCatalog nodename version cat exports edges = Object $ HM.fromList [("data",datahash), ("document_type", String "Catalog"), ("metadata", Object (HM.fromList [("api_version", Number 1)]))]@@ -28,25 +27,26 @@ , ("version" , Number (I version)) ] lcat = Map.toList cat- classes = map (String . T.pack . snd . fst) . filter (\((k,_),_) -> k == "class") $ lcat+ classes = map (String . snd . fst) . filter (\((k,_),_) -> k == "class") $ lcat --notcatalog = map fakeResource $ nubBy (\(a,_) (b,_) -> a == b) . filter (\(x,_) -> not (Map.member x cat)) . concatMap (\((a,b),(_,_,c)) -> [(a,c),(b,c)]) . Map.toList $ edges ledges = map (\(s,d) -> Object $ HM.fromList [("source", prref s),("target", prref d)] ) . filter (\i -> Map.member (fst i) cat && Map.member (snd i) cat) . Map.keys $ edges resources = map (res2JSon False . snd) lcat fakeResource :: (ResIdentifier, SourcePos) -> RResource-fakeResource ((t,n),p) = RResource 0 n t Map.empty [] p+fakeResource ((t,n),p) = RResource 0 n t Map.empty [] [["fake"]] p -- stuff that is done -- * the EXPORTEDSOURCE is added for resources coming from PuppetDB res2JSon :: Bool -> RResource -> Value-res2JSon isExported (RResource _ rn rt rp _ rpos) = Object $ HM.fromList [ ("exported", Bool isExported)- , ("file", String (T.pack (sourceName rpos)))- , ("line", Number (fromIntegral (sourceLine rpos)))- , ("parameters", Object (HM.delete "EXPORTEDSOURCE" $ HM.fromList paramlist))- , ("tags", Array V.empty)- , ("title", String (T.pack realtitle))- , ("type", String . T.pack . capitalizeResType $ rt)- ]+res2JSon isExported (RResource _ rn rt rp _ scopes rpos) = Object $ HM.fromList [ ("exported", Bool isExported)+ , ("file", String (T.pack $ sourceName rpos))+ , ("line", Number (fromIntegral (sourceLine rpos)))+ , ("parameters", Object (HM.delete "EXPORTEDSOURCE" $ HM.fromList paramlist))+ , ("tags", Array V.empty)+ , ("title", String realtitle)+ , ("type", String . capitalizeResType $ rt)+ , "scope" .= scopes+ ] where -- in puppet class titles are capitalized ... realtitle = if rt == "class"@@ -55,17 +55,17 @@ ctitle = case Map.lookup "title" rp of Just (ResolvedString s) -> s _ -> rn- paramlist = map (\(k,v) -> (T.pack k, rv2json v)) $ Map.toList $ Map.delete "title" rp+ paramlist = map (\(k,v) -> (k, rv2json v)) $ Map.toList $ Map.delete "title" rp rv2json :: ResolvedValue -> Value-rv2json (ResolvedString x) = String (T.pack x)-rv2json (ResolvedRegexp x) = String (T.pack x)+rv2json (ResolvedString x) = String x+rv2json (ResolvedRegexp x) = String x rv2json (ResolvedInt x) = Number (I x) rv2json (ResolvedDouble x) = Number (D x) rv2json (ResolvedBool x) = Bool x rv2json (ResolvedArray h) = Array (V.fromList (map rv2json h))-rv2json (ResolvedHash h) = Object $ HM.fromList $ map (\(k,v) -> (T.pack k, rv2json v)) h+rv2json (ResolvedHash h) = Object $ HM.fromList $ map (\(k,v) -> (k, rv2json v)) h rv2json _ = Null -catalog2JSon :: String -> Integer -> FinalCatalog -> FinalCatalog -> EdgeMap -> BSL.ByteString-catalog2JSon nodename version dc de dm = encode (mkJsonCatalog (T.pack nodename) version dc de dm)+catalog2JSon :: T.Text -> Integer -> FinalCatalog -> FinalCatalog -> EdgeMap -> BSL.ByteString+catalog2JSon nodename version dc de dm = encode (mkJsonCatalog nodename version dc de dm)
Puppet/NativeTypes.hs view
@@ -8,13 +8,16 @@ import Puppet.NativeTypes.Group import Puppet.NativeTypes.Host import Puppet.NativeTypes.Mount+import Puppet.NativeTypes.Package+import Puppet.NativeTypes.User import Puppet.NativeTypes.ZoneRecord+import Puppet.NativeTypes.SshSecure import Puppet.Interpreter.Types import qualified Data.Map as Map -fakeTypes = map faketype ["class", "ssh_authorized_key_secure"]+fakeTypes = map faketype ["class"] -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"]+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","vlan","yumrepo","zfs","zone","zpool"] -- | The map of native types. They are described in "Puppet.NativeTypes.Helpers". baseNativeTypes :: Map.Map PuppetTypeName PuppetTypeMethods@@ -26,4 +29,7 @@ : nativeZoneRecord : nativeCron : nativeExec+ : nativePackage+ : nativeUser+ : nativeSshSecure : fakeTypes ++ defaultTypes)
Puppet/NativeTypes/Cron.hs view
@@ -6,7 +6,9 @@ import qualified Data.Set as Set import qualified Data.Map as Map import Data.Char+import qualified Data.Text as T +nativeCron :: (PuppetTypeName, PuppetTypeMethods) 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.@@ -30,13 +32,13 @@ validateCron :: PuppetTypeValidate validateCron = defaultValidate parameterset >=> parameterFunctions parameterfunctions -vrange :: Integer -> Integer -> [String] -> String -> PuppetTypeValidate+vrange :: Integer -> Integer -> [T.Text] -> T.Text -> 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' :: Integer -> Integer -> [T.Text] -> T.Text -> RResource -> ResolvedValue -> Either String RResource vrange' mi ma valuelist param res y = case y of ResolvedString "*" -> Right res ResolvedString "absent" -> Right res@@ -44,21 +46,21 @@ 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+ x -> Left $ "Parameter " ++ T.unpack 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+parseval :: T.Text -> Integer -> Integer -> T.Text -> PuppetTypeValidate+parseval resval mi ma pname res | T.isPrefixOf "*/" resval = checkint (T.drop 2 resval) 1 ma pname res+ | otherwise = checkint resval mi ma pname res -checkint :: String -> Integer -> Integer -> String -> PuppetTypeValidate-checkint st mi ma pname res = if all isDigit st+checkint :: T.Text -> Integer -> Integer -> T.Text -> PuppetTypeValidate+checkint st mi ma pname res = if T.all isDigit st then- let v = read st :: Integer+ let v = read (T.unpack st) :: Integer in checkint' v mi ma pname res- else Left $ "Invalid value type for parameter " ++ pname+ else Left $ "Invalid value type for parameter " ++ T.unpack pname -checkint' :: Integer -> Integer -> Integer -> String -> PuppetTypeValidate-checkint' i mi ma param res = +checkint' :: Integer -> Integer -> Integer -> T.Text -> 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+ else Left $ "Parameter " ++ T.unpack param ++ " value is out of bound, should statisfy " ++ show mi ++ "<=" ++ show i ++ "<=" ++ show ma
Puppet/NativeTypes/Exec.hs view
@@ -4,7 +4,10 @@ import Puppet.Interpreter.Types import Control.Monad.Error import qualified Data.Set as Set+import qualified Data.Map as Map+import qualified Data.Text as T +nativeExec :: (PuppetTypeName, PuppetTypeMethods) 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.@@ -30,5 +33,11 @@ ] validateExec :: PuppetTypeValidate-validateExec = defaultValidate parameterset >=> parameterFunctions parameterfunctions+validateExec = defaultValidate parameterset >=> parameterFunctions parameterfunctions >=> fullyQualifiedOrPath +fullyQualifiedOrPath :: PuppetTypeValidate+fullyQualifiedOrPath res = case (Map.member "path" (rrparams res), Map.lookup "command" (rrparams res)) of+ (False, Just (ResolvedString x)) -> if T.head x == '/'+ then Right res+ else Left "Command must be fully qualified if path is not defined"+ _ -> Right res
Puppet/NativeTypes/File.hs view
@@ -6,7 +6,9 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Data.Char (isDigit)+import qualified Data.Text as T +nativeFile :: (PuppetTypeName, PuppetTypeMethods) 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.@@ -23,7 +25,7 @@ ,("links" , [string]) ,("mode" , [defaultvalue "0644", string]) ,("owner" , [string])- ,("path" , [nameval, fullyQualified])+ ,("path" , [nameval, fullyQualified, noTrailingSlash]) ,("provider" , [values ["posix","windows"]]) ,("purge" , [string, values ["true","false"]]) ,("recurse" , [string, values ["inf","true","false","remote"]])@@ -43,10 +45,10 @@ ResolvedString s -> s _ -> "0644" in do- when ((length modestr /= 3) && (length modestr /= 4)) (throwError "Invalid mode size")- when (not (all isDigit modestr)) (throwError "The mode should only be made of digits")- if length modestr == 3- then return $ insertparam res "mode" (ResolvedString ('0':modestr))+ when ((T.length modestr /= 3) && (T.length modestr /= 4)) (throwError "Invalid mode size")+ when (not (T.all isDigit modestr)) (throwError "The mode should only be made of digits")+ if T.length modestr == 3+ then return $ insertparam res "mode" (ResolvedString (T.cons '0' modestr)) else return res validateSourceOrContent :: PuppetTypeValidate
Puppet/NativeTypes/Group.hs view
@@ -5,6 +5,7 @@ import Control.Monad.Error import qualified Data.Set as Set +nativeGroup :: (PuppetTypeName, PuppetTypeMethods) 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.
Puppet/NativeTypes/Helpers.hs view
@@ -8,6 +8,8 @@ import qualified Data.Set as Set import Data.Char (isDigit) import Control.Monad+import qualified Data.Text as T+import Puppet.Utils faketype :: PuppetTypeName -> (PuppetTypeName, PuppetTypeMethods) faketype tname = (tname, PuppetTypeMethods Right Set.empty)@@ -17,11 +19,11 @@ {-| This helper will validate resources given a list of fields. It will run 'checkParameterList' and then 'addDefaults'. -}-defaultValidate :: Set.Set String -> PuppetTypeValidate+defaultValidate :: Set.Set T.Text -> PuppetTypeValidate defaultValidate validparameters = checkParameterList validparameters >=> addDefaults -- | This validator checks that no unknown parameters have been set (except metaparameters)-checkParameterList :: Set.Set String -> PuppetTypeValidate+checkParameterList :: Set.Set T.Text -> PuppetTypeValidate checkParameterList validparameters res | Set.null validparameters = Right res | otherwise = if Set.null setdiff then Right res@@ -40,141 +42,152 @@ nm = ResolvedString $ rrname res -- | Helper function that runs a validor on a ResolvedArray-runarray :: String -> (String -> ResolvedValue -> PuppetTypeValidate) -> PuppetTypeValidate+runarray :: T.Text -> (T.Text -> 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+ Just x -> Left $ "Parameter " ++ T.unpack 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 :: T.Text -> PuppetTypeValidate string param res = case Map.lookup param (rrparams res) of Just x -> string' param x res Nothing -> Right res -strings :: String -> PuppetTypeValidate+strings :: T.Text -> PuppetTypeValidate strings param = runarray param string' -string' :: String -> ResolvedValue -> PuppetTypeValidate+string' :: T.Text -> ResolvedValue -> PuppetTypeValidate string' param re res = case re of ResolvedString _ -> Right res- ResolvedInt n -> Right (insertparam res param (ResolvedString $ show n))+ ResolvedInt n -> Right (insertparam res param (ResolvedString (tshow 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+ x -> Left $ "Parameter " ++ T.unpack 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 :: [T.Text] -> T.Text -> 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 ++ " and not " ++ x- Just x -> Left $ "Parameter " ++ param ++ " value should be one of " ++ show valuelist ++ " and not " ++ show x+ else Left $ "Parameter " ++ T.unpack param ++ " value should be one of " ++ show valuelist ++ " and not " ++ T.unpack x+ Just x -> Left $ "Parameter " ++ T.unpack param ++ " value should be one of " ++ show valuelist ++ " and not " ++ show x Nothing -> Right res -- | This fills the default values of unset parameters.-defaultvalue :: String -> String -> PuppetTypeValidate+defaultvalue :: T.Text -> T.Text -> PuppetTypeValidate defaultvalue value param res = case (Map.lookup param (rrparams res)) of Just _ -> Right res Nothing -> Right $ insertparam res param (ResolvedString value) -insertparam :: RResource -> String -> ResolvedValue -> RResource-insertparam res param value = res { rrparams = Map.insert param value (rrparams res) }- -- | Checks that a given parameter, if set, is a 'ResolvedInt'. If it is a -- 'ResolvedString' it will attempt to parse it.-integer :: String -> PuppetTypeValidate+integer :: T.Text -> PuppetTypeValidate 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 -integers :: String -> PuppetTypeValidate+integers :: T.Text -> PuppetTypeValidate integers param = runarray param integer'' -integer'' :: String -> ResolvedValue -> PuppetTypeValidate+integer'' :: T.Text -> 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"+ ResolvedString x -> if T.all isDigit x+ then Right $ insertparam res param (ResolvedInt $ read $ T.unpack x)+ else Left $ "Parameter " ++ T.unpack param ++ " should be a number" ResolvedInt _ -> Right res- _ -> Left $ "Parameter " ++ param ++ " must be an integer"+ _ -> Left $ "Parameter " ++ T.unpack param ++ " must be an integer" -- | Copies the "name" value into the parameter if this is not set. It implies -- the `string` validator.-nameval :: String -> PuppetTypeValidate+nameval :: T.Text -> PuppetTypeValidate nameval prm res = do- nres <- string prm res+ nres <- string prm res >>= addAlias' prm 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." +addAlias' :: T.Text -> PuppetTypeValidate+addAlias' prm res = case Map.lookup prm (rrparams res) of+ Just (ResolvedString nm) -> addAlias nm res+ Just _ -> Left "Can't happen, the nameval should have been a string"+ Nothing -> return res+ -- | Checks that a given parameter is set.-mandatory :: String -> PuppetTypeValidate+mandatory :: T.Text -> PuppetTypeValidate mandatory param res = case Map.lookup param (rrparams res) of Just _ -> Right res- Nothing -> Left $ "Parameter " ++ param ++ " should be set."+ Nothing -> Left $ "Parameter " ++ T.unpack param ++ " should be set." -- | Helper that takes a list of stuff and will generate a validator.-parameterFunctions :: [(String, [String -> PuppetTypeValidate])] -> PuppetTypeValidate+parameterFunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] -> PuppetTypeValidate parameterFunctions argrules rs = foldM parameterFunctions' rs argrules where- parameterFunctions' :: RResource -> (String, [String -> PuppetTypeValidate]) -> Either String RResource+ parameterFunctions' :: RResource -> (T.Text, [T.Text -> PuppetTypeValidate]) -> Either String RResource parameterFunctions' r (param, validationfunctions) = foldM (parameterFunctions'' param) r validationfunctions- parameterFunctions'' :: String -> RResource -> (String -> PuppetTypeValidate) -> Either String RResource+ parameterFunctions'' :: T.Text -> RResource -> (T.Text -> PuppetTypeValidate) -> Either String RResource parameterFunctions'' param r validationfunction = validationfunction param r -- checks that a parameter is fully qualified-fullyQualified :: String -> PuppetTypeValidate+fullyQualified :: T.Text -> PuppetTypeValidate fullyQualified param res = case Map.lookup param (rrparams res) of Just path -> fullyQualified' param path res Nothing -> Right res -fullyQualifieds :: String -> PuppetTypeValidate+noTrailingSlash :: T.Text -> PuppetTypeValidate+noTrailingSlash param res = case Map.lookup param (rrparams res) of+ Just (ResolvedString x) -> if T.last x == '/'+ then Left ("Parameter " ++ T.unpack param ++ " should not have a trailing slash")+ else Right res+ _ -> Right res++fullyQualifieds :: T.Text -> PuppetTypeValidate fullyQualifieds param = runarray param fullyQualified' -fullyQualified' :: String -> ResolvedValue -> PuppetTypeValidate+fullyQualified' :: T.Text -> 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+ ResolvedString ("") -> Left $ "Empty path for parameter " ++ T.unpack param+ ResolvedString p -> if T.head p == '/'+ then Right res+ else Left $ "Path must be absolute, not " ++ T.unpack p ++ " for parameter " ++ T.unpack param+ x -> Left $ "SHOULD NOT HAPPEN: path is not a resolved string, but " ++ show x ++ " for parameter " ++ show x -rarray :: String -> PuppetTypeValidate+rarray :: T.Text -> 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 :: T.Text -> 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+ else Left $ "Invalid IP address for parameter " ++ T.unpack param+ Just x -> Left $ "Parameter " ++ T.unpack param ++ " should be an IP address string, not " ++ show x -checkipv4 :: String -> Int -> Bool+checkipv4 :: T.Text -> 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+ let (cur, nxt) = T.break (=='.') ip+ nextfunc = if T.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))+ else checkipv4 (T.tail nxt) (v+1)+ goodcur = not (T.null cur) && T.all isDigit cur && (let rcur = read (T.unpack cur) :: Int in (rcur >= 0) && (rcur <= 255)) in goodcur && nextfunc -inrange :: Integer -> Integer -> String -> PuppetTypeValidate+inrange :: Integer -> Integer -> T.Text -> 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+ else Left $ "Parameter " ++ T.unpack param ++ "'s value should be between " ++ show mi ++ " and " ++ show ma+ Just x -> Left $ "Parameter " ++ T.unpack param ++ " should be an integer, and not " ++ show x
Puppet/NativeTypes/Host.hs view
@@ -6,7 +6,9 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Data.Char (isAlphaNum)+import qualified Data.Text as T +nativeHost :: (PuppetTypeName, PuppetTypeMethods) 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.@@ -24,26 +26,26 @@ validateHost :: PuppetTypeValidate validateHost = defaultValidate parameterset >=> parameterFunctions parameterfunctions -checkhostname :: String -> PuppetTypeValidate+checkhostname :: T.Text -> 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+ Just x -> Left $ T.unpack 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' :: T.Text -> RResource -> ResolvedValue -> Either String RResource+checkhostname' prm _ (ResolvedString "") = Left $ "Empty hostname for parameter " ++ T.unpack 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' prm _ x = Left $ "Parameter " ++ T.unpack 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'' :: T.Text -> RResource -> T.Text -> Either String RResource+checkhostname'' prm _ "" = Left $ "Empty hostname part in parameter " ++ T.unpack prm checkhostname'' prm res prt =- let (cur,nxt) = break (=='.') prt- nextfunc = if null nxt+ let (cur,nxt) = T.break (=='.') prt+ nextfunc = if T.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 checkhostname'' prm res (T.tail nxt)+ in if T.null cur || (T.head cur == '-') || not (T.all (\x -> isAlphaNum x || (x=='-')) cur)+ then Left $ "Invalid hostname part for parameter " ++ T.unpack prm else nextfunc
Puppet/NativeTypes/Mount.hs view
@@ -5,6 +5,7 @@ import Control.Monad.Error import qualified Data.Set as Set +nativeMount :: (PuppetTypeName, PuppetTypeMethods) nativeMount = ("mount", PuppetTypeMethods validateMount parameterset) parameterset = Set.fromList $ map fst parameterfunctions
+ Puppet/NativeTypes/Package.hs view
@@ -0,0 +1,107 @@+module Puppet.NativeTypes.Package (nativePackage) where++import Puppet.NativeTypes.Helpers+import Puppet.Interpreter.Types+import Control.Monad.Error+import qualified Data.Set as Set+import qualified Data.Map as Map+import qualified Data.Text as T++nativePackage :: (PuppetTypeName, PuppetTypeMethods)+nativePackage = ("package", PuppetTypeMethods validatePackage parameterset)++data PackagingFeatures = Holdable | InstallOptions | Installable | Purgeable | UninstallOptions | Uninstallable | Upgradeable | Versionable deriving (Show, Ord, Eq)++isFeatureSupported :: Map.Map T.Text (Set.Set PackagingFeatures)+isFeatureSupported = Map.fromList [ ("aix", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("appdmg", Set.fromList [Installable])+ , ("apple", Set.fromList [Installable])+ , ("apt", Set.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable])+ , ("aptitude", Set.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable])+ , ("aptrpm", Set.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable])+ , ("blastwave", Set.fromList [Installable, Uninstallable, Upgradeable])+ , ("dpkg", Set.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable])+ , ("fink", Set.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable])+ , ("freebsd", Set.fromList [Installable, Uninstallable])+ , ("gem", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("hpux", Set.fromList [Installable, Uninstallable])+ , ("macports", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("msi", Set.fromList [InstallOptions, Installable, UninstallOptions, Uninstallable])+ , ("nim", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("openbsd", Set.fromList [Installable, Uninstallable, Versionable])+ , ("pacman", Set.fromList [Installable, Uninstallable, Upgradeable])+ , ("pip", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("pkg", Set.fromList [Holdable, Installable, Uninstallable, Upgradeable, Versionable])+ , ("pkgdmg", Set.fromList [Installable])+ , ("pkgin", Set.fromList [Installable, Uninstallable])+ , ("pkgutil", Set.fromList [Installable, Uninstallable, Upgradeable])+ , ("portage", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("ports", Set.fromList [Installable, Uninstallable, Upgradeable])+ , ("portupgrade", Set.fromList [Installable, Uninstallable, Upgradeable])+ , ("rpm", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("rug", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("sun", Set.fromList [InstallOptions, Installable, Uninstallable, Upgradeable])+ , ("sunfreeware", Set.fromList [Installable, Uninstallable, Upgradeable])+ , ("up2date", Set.fromList [Installable, Uninstallable, Upgradeable])+ , ("urpmi", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("windows", Set.fromList [InstallOptions, Installable, UninstallOptions, Uninstallable])+ , ("yum", Set.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable])+ , ("zypper", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ ]++parameterset = Set.fromList $ map fst parameterfunctions+parameterfunctions =+ [("adminfile" , [string, fullyQualified])+ ,("allowcdrom" , [string, values ["true","false"]])+ ,("configfiles" , [string, values ["keep","replace"]])+ ,("ensure" , [defaultvalue "present", string, values ["present","absent","latest","held","purged","installed"]])+ ,("flavor" , [])+ ,("install_options" , [rarray])+ ,("name" , [nameval])+ ,("provider" , [defaultvalue "apt", string])+ ,("responsefile" , [string, fullyQualified])+ ,("source" , [string])+ ,("uninstall_options", [rarray])+ ]++getFeature :: RResource -> Either String (Set.Set PackagingFeatures, RResource)+getFeature res = case Map.lookup "provider" (rrparams res) of+ Just (ResolvedString x) -> case Map.lookup x isFeatureSupported of+ Just s -> Right (s,res)+ Nothing -> Left ("Do not know provider " ++ T.unpack x)+ _ -> Left "Can't happen at Puppet.NativeTypes.Package"++checkFeatures :: (Set.Set PackagingFeatures, RResource) -> Either String RResource+checkFeatures =+ checkAdminFile+ >=> checkEnsure+ >=> checkParam "install_options" InstallOptions+ >=> checkParam "uninstall_options" UninstallOptions+ >=> decap+ where+ checkFeature :: Set.Set PackagingFeatures -> RResource -> PackagingFeatures -> Either String (Set.Set PackagingFeatures, RResource)+ checkFeature s r f = if Set.member f s+ then Right (s, r)+ else Left ("Feature " ++ show f ++ " is required for the current configuration")+ checkParam :: T.Text -> PackagingFeatures -> (Set.Set PackagingFeatures, RResource) -> Either String (Set.Set PackagingFeatures, RResource)+ checkParam pn f (s,r) = if Map.member pn (rrparams r)+ then checkFeature s r f+ else Right (s,r)+ checkAdminFile :: (Set.Set PackagingFeatures, RResource) -> Either String (Set.Set PackagingFeatures, RResource)+ checkAdminFile = Right -- TODO, check that it only works for aix+ checkEnsure :: (Set.Set PackagingFeatures, RResource) -> Either String (Set.Set PackagingFeatures, RResource)+ checkEnsure (s, res) = case Map.lookup "ensure" (rrparams res) of+ Just (ResolvedString "latest") -> checkFeature s res Installable >> checkFeature s res Versionable+ Just (ResolvedString "purged") -> checkFeature s res Purgeable+ Just (ResolvedString "absent") -> checkFeature s res Uninstallable+ Just (ResolvedString "installed") -> checkFeature s res Installable+ Just (ResolvedString "present") -> checkFeature s res Installable+ Just (ResolvedString "held") -> checkFeature s res Installable >> checkFeature s res Holdable+ _ -> Right (s, res)+ decap :: (Set.Set PackagingFeatures, RResource) -> Either String RResource+ decap = Right . snd++validatePackage :: PuppetTypeValidate+validatePackage = defaultValidate parameterset >=> parameterFunctions parameterfunctions >=> getFeature >=> checkFeatures++
+ Puppet/NativeTypes/SshSecure.hs view
@@ -0,0 +1,37 @@+module Puppet.NativeTypes.SshSecure (nativeSshSecure) where++import Puppet.NativeTypes.Helpers+import Puppet.Interpreter.Types+import Control.Monad.Error+import qualified Data.Set as Set+import qualified Data.Map as Map++nativeSshSecure :: (PuppetTypeName, PuppetTypeMethods)+nativeSshSecure = ("ssh_authorized_key_secure", PuppetTypeMethods validateSshSecure parameterset)++-- Autorequires: If Puppet is managing the user or user 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 =+ [("type" , [string, defaultvalue "ssh-rsa", values ["rsa","dsa","ssh-rsa","ssh-dss"]])+ ,("key" , [string])+ ,("user" , [string])+ ,("ensure" , [defaultvalue "present", string, values ["present","absent","role"]])+ ,("target" , [string])+ ,("options" , [rarray, strings])+ ]++userOrTarget :: PuppetTypeValidate+userOrTarget res = case (Map.lookup "user" (rrparams res), Map.lookup "target" (rrparams res)) of+ (Nothing, Nothing) -> Left "Parameters user or target are mandatory"+ _ -> Right res+++keyIfPresent :: PuppetTypeValidate+keyIfPresent res = case (Map.lookup "key" (rrparams res), Map.lookup "ensure" (rrparams res)) of+ (Just _, Just "present") -> Right res+ (_, Just "absent") -> Right res+ _ -> Left "Parameter key is mandatory when the resource is present"++validateSshSecure :: PuppetTypeValidate+validateSshSecure = defaultValidate parameterset >=> parameterFunctions parameterfunctions >=> userOrTarget >=> keyIfPresent+
+ Puppet/NativeTypes/User.hs view
@@ -0,0 +1,49 @@+module Puppet.NativeTypes.User (nativeUser) where++import Puppet.NativeTypes.Helpers+import Puppet.Interpreter.Types+import Control.Monad.Error+import qualified Data.Set as Set++nativeUser :: (PuppetTypeName, PuppetTypeMethods)+nativeUser = ("user", PuppetTypeMethods validateUser parameterset)++-- Autorequires: If Puppet is managing the user or user 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" , [rarray,strings])+ ,("auth_membership" , [defaultvalue "true"])+ ,("auths" , [rarray,strings])+ ,("comment" , [string])+ ,("ensure" , [defaultvalue "present", string, values ["present","absent","role"]])+ ,("expiry" , [string])+ ,("gid" , [string])+ ,("groups" , [rarray,strings])+ ,("home" , [string, fullyQualified, noTrailingSlash])+ ,("ia_load_module" , [string])+ ,("iterations" , [integer])+ ,("key_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]])+ ,("keys" , [])+ ,("managehome" , [string, defaultvalue "false", values ["true","false"]])+ ,("membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]])+ ,("name" , [nameval])+ ,("password" , [string])+ ,("password_max_age" , [integer])+ ,("password_min_age" , [integer])+ ,("profile_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]])+ ,("profiles" , [rarray,strings])+ ,("project" , [string])+ ,("provider" , [string, values ["aix","directoryservice","hpuxuseradd","useradd","ldap","pw","user_role_add","window_adsi"]])+ ,("role_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]])+ ,("roles" , [rarray,strings])+ ,("salt" , [string])+ ,("shell" , [string, fullyQualified, noTrailingSlash])+ ,("system" , [string, defaultvalue "false", values ["true","false"]])+ ,("uid" , [integer])+ ]++validateUser :: PuppetTypeValidate+validateUser = defaultValidate parameterset >=> parameterFunctions parameterfunctions+
Puppet/NativeTypes/ZoneRecord.hs view
@@ -6,14 +6,16 @@ import qualified Data.Map as Map import qualified Data.Set as Set +nativeZoneRecord :: (PuppetTypeName, PuppetTypeMethods) 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 = +parameterfunctions = [("name" , [nameval]) ,("owner" , [string]) ,("dest" , [string])+ ,("ensure" , [defaultvalue "present", string, values ["present","absent"]]) ,("rtype" , [string, defaultvalue "A", values ["SOA", "A", "AAAA", "MX", "NS", "CNAME", "PTR", "SRV"]]) ,("rclass" , [defaultvalue "IN", string]) ,("ttl" , [defaultvalue "2d", string])
Puppet/Plugins.hs view
@@ -20,19 +20,21 @@ * This currently only works for functions that must return a value. They will have no access to the manifests data. -}-module Puppet.Plugins (initLua, puppetFunc, closeLua, getFiles, getBasename) where+module Puppet.Plugins (initLua, puppetFunc, closeLua, getFiles) where import Prelude hiding (catch) import qualified Scripting.Lua as Lua import Scripting.LuaUtils()-import System.Directory import Control.Exception-import Data.String.Utils (endswith) import qualified Data.Map as Map import Control.Monad.IO.Class+import System.IO+import qualified Data.Text as T+import qualified Data.Text.IO as T import Puppet.Interpreter.Types import Puppet.Printers+import Puppet.Utils instance Lua.StackValue ResolvedValue where@@ -44,7 +46,7 @@ push l (ResolvedRReference rr _) = Lua.push l rr push l (ResolvedArray arr) = Lua.push l arr push l (ResolvedHash h) = Lua.push l (Map.fromList h)- push l (ResolvedUndefined) = Lua.push l "undefined"+ push l (ResolvedUndefined) = Lua.push l ("undefined" :: T.Text) peek l n = do t <- Lua.ltype l n@@ -69,47 +71,43 @@ valuetype _ = Lua.TUSERDATA -getDirContents :: FilePath -> IO [FilePath]-getDirContents x = fmap (filter (not . all (=='.'))) (getDirectoryContents x)+getDirContents :: T.Text -> IO [T.Text]+getDirContents x = fmap (filter (not . T.all (=='.'))) (getDirectoryContents x) -- find files in subdirectories-checkForSubFiles :: String -> String -> IO [String]+checkForSubFiles :: T.Text -> T.Text -> IO [T.Text] checkForSubFiles extension dir = do content <- catch (fmap Right (getDirContents dir)) (\e -> return $ Left (e :: IOException)) case content of Right o -> do- return ((map (\x -> dir ++ "/" ++ x) . filter (endswith extension)) o )+ return ((map (\x -> dir <> "/" <> x) . filter (T.isSuffixOf extension)) o ) Left _ -> return [] -- Find files in the module directory that are in a module subdirectory and -- finish with a specific extension-getFiles :: String -> String -> String -> IO [String]+getFiles :: T.Text -> T.Text -> T.Text -> IO [T.Text] getFiles moduledir subdir extension =- getDirContents moduledir- >>= mapM ( (checkForSubFiles extension) . (\x -> moduledir ++ "/" ++ x ++ "/" ++ subdir))+ getDirContents moduledir+ >>= mapM ( (checkForSubFiles extension) . (\x -> moduledir <> "/" <> x <> "/" <> subdir)) >>= return . concat -getLuaFiles :: String -> IO [String]-getLuaFiles moduledir = getFiles moduledir "lib/puppet/parser/functions" ".lua"---- retrieves the base name of a file (very slow and naïve implementation).-getBasename :: String -> String-getBasename fullname =- let lastpart = reverse $ fst $ break (=='/') $ reverse fullname- in fst $ break (=='.') lastpart+getLuaFiles :: T.Text -> IO [T.Text]+getLuaFiles moduledir = getFiles moduledir "lib/puppet/parser/luafunctions" ".lua" -loadLuaFile :: Lua.LuaState -> String -> IO [String]+loadLuaFile :: Lua.LuaState -> T.Text -> IO [T.Text] loadLuaFile l file = do- r <- Lua.loadfile l file+ r <- Lua.loadfile l (T.unpack file) case r of- 0 -> Lua.call l 0 0 >> return [getBasename file]- _ -> return []+ 0 -> Lua.call l 0 0 >> return [takeBaseName file]+ _ -> do+ T.hPutStrLn stderr ("Could not load file " <> file)+ return [] {-| Runs a puppet function in the 'CatalogMonad' monad. It takes a state, function name and list of arguments. It returns a valid Puppet value. -}-puppetFunc :: Lua.LuaState -> String -> [ResolvedValue] -> CatalogMonad ResolvedValue+puppetFunc :: Lua.LuaState -> T.Text -> [ResolvedValue] -> CatalogMonad ResolvedValue puppetFunc l fn args = do- content <- liftIO $ catch (fmap Right (Lua.callfunc l fn args)) (\e -> return $ Left $ show (e :: SomeException))+ content <- liftIO $ catch (fmap Right (Lua.callfunc l (T.unpack fn) args)) (\e -> return $ Left $ tshow (e :: SomeException)) case content of Right x -> return x Left y -> throwPosError y@@ -117,7 +115,7 @@ -- | Initializes the Lua state. The argument is the modules directory. Each -- subdirectory will be traversed for functions. -- The default location is @\/lib\/puppet\/parser\/functions@.-initLua :: String -> IO (Lua.LuaState, [String])+initLua :: T.Text -> IO (Lua.LuaState, [T.Text]) initLua moduledir = do funcfiles <- getLuaFiles moduledir l <- Lua.newstate
Puppet/Printers.hs view
@@ -5,61 +5,66 @@ , showValue , showRRef , capitalizeResType+ , showScope ) where import Puppet.Interpreter.Types import Puppet.DSL.Types import qualified Data.Map as Map-import Data.List+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Puppet.Utils+import Data.List (groupBy,sort) -showRes (CResource _ rname rtype params virtuality _) = putStrLn $ rtype ++ " " ++ show rname ++ " " ++ show params ++ " " ++ show virtuality-showRRes (RResource _ rname rtype params relations _) = putStrLn $ rtype ++ " " ++ show rname ++ " " ++ show params ++ " " ++ show relations+showRes (CResource _ rname rtype params virtuality _ _) = T.putStrLn $ rtype <> " " <> tshow rname <> " " <> tshow params <> " " <> tshow virtuality+showRRes (RResource _ rname rtype params relations _ _) = T.putStrLn $ rtype <> " " <> tshow rname <> " " <> tshow params <> " " <> tshow relations -showFCatalog :: FinalCatalog -> String+showFCatalog :: FinalCatalog -> T.Text showFCatalog rmap = let rawlist = groupBy (\((rtype1,_), _) ((rtype2,_), _) -> rtype1 == rtype2) (sort $ Map.toList rmap) rlist = map (map snd) rawlist- out = concatMap showuniqueres rlist+ out = T.concat$ map showuniqueres rlist in out -- helpers -commasep :: [String] -> String-commasep = intercalate ", "-commaretsep :: [String] -> String-commaretsep = intercalate ",\n"+commasep :: [T.Text] -> T.Text+commasep = T.intercalate ", "+commaretsep :: [T.Text] -> T.Text+commaretsep = T.intercalate ",\n" -showRRef :: ResIdentifier -> String-showRRef (rt, rn) = capitalizeResType rt ++ "[" ++ rn ++ "]"+showRRef :: ResIdentifier -> T.Text+showRRef (rt, rn) = capitalizeResType rt <> "[" <> rn <> "]" -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 :: ResolvedValue -> T.Text+showValue (ResolvedString x) = tshow x+showValue (ResolvedInt x) = tshow x+showValue (ResolvedDouble x) = tshow x+showValue (ResolvedBool True) = "True"+showValue (ResolvedBool False) = "False" showValue (ResolvedRReference rt rn) = showRRef (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 (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"+showuniqueres :: [RResource] -> T.Text+showuniqueres res = mrtype <> " {\n" <> T.concat (map showrres res) <> "}\n" where- showrres (RResource _ rname _ params rels mpos) =+ showrres (RResource _ rname _ params rels scopes mpos) = let relslist = map asparams rels- groupedrels = Map.fromListWith (++) relslist :: Map.Map String [ResolvedValue]+ groupedrels = Map.fromListWith (<>) relslist :: Map.Map T.Text [ResolvedValue] maybeArray (s,[a]) = (s,a) maybeArray (s, x ) = (s,ResolvedArray x)- paramlist = (Map.toList $ Map.delete "title" params) ++ map maybeArray (Map.toList groupedrels) :: [(String, ResolvedValue)]- maxlen = maximum (map (length . fst) paramlist) :: Int- in " " ++ show rname ++ ":" ++ " #" ++ show mpos ++ "\n"- ++ commaretsep (map (showparams maxlen) paramlist) ++ ";\n"- showparams mxl (name, val) = " " ++ name ++ replicate (mxl - length name) ' ' ++ " => " ++ showValue val+ paramlist = (Map.toList $ Map.delete "title" params) <> map maybeArray (Map.toList groupedrels) :: [(T.Text, ResolvedValue)]+ maxlen = maximum (map (T.length . fst) paramlist) :: Int+ in " " <> tshow rname <> ":" <> " #" <> tshow mpos <> " " <> showScope scopes <> "\n"+ <> commaretsep (map (showparams maxlen) paramlist) <> ";\n"+ showparams mxl (name, val) = " " <> T.justifyLeft 15 ' ' name <> " => " <> showValue val asparams (RBefore, (dtype, dname)) = ("before", [ResolvedRReference dtype (ResolvedString dname)]) asparams (RNotify, (dtype, dname)) = ("notify", [ResolvedRReference dtype (ResolvedString dname)]) asparams (RSubscribe, (dtype, dname)) = ("subscribe", [ResolvedRReference dtype (ResolvedString dname)]) asparams (RRequire, (dtype, dname)) = ("require", [ResolvedRReference dtype (ResolvedString dname)]) mrtype = rrtype (head res)+
Puppet/Stats.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-| A quickly done module that exports utility functions used to collect various statistics. All statistics are stored in a MVar holding a Map. -}@@ -8,10 +7,11 @@ import Control.Monad import Control.Concurrent.MVar import qualified Data.Map as Map+import qualified Data.Text as T data StatsPoint = StatsPoint !Int !Double !Double !Double deriving(Show)-type StatsTable = Map.Map String StatsPoint+type StatsTable = Map.Map T.Text StatsPoint type MStats = MVar StatsTable @@ -21,7 +21,7 @@ newStats :: IO MStats newStats = newMVar Map.empty -measure :: MStats -> String -> IO a -> IO a+measure :: MStats -> T.Text -> IO a -> IO a measure mtable statsname action = do (tm, out) <- time action !stats <- takeMVar mtable :: IO StatsTable@@ -39,7 +39,7 @@ putMVar mtable nstats return out -measure_ :: MStats -> String -> IO a -> IO ()+measure_ :: MStats -> T.Text -> IO a -> IO () measure_ mtable statsname act = void ( measure mtable statsname act ) getTime :: IO Double
Puppet/Testing.hs view
@@ -1,74 +1,129 @@-module Puppet.Testing (testCatalog, Test, testFileSources) where+module Puppet.Testing+ ( testCatalog+ , Test(..)+ , TestsState(..)+ , testFileSources+ , TestResult+ , TestMonad+ , testingDaemon+ , module Puppet.Interpreter.Types+ , getFileContent+ , getResource+ , fileContent+ , isEnsure+ , isPresent+ , isAbsent+ , checkResource+ , checkResources+ , egrep+ , sha1sum+ , runTests+ , sequenceCheck+ , sequenceCheck_+ , getParameter+ , getParameterM+ , equalOrAbsentParameter+ , equalParameter+ , equalParameters+ , (.>)+ , toByteString+ , runFullTests+ ) where import qualified Data.Map as Map-import Puppet.Interpreter.Types-import Data.List import Data.Maybe-import Data.List.Utils import Data.Either import Control.Monad.Error+import Control.Monad.State.Strict import System.Posix.Files+import qualified System.Log.Logger as LOG+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Text.Regex.PCRE.ByteString+import qualified Data.ByteString as BS+import qualified Data.Set as Set -type TestResult = IO (Either String ())+import Puppet.Interpreter.Types+import Puppet.Interpreter.Functions+import Puppet.Init+import Puppet.Daemon+import PuppetDB.TestDB+import PuppetDB.Rest+import Puppet.Utils+import Puppet.Printers +data TestsState = TestsState { getCoverage :: Set.Set ResIdentifier+ }+ deriving (Show)++newState :: TestsState+newState = TestsState Set.empty++type TestResult = StateT TestsState IO (Either String ())++type TestMonad = ErrorT String (StateT TestsState IO)+ --StateT TestsState (ErrorT String IO)+ data TestR- = TestGroupR String [TestR]- | SingleTestR String (Either String ())+ = TestGroupR T.Text [TestR]+ | SingleTestR T.Text (Either String ()) deriving (Show) data Test- = TestGroup String [Test]- | TestFirstOk String [Test]- | SingleTest String (FinalCatalog -> TestResult)+ = TestGroup T.Text [Test]+ | TestFirstOk T.Text [Test]+ | SingleTest T.Text (FinalCatalog -> TestResult) failedTests :: TestR -> Maybe TestR-failedTests (TestGroupR d tests) = case catMaybes (map failedTests tests) of+failedTests (TestGroupR d tests) = case mapMaybe failedTests tests of [] -> Nothing x -> Just (TestGroupR d x) failedTests t@(SingleTestR _ (Left _)) = Just t failedTests _ = Nothing -showRes :: TestR -> String-showRes = showRes' 0+showResT :: TestR -> T.Text+showResT = showRes' 0 where- showRes' :: Int -> TestR -> String- showRes' dec (TestGroupR desc tsts) = replicate dec ' ' ++ desc ++ "\n" ++ unlines (map (showRes' (dec + 1)) tsts)- showRes' dec (SingleTestR desc (Right ())) = replicate dec ' ' ++ desc ++ " OK"- showRes' dec (SingleTestR desc (Left err)) = replicate dec ' ' ++ desc ++ " FAIL: " ++ err+ showRes' :: Int -> TestR -> T.Text+ showRes' dec (TestGroupR desc tsts) = T.replicate dec " " <> desc <> "\n" <> T.unlines (map (showRes' (dec + 1)) tsts)+ showRes' dec (SingleTestR desc (Right ())) = T.replicate dec " " <> desc <> " OK"+ showRes' dec (SingleTestR desc (Left err)) = T.replicate dec " " <> desc <> " FAIL: " <> T.pack err -testFileSources :: String -> FinalCatalog -> Test+-- Converts a source string to a directory on dist+sourceToPath :: FilePath -> T.Text -> TestMonad (Maybe FilePath)+sourceToPath puppetdir src = do+ stringdir <- case T.stripPrefix "puppet:///" src of+ Just r -> return r+ Nothing -> throwError "The source does not start with puppet:///"+ case T.splitOn "/" stringdir of+ ("modules":modulename:rest) -> return $ Just $ puppetdir <> "/modules/" <> T.unpack modulename <> "/files/" <> T.unpack (T.intercalate "/" rest)+ ("files":rest) -> return $ Just $ puppetdir <> "/files/" <> T.unpack (T.intercalate "/" rest)+ ("private":_) -> return Nothing+ _ -> throwError ("Invalid file source " ++ T.unpack src)++testFileSources :: T.Text -> FinalCatalog -> Test testFileSources puppetdir cat = let fileresources = Map.elems $ Map.filterWithKey (\k _ -> fst k == "file") cat- filesources = catMaybes $ map (Map.lookup "source" . rrparams) fileresources- findPlace :: String -> Maybe String- findPlace stringdir =- case split "/" stringdir of- ("private":_) -> Just puppetdir -- not handled- ("modules":modulename:rest) -> Just $ puppetdir ++ "/modules/" ++ modulename ++ "/files/" ++ intercalate "/" rest- ("files":rest) -> Just $ puppetdir ++ "/files/" ++ intercalate "/" rest- _ -> Nothing- checkSrcExists :: String -> FinalCatalog -> TestResult+ filesources = mapMaybe (Map.lookup "source" . rrparams) fileresources+ checkSrcExists :: T.Text -> FinalCatalog -> TestResult checkSrcExists src _ = runErrorT $ do- let protostring = "puppet:///"- unless (startswith protostring src) (throwError "Does not start with puppet:///")- let stringdir = drop (length protostring) src- place = findPlace stringdir+ place <- sourceToPath (T.unpack puppetdir) src case place of- Just dir -> liftIO (fileExist dir) >>= (`unless` (throwError $ "Searched in " ++ dir))- Nothing -> throwError ("Unknown path: " ++ stringdir)+ Just p -> liftIO (fileExist p) >>= (`unless` (throwError $ "Searched in " ++ p))+ Nothing -> return () genFileTest :: ResolvedValue -> Test- genFileTest (ResolvedString src) = SingleTest (src ++ " exists") (checkSrcExists src)+ genFileTest (ResolvedString src) = SingleTest (src <> " exists") (checkSrcExists src) genFileTest (ResolvedArray arr) = TestFirstOk "First exists" (map genFileTest arr)- genFileTest x = SingleTest ("Valid source") (\_ -> return $ Left ("Not a valid data type: " ++ show x))- in (TestGroup "check that all files are defined" (map genFileTest filesources))+ genFileTest x = SingleTest "Valid source" (\_ -> return $ Left ("Not a valid data type: " ++ show x))+ in TestGroup "check that all files are defined" (map genFileTest filesources) unsingle :: TestR -> Either String ()-unsingle (SingleTestR desc (Left err)) = Left (desc ++ " failed: " ++ err)+unsingle (SingleTestR desc (Left err)) = Left (T.unpack desc ++ " failed: " ++ err) unsingle (SingleTestR _ _ ) = Right () unsingle x = Left ("Bad type for unsingle " ++ show x) -runTest :: FinalCatalog -> Test -> IO TestR-runTest cat (SingleTest desc test) = fmap (\x -> SingleTestR desc x) (test cat)+runTest :: FinalCatalog -> Test -> StateT TestsState IO TestR+runTest cat (SingleTest desc test) = fmap (SingleTestR desc) (test cat) runTest cat (TestGroup desc tests) = fmap (TestGroupR desc) (mapM (runTest cat) tests) runTest cat (TestFirstOk desc tests) = do allRes <- mapM (fmap unsingle . runTest cat) tests@@ -76,12 +131,161 @@ [] -> return $ SingleTestR desc (Right ()) x -> return $ SingleTestR desc (Left (show x)) -runTests :: Test -> FinalCatalog -> IO (Either String ())+runTests :: Test -> FinalCatalog -> StateT TestsState IO (Either String ()) runTests tsts cat = do tr <- fmap failedTests (runTest cat tsts) case tr of Nothing -> return $ Right ()- Just fl -> return $ Left $ showRes fl+ Just fl -> return $ Left $ T.unpack $ showResT fl -testCatalog :: String -> FinalCatalog -> [Test] -> IO (Either String ())-testCatalog puppetdir catalog stests = runTests (TestGroup "All Tests" ( testFileSources puppetdir catalog : stests )) catalog+testCatalog :: T.Text -> FinalCatalog -> [Test] -> IO (Either String (), TestsState)+testCatalog puppetdir catalog stests = runStateT (runTests (TestGroup "All Tests" ( testFileSources puppetdir catalog : stests )) catalog) newState++-- | Initializes a daemon made for running tests, using the specific test+-- puppetDB+testingDaemon :: Maybe T.Text -- ^ Might contain the URL of the actual PuppetDB, used for getting facts.+ -> T.Text -- ^ Path to the manifests+ -> (T.Text -> IO (Map.Map T.Text ResolvedValue)) -- ^ The facter function+ -> IO (T.Text -> IO (Either String (FinalCatalog, EdgeMap, FinalCatalog)))+testingDaemon purl puppetdir allFacts = do+ LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel LOG.WARNING)+ prefs <- genPrefs puppetdir+ let realPuppetDB = case purl of+ Nothing -> puppetDBquery prefs { compilepoolsize = 8, parsepoolsize = 3, erbpoolsize = 4 }+ Just url -> pdbRequest url+ (queryPDB, updatePDB) <- initTestDBFunctions realPuppetDB+ let pdbr = prefs { puppetDBquery = queryPDB }+ (queryfunc, _, _, _) <- initDaemon pdbr+ return (\nodename -> do+ o <- allFacts nodename >>= queryfunc nodename+ case o of+ Right x -> updatePDB nodename x >> return (Right x)+ x -> return x+ )++-- | Retrieves content on disk+getSource :: FilePath -> T.Text -> TestMonad BS.ByteString+getSource puppetdir source = do+ path <- sourceToPath puppetdir source+ case path of+ Just p -> liftIO (BS.readFile p)+ Nothing -> throwError "Could not test this file !"++getFileContent :: FilePath -> RResource -> TestMonad BS.ByteString+getFileContent puppetdir r =+ let rname = T.unpack (showRRef (rrtype r, rrname r))+ in case Map.lookup "content" (rrparams r) of+ Just (ResolvedString s) -> return (T.encodeUtf8 s)+ Just x -> throwError ("Content of " <> rname <> " is not a string, but: " <> show x)+ Nothing -> case Map.lookup "source" (rrparams r) of+ Just (ResolvedString s) -> getSource puppetdir s+ Just x -> throwError ("Source of " <> rname <> " is not a string, but: " <> show x)+ Nothing -> throwError (rname <> " has no content or source, can't check for it")++getResource :: T.Text -> T.Text -> FinalCatalog -> TestMonad RResource+getResource restype resname cat = case Map.lookup (restype, resname) cat of+ Just r -> do+ modify (\s -> s { getCoverage = Set.insert (restype, resname) (getCoverage s) })+ return r+ Nothing -> throwError ("Could not find resource " <> T.unpack (showRRef (restype, resname)))++fileContent :: FilePath -> Maybe T.Text -> T.Text -> (BS.ByteString -> TestMonad ()) -> Test+fileContent puppetdir msg filename contenttest = SingleTest testmsg (runErrorT . chain)+ where testmsg = fromMaybe ("Testing file " <> filename) msg+ chain = getResource "file" filename >=> getFileContent puppetdir >=> contenttest++checkResources :: Maybe T.Text -> T.Text -> [T.Text] -> (RResource -> TestMonad ()) -> Test+checkResources msg restype resnames test = TestGroup testmsg (map (\n -> checkResource msg restype n test) resnames)+ where testmsg = fromMaybe ("Testing resources " <> resgroup) msg+ resgroup = T.intercalate ", " (map (\n -> showRRef(restype, n)) resnames)++checkResource :: Maybe T.Text -> T.Text -> T.Text -> (RResource -> TestMonad ()) -> Test+checkResource msg restype resname test = SingleTest testmsg (runErrorT . chain)+ where testmsg = fromMaybe ("Testing resource " <> showRRef (restype, resname)) msg+ chain = getResource restype resname >=> test++isEnsure :: T.Text -> RResource -> TestMonad ()+isEnsure t r =+ let rname = T.unpack $ showRRef (rrtype r, rrname r)+ in case Map.lookup "ensure" (rrparams r) of+ Just (ResolvedString x) -> unless (x == t) $ throwError ("Resource " <> rname <> " ensure is not " <> T.unpack t <> ", it is " <> T.unpack x)+ Just x -> throwError ("Resource " <> rname <> " ensure is not " <> T.unpack t <> ", it is " <> show x)+ Nothing -> throwError ("Resource " <> rname <> " is not ensured, can't be " <> T.unpack t)++isPresent :: RResource -> TestMonad ()+isPresent = isEnsure "present"++isAbsent :: RResource -> TestMonad ()+isAbsent = isEnsure "absent"++-- | Runs a multiline regexp+egrep :: T.Text -> BS.ByteString -> TestMonad ()+egrep regexp text = do+ reg <- liftIO $ compile compMultiline execBlank (T.encodeUtf8 regexp)+ rreg <- case reg of+ Left rr -> throwError (show rr)+ Right r -> return r+ x <- liftIO $ execute rreg text+ case x of+ Left rr -> throwError (show rr)+ Right (Just _) -> return ()+ Right _ -> throwError "Regexp did not match"++sha1sum :: T.Text -> BS.ByteString -> TestMonad ()+sha1sum cs text | puppetSHA1 (T.decodeUtf8 text) == cs = return ()+ | otherwise = throwError "Checksum mismatch"++-- | Let you sequence several checks with the same input. Useful for the+-- | checkResource function+sequenceCheck :: [a -> TestMonad b] -> a -> TestMonad [b]+sequenceCheck funcs input = mapM (\f -> f input) funcs++-- | Same thing but without output, even more useful for the checkResource+-- | function+sequenceCheck_ :: [a -> TestMonad b] -> a -> TestMonad ()+sequenceCheck_ funcs input = void $ mapM (\f -> f input) funcs++-- | Gets a resource parameter value as a (Maybe Text)+getParameterM :: T.Text -> RResource -> TestMonad (Maybe ResolvedValue)+getParameterM param r = return (Map.lookup param (rrparams r))++getParameter :: T.Text -> RResource -> TestMonad ResolvedValue+getParameter param r = case Map.lookup param (rrparams r) of+ Just x -> return x+ Nothing -> throwError ("Parameter " <> T.unpack param <> " is not defined")++equalParameter :: T.Text -> ResolvedValue -> RResource -> TestMonad ()+equalParameter paramname checkvalue r = do+ realvalue <- getParameter paramname r+ unless (realvalue == checkvalue) (throwError ("Values for parameter " ++ T.unpack paramname ++ " don't match. Expected: " ++ show checkvalue ++ ", had " ++ show realvalue))++equalOrAbsentParameter :: T.Text -> ResolvedValue -> RResource -> TestMonad ()+equalOrAbsentParameter paramname checkvalue r = do+ mrealvalue <- getParameterM paramname r+ case mrealvalue of+ Just _ -> equalParameter paramname checkvalue r+ Nothing -> return ()++equalParameters :: [(T.Text, ResolvedValue)] -> RResource -> TestMonad ()+equalParameters checks = sequenceCheck_ (map (uncurry equalParameter) checks)++(.>) :: T.Text -> ResolvedValue -> (T.Text, ResolvedValue)+name .> value = (name ,value)++toByteString :: ResolvedValue -> TestMonad BS.ByteString+toByteString (ResolvedString x) = return $ T.encodeUtf8 x+toByteString x = throwError ("Could not convert " ++ show x ++ " to a bytestring")++-- | Run tests on several hosts at once+runFullTests :: [(T.Text -> Bool, Test)] -> [(T.Text, FinalCatalog)] -> IO [(T.Text, Either String (), TestsState)]+runFullTests testlist = mapM runFullTests'+ where+ runFullTests' :: (T.Text, FinalCatalog) -> IO (T.Text, Either String (), TestsState)+ runFullTests' (hostname, catalog) = do+ let tests = TestGroup hostname $ map snd $ filter (\x -> (fst x) hostname) testlist+ (r,s) <- runStateT (runTests tests catalog) newState+ putStrLn (T.unpack hostname ++ " resource coverage " ++ show (Set.size (getCoverage s)) ++ "/" ++ show (Map.size catalog))+ case r of+ Left rr -> putStrLn rr+ Right () -> return ()+ return (hostname, r,s)
+ Puppet/Utils.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++module Puppet.Utils+ ( mGetExecutablePath+ , readFile'+ , readSymbolicLink+ , tshow+ , dq+ , readDecimal+ , textElem+ , module Data.Monoid+ , getDirectoryContents+ , takeBaseName+ , takeDirectory+ , regexpSplit+ , regexpMatched+ , regexpUnmatched+ , regexpAll+ , RegexpSplit(..)+ ) where++-- copy pasted from base 4.6.0.0+import Prelude hiding (catch)+import Foreign.C+import Foreign.Marshal.Array+import System.Posix.Internals+import System.IO+import Control.Exception+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Read as T+import qualified Data.ByteString as BS+import Data.Monoid+import System.Posix.Directory.ByteString+import Text.Regex.PCRE.ByteString+import Control.Monad.Error++foreign import ccall unsafe "readlink" c_readlink :: CString -> CString -> CSize -> IO CInt++readSymbolicLink :: FilePath -> IO FilePath+readSymbolicLink file =+ allocaArray0 4096 $ \buf -> do+ withFilePath file $ \s -> do+ len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $+ c_readlink s buf 4096+ peekFilePathLen (buf,fromIntegral len)++-- | Returns the absolute pathname of the current executable.+--+-- Note that for scripts and interactive sessions, this is the path to+-- the interpreter (e.g. ghci.)+-- (Stolen from base 4.6.0)+mGetExecutablePath :: IO FilePath+mGetExecutablePath = readSymbolicLink $ "/proc/self/exe"++-- | Strict readFile+readFile' f = do+ h <- openFile f ReadMode+ s <- hGetContents h+ evaluate (length s)+ return s++tshow :: Show a => a -> T.Text+tshow = T.pack . show++dq :: T.Text -> T.Text+dq x = T.cons '"' (T.snoc x '"')++readDecimal :: (Integral a) => T.Text -> Either String a+readDecimal t = case T.decimal t of+ Right (x, "") -> Right x+ Right _ -> Left "Trailing characters when reading an integer"+ Left r -> Left r++textElem :: Char -> T.Text -> Bool+textElem c t = T.any (==c) t++getDirectoryContents :: T.Text -> IO [T.Text]+getDirectoryContents fpath = do+ h <- openDirStream (T.encodeUtf8 fpath)+ let readHandle = do+ fp <- readDirStream h+ if BS.null fp+ then return []+ else fmap (\e -> T.decodeUtf8 fp : e) readHandle+ out <- readHandle+ closeDirStream h+ return out++-- | See System.FilePath.Posix+takeBaseName :: T.Text -> T.Text+takeBaseName fullname =+ let afterLastSlash = last $ T.splitOn "/" fullname+ splitExtension = init $ T.splitOn "." afterLastSlash+ in T.intercalate "." splitExtension++-- | See System.FilePath.Posix+takeDirectory :: T.Text -> T.Text+takeDirectory "" = "."+takeDirectory "/" = "/"+takeDirectory x =+ let res = T.dropWhileEnd (== '/') file+ file = dropFileName x+ in if T.null res && (not (T.null file))+ then file+ else res++-- | Drop the filename.+--+-- > dropFileName x == fst (splitFileName x)+--+-- (See System.FilePath.Posix)+dropFileName :: T.Text -> T.Text+dropFileName = fst . splitFileName+++-- | Split a filename into directory and file. 'combine' is the inverse.+--+-- > Valid x => uncurry (</>) (splitFileName x) == x || fst (splitFileName x) == "./"+-- > Valid x => isValid (fst (splitFileName x))+-- > splitFileName "file/bob.txt" == ("file/", "bob.txt")+-- > splitFileName "file/" == ("file/", "")+-- > splitFileName "bob" == ("./", "bob")+-- > Posix: splitFileName "/" == ("/","")+-- > Windows: splitFileName "c:" == ("c:","")+--+-- (See System.FilePath.Posix)+splitFileName :: T.Text -> (T.Text, T.Text)+splitFileName x = (if T.null dir then "./" else dir, name)+ where+ (dir, name) = splitFileName_ x+ splitFileName_ y = (T.reverse b, T.reverse a)+ where+ (a,b) = T.break (=='/') $ T.reverse y++data RegexpSplit a = Matched a+ | Unmatched a+ deriving (Show, Eq, Ord)++instance Functor RegexpSplit where+ fmap f (Matched x) = Matched (f x)+ fmap f (Unmatched x) = Unmatched (f x)++regexpAll :: [RegexpSplit a] -> [a]+regexpAll = map unreg+ where+ unreg ( Matched x ) = x+ unreg ( Unmatched x ) = x++isMatched :: RegexpSplit a -> Bool+isMatched (Matched _) = True+isMatched _ = False++regexpMatched :: [RegexpSplit a] -> [a]+regexpMatched = regexpAll . filter isMatched++regexpUnmatched :: [RegexpSplit a] -> [a]+regexpUnmatched = regexpAll . filter (not . isMatched)++regexpSplit :: CompOption -> T.Text -> T.Text -> IO (Either String [RegexpSplit T.Text])+regexpSplit opt reg src = runErrorT $ do+ creg <- liftIO $ compile opt execBlank (T.encodeUtf8 reg)+ >>= \x -> case x of+ Right r -> return r+ Left rr -> error (show rr)+ fmap (map (fmap T.decodeUtf8)) $ getMatches opt creg (T.encodeUtf8 src)++getMatches :: CompOption -> Regex -> BS.ByteString -> ErrorT String IO [RegexpSplit BS.ByteString]+getMatches _ _ "" = return []+getMatches opt creg src = do+ x <- liftIO (regexec creg src)+ case x of+ Right Nothing -> return [Unmatched src]+ Right (Just (before,current,remaining,_)) -> do+ remain <- getMatches opt creg remaining+ if BS.null before+ then return (Matched current : remain)+ else return (Unmatched before : Matched current : remain)+ Left (rcode, rerror) -> throwError ("Regexp application error: " ++ rerror ++ "(" ++ show rcode ++ ")")
PuppetDB/Query.hs view
@@ -1,17 +1,19 @@ module PuppetDB.Query where import Puppet.DSL.Types-import Data.List (intercalate)+import qualified Data.Text as T+import Data.Monoid+import Puppet.Utils data Operator = OEqual | OOver | OUnder | OOverE | OUnderE | OAnd | OOr | ONot deriving (Show, Ord, Eq) -- [Field] Value-data Query = Query Operator [Query] | Term String | Terms [String]+data Query = Query Operator [Query] | Term T.Text | Terms [T.Text] deriving (Show, Ord, Eq) -- | Query used for realizing a resources, when its type and title is known.-queryRealize :: String -> String -> Query+queryRealize :: T.Text -> T.Text -> Query queryRealize rtype rtitle = Query OAnd [ Query OEqual [ Term "type", Term (capitalizeResType rtype) ] , Query OEqual [ Term "title", Term rtitle ]@@ -19,13 +21,13 @@ ] -- | Collects all resources of a given type-collectAll :: String -> Query+collectAll :: T.Text -> Query collectAll rtype = Query OAnd [ Query OEqual [ Term "type", Term (capitalizeResType rtype) ] , Query OEqual [ Term "exported", Term "true" ] ] -- | Collections based on tags.-collectTag :: String -> String -> Query+collectTag :: T.Text -> T.Text -> Query collectTag rtype tagval = Query OAnd [ Query OEqual [ Term "type", Term (capitalizeResType rtype) ] , Query OEqual [ Term "tag" , Term tagval ]@@ -33,17 +35,14 @@ ] -- | Used to emulate collections such as `Type<|| prmname == "prmval" ||>`-collectParam :: String -> String -> String -> Query+collectParam :: T.Text -> T.Text -> T.Text -> Query collectParam rtype prmname prmval = Query OAnd [ Query OEqual [ Term "type", Term (capitalizeResType rtype) ] , Query OEqual [ Terms ["parameter", "prmname"], Term prmval ] , Query OEqual [ Term "exported", Term "true" ] ] -dq :: String -> String-dq x = '"' : x ++ "\""--showOperator :: Operator -> String+showOperator :: Operator -> T.Text showOperator OEqual = dq "=" showOperator OOver = dq ">" showOperator OUnder = dq "<"@@ -53,7 +52,19 @@ showOperator OOr = dq "or" showOperator ONot = dq "not" -showQuery :: Query -> String-showQuery (Query op subqueries) = "[" ++ intercalate ", " (showOperator op : map showQuery subqueries) ++ "]"-showQuery (Term t) = show t-showQuery (Terms ts) = show ts+getOperator :: T.Text -> Maybe Operator+getOperator "=" = Just OEqual+getOperator ">" = Just OOver+getOperator "<" = Just OUnder+getOperator ">=" = Just OOverE+getOperator "<=" = Just OUnderE+getOperator "and" = Just OAnd+getOperator "or" = Just OOr+getOperator "not" = Just ONot+getOperator _ = Nothing++showQuery :: Query -> T.Text+showQuery (Query op subqueries) = "[" <> T.intercalate ", " (showOperator op : map showQuery subqueries) <> "]"+showQuery (Term t) = tshow t+showQuery (Terms ts) = tshow ts+
PuppetDB/Rest.hs view
@@ -1,63 +1,24 @@-{-# LANGUAGE OverloadedStrings #-}- module PuppetDB.Rest where -import qualified Puppet.DSL.Types as DT-import Puppet.Interpreter.Types import qualified PuppetDB.Query as PDB 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 import qualified Control.Exception as X import Control.Monad.Error-import Control.Applicative-import qualified Text.Parsec.Pos as TPP-import qualified Data.Map as Map--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--instance FromJSON CResource where- parseJSON (Object o) = do- utitle <- o .: "title"- params <- o .: "parameters"- sourcefile <- o .: "sourcefile"- sourceline <- o .: "sourceline"- certname <- o .: "certname"- let _ = params :: HM.HashMap String ResolvedValue- parameters = Map.fromList $ map (\(k,v) -> (Right k, Right v)) $ ("EXPORTEDSOURCE", ResolvedString certname) : HM.toList params :: Map.Map GeneralString GeneralValue- position = TPP.newPos (sourcefile ++ "(host: " ++ certname ++ ")") sourceline 1- CResource <$> pure 0- <*> pure (Right utitle)- <*> fmap (T.unpack . T.toLower) (o .: "type")- <*> pure parameters- <*> pure DT.Normal- <*> pure position- parseJSON _ = mzero+import Puppet.Utils+import qualified Data.Text as T+import qualified Data.Text.Encoding as T runRequest req = do- let doRequest = withManager (\manager -> fmap responseBody $ httpLbs req manager) :: IO L.ByteString+ let doRequest = withManager (fmap responseBody . httpLbs req) :: IO L.ByteString eHandler :: X.SomeException -> IO (Either String L.ByteString)- eHandler e = return $ Left $ show e ++ ", with queryString " ++ (BC.unpack $ queryString req)- mo <- liftIO ((fmap Right doRequest) `X.catch` eHandler)+ eHandler e = return $ Left $ show e ++ ", with queryString " ++ BC.unpack (queryString req)+ mo <- liftIO (fmap Right doRequest `X.catch` eHandler) case mo of Right o -> do let utf8 = IConv.convert "LATIN1" "UTF-8" o@@ -66,28 +27,16 @@ Nothing -> throwError "Json decoding has failed" Left err -> throwError err -isNotLocal :: String -> CResource -> Bool-isNotLocal fqdn cr = case Map.lookup (Right "EXPORTEDSOURCE") (crparams cr) of- Just (Right (ResolvedString x)) -> x /= fqdn- _ -> True--pdbResRequest :: String -> String -> PDB.Query -> IO (Either String [CResource])-pdbResRequest url fqdn qquery = do- res <- rawRequest url "resources" (PDB.showQuery qquery)- case res of- Left x -> return $ Left x- Right y -> return $ Right $ filter ( isNotLocal fqdn ) y--pdbRequest :: String -> String -> PDB.Query -> IO (Either String ResolvedValue)+pdbRequest :: (FromJSON a) => T.Text -> T.Text -> PDB.Query -> IO (Either String a) pdbRequest url querytype qquery = rawRequest url querytype (PDB.showQuery qquery) -rawRequest :: (FromJSON a) => String -> String -> String -> IO (Either String a)+rawRequest :: (FromJSON a) => T.Text -> T.Text -> T.Text -> IO (Either String a) rawRequest url querytype query = runErrorT $ do- unless (querytype `elem` ["resources", "nodes", "facts"]) (throwError $ "Invalid query type " ++ querytype)+ unless (querytype `elem` ["resources", "nodes", "facts"]) (throwError $ "Invalid query type " ++ T.unpack querytype) let q = case querytype of- "facts" -> '/' : query- _ -> "?" ++ (BC.unpack $ W.renderSimpleQuery False [("query", BC.pack query)])- fullurl = url ++ "/" ++ querytype ++ q+ "facts" -> T.cons '/' query+ _ -> "?" <> T.decodeUtf8 (W.renderSimpleQuery False [("query", T.encodeUtf8 query)])+ fullurl = T.unpack $ url <> "/v1/" <> querytype <> q initReq <- case (parseUrl fullurl :: Maybe (Request a)) of Just x -> return x Nothing -> throwError "Something failed when parsing the PuppetDB URL"
+ PuppetDB/TestDB.hs view
@@ -0,0 +1,76 @@+module PuppetDB.TestDB (initTestDBFunctions) where++import PuppetDB.Query+import Puppet.Interpreter.Types+import Puppet.DSL.Types hiding (Value)++import Data.Aeson+import qualified Data.Map as Map+import Control.Concurrent.MVar+import qualified Data.Text as T++type ExportedResources = Map.Map T.Text (FinalCatalog, EdgeMap, FinalCatalog)++initTestDBFunctions :: (T.Text -> Query -> IO (Either String Value)) -> IO (T.Text -> Query -> IO (Either String Value), T.Text -> (FinalCatalog, EdgeMap, FinalCatalog) -> IO ())+initTestDBFunctions defaultquery = do+ v <- newMVar Map.empty+ return (queryPDB v defaultquery, updatePDB v)++updatePDB :: MVar ExportedResources -> T.Text -> (FinalCatalog, EdgeMap, FinalCatalog) -> IO ()+updatePDB v node res = do+ ex <- takeMVar v+ let ex' = Map.insert node res ex+ putMVar v ex'++toBool :: T.Text -> Either String Bool+toBool "true" = Right True+toBool "false" = Right False+toBool x = Left ("Is not a boolean " ++ T.unpack x) ++evaluateQueryResource :: Query -> Bool -> T.Text -> ResIdentifier -> RResource -> Either String Bool+evaluateQueryResource (Query OAnd lst) e n rid rr = fmap and (mapM (\x -> evaluateQueryResource x e n rid rr) lst)+evaluateQueryResource (Query OOr lst) e n rid rr = fmap or (mapM (\x -> evaluateQueryResource x e n rid rr) lst)+evaluateQueryResource (Query OEqual [Terms ["node","active"], Term bool]) _ _ _ _ = toBool bool+evaluateQueryResource (Query OEqual [Terms ["node","name"], Term hname]) _ n _ _ = Right (n == hname)+evaluateQueryResource (Query OEqual [Term "type",Term ctype]) _ _ _ rr = Right (capitalizeResType (rrtype rr) == ctype)+evaluateQueryResource (Query OEqual [Term "exported",Term expo]) exported _ _ _ = toBool expo >>= \x -> return (x == exported)+evaluateQueryResource (Query OEqual [Term "tag",Term tag]) _ _ _ rr =+ let tags = Map.findWithDefault (ResolvedArray []) "tag" (rrparams rr)+ stringEqual y (ResolvedString x) = (x == y)+ stringEqual _ _ = False+ in case tags of+ ResolvedArray lst -> Right (any (stringEqual tag) lst)+ _ -> Right (stringEqual tag tags)+evaluateQueryResource (Query OEqual [Term "title", Term ttl]) _ _ _ rr = Right (rrname rr == ttl)+evaluateQueryResource (Query ONot [q]) e n rid rr = fmap not (evaluateQueryResource q e n rid rr)+evaluateQueryResource q _ _ _ _ = Left ("Not interpreted: " ++ show q)++queryPDB :: MVar ExportedResources -> (T.Text -> Query -> IO (Either String Value)) -> T.Text -> Query -> IO (Either String Value)+queryPDB v _ "resources" query = do+ ex <- readMVar v+ let isSelected = evaluateQueryResource query+ sortResources :: Either String ([(T.Text,ResIdentifier,RResource)], [(T.Text,ResIdentifier,RResource)])+ -> T.Text+ -> (FinalCatalog, EdgeMap, FinalCatalog)+ -> Either String ([(T.Text,ResIdentifier,RResource)], [(T.Text,ResIdentifier,RResource)])+ sortResources (Left rr) _ _ = Left rr+ sortResources (Right (curnormal, curexported)) nodename (fnormal, _, fexported) =+ let newnormal = Map.foldlWithKey' (sortResources' False nodename) (Right curnormal ) fnormal+ newexported = Map.foldlWithKey' (sortResources' True nodename) (Right curexported) fexported+ in case (newnormal, newexported) of+ (Left r1, _) -> Left r1+ (_, Left r2) -> Left r2+ (Right n, Right e) -> Right (n,e)+ sortResources' :: Bool -> T.Text -> Either String [(T.Text,ResIdentifier,RResource)] -> ResIdentifier -> RResource -> Either String [(T.Text,ResIdentifier,RResource)]+ sortResources' _ _ (Left rr) _ _ = Left rr+ sortResources' e nodename (Right curlist) resid rr = case isSelected e nodename resid rr of+ Right False -> Right curlist+ Right True -> Right ((nodename,resid,rr) : curlist)+ Left err -> Left err+ jsonize :: (T.Text,ResIdentifier,RResource) -> Value+ jsonize (h,_,r) = rr2json h r+ case Map.foldlWithKey' sortResources (Right ([], [])) ex of+ Right (n,e) -> return $ Right $ toJSON $ map jsonize ( n ++ e )+ Left rr -> return (Left rr)++queryPDB _ _ querytype query = error (show (querytype, query))
SafeProcess.hs view
@@ -10,9 +10,12 @@ import System.Posix.Signals import System.Process import System.Process.Internals-import qualified Data.ByteString.Lazy as BS+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.IO as TL -safeReadProcessTimeout :: String -> [String] -> BS.ByteString -> Int -> IO (Maybe (Either String BS.ByteString))+safeReadProcessTimeout :: String -> [String] -> TL.Text -> Int -> IO (Maybe (Either String T.Text)) safeReadProcessTimeout prog args input tout = timeout (tout*1000) $ safeReadProcess prog args input safeCreateProcess :: String -> [String] -> StdStream -> StdStream -> StdStream@@ -24,7 +27,7 @@ -> IO a safeCreateProcess prog args streamIn streamOut streamErr fun = bracket ( do- h <- createProcess (proc prog args) + h <- createProcess (proc prog args) { std_in = streamIn , std_out = streamOut , std_err = streamErr@@ -38,18 +41,18 @@ fun {-# NOINLINE safeCreateProcess #-} -safeReadProcess :: String -> [String] -> BS.ByteString -> IO (Either String BS.ByteString)+safeReadProcess :: String -> [String] -> TL.Text -> IO (Either String T.Text) safeReadProcess prog args str = safeCreateProcess prog args CreatePipe CreatePipe Inherit (\(Just inh, Just outh, _, ph) -> do hSetBinaryMode inh True hSetBinaryMode outh True- BS.hPut inh str+ TL.hPutStr inh str hClose inh -- fork a thread to consume output- output <- BS.hGetContents outh+ output <- T.hGetContents outh outMVar <- newEmptyMVar- forkIO $ evaluate (BS.length output) >> putMVar outMVar ()+ forkIO $ evaluate (T.length output) >> putMVar outMVar () -- wait on output takeMVar outMVar hClose outh
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.3.2+Version: 0.4.0 -- A short (one-line) description of the package. Synopsis: Tools to parse and evaluate the Puppet DSL.@@ -52,43 +52,47 @@ location: git://github.com/bartavelle/language-puppet.git Library- ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-unused-do-bind -funbox-strict-fields -O2 -fllvm+ ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-unused-do-bind -funbox-strict-fields -O2 -- 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, PuppetDB.Rest, PuppetDB.Query, Puppet.Plugins, Puppet.Testing,- Puppet.Stats, Puppet.JsonCatalog+ Puppet.Stats, Puppet.JsonCatalog, PuppetDB.TestDB -- 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>=0.10.2.0,cryptohash,base16-bytestring,regex-pcre-builtin,- iconv, text, unordered-containers, aeson, vector, http-types, http-conduit, attoparsec, failure, hslua, monad-loops, directory, luautils >= 0.1.1.0, transformers, time+ Build-depends: base >=3 && <5,parsec,containers,pretty,mtl,unix,hslogger,Glob,process,bytestring>=0.10.0.0,cryptohash,base16-bytestring,regex-pcre-builtin,+ iconv, text, unordered-containers, aeson, http-types, http-conduit, attoparsec, failure, hslua, vector, luautils >= 0.1.1.0, transformers, time,+ pcre-utils -- 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+ Puppet.NativeTypes.ZoneRecord, Puppet.NativeTypes.Cron, Puppet.NativeTypes.Exec, Puppet.NativeTypes.Group, Puppet.NativeTypes.Host, Puppet.NativeTypes.User+ Puppet.NativeTypes.Mount, Puppet.Utils, Puppet.NativeTypes.Package, Puppet.NativeTypes.SshSecure, Puppet.Interpreter.RubyRandom -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: -+ Extensions: OverloadedStrings, BangPatterns GHC-Prof-Options: -auto-all -caf-all Test-Suite test-lexer hs-source-dirs: test type: exitcode-stdio-1.0 ghc-options: -Wall+ extensions: OverloadedStrings build-depends: language-puppet,base,Glob,mtl main-is: lexer.hs Test-Suite test-expr hs-source-dirs: test type: exitcode-stdio-1.0 ghc-options: -Wall+ extensions: OverloadedStrings build-depends: language-puppet,base,parsec main-is: expr.hs Test-Suite test-interpreter hs-source-dirs: test type: exitcode-stdio-1.0 ghc-options: -Wall- build-depends: language-puppet,base,Glob,mtl,containers,parsec+ extensions: OverloadedStrings+ build-depends: language-puppet,base,Glob,mtl,containers,parsec,text main-is: interpreter.hs
ruby/calcerb.rb view
@@ -8,6 +8,9 @@ end def lookupvar(name)+ if name.start_with?("::")+ name = name[2..-1]+ end if has_variable?(name) @mvars[name] elsif has_variable?("::" + name)
test/expr.hs view
@@ -4,7 +4,7 @@ import Puppet.DSL.Types import Text.Parsec -testcases = +testcases = [ ("5 + 3 * 2", PlusOperation (Value $ Integer 5) (MultiplyOperation (Value $ Integer 3) (Value $ Integer 2)) ) , ("5+2 == 7", EqualOperation ( PlusOperation (Value $ Integer 5) (Value $ Integer 2) ) (Value $ Integer 7) ) ]
test/interpreter.hs view
@@ -11,14 +11,16 @@ import Data.Either import Data.List import Text.Parsec.Pos+import qualified Data.Text as T -getstatement :: Map.Map (TopLevelType, String) Statement -> TopLevelType -> String -> IO (Either String Statement)+getstatement :: Map.Map (TopLevelType, T.Text) Statement -> TopLevelType -> T.Text -> IO (Either String Statement) getstatement stmtlist toplevel name = case (Map.lookup (toplevel, name) stmtlist) of Just x -> return $ Right x Nothing -> return $ Left "not found" -gettemplate :: String -> String -> c -> IO (Either String String)-gettemplate n _ _ = return $ Right n+gettemplate :: Either T.Text T.Text -> T.Text -> c -> IO (Either String T.Text)+gettemplate (Right n) _ _ = return $ Right n+gettemplate (Left n) _ _ = return $ Right n main :: IO () main = do@@ -32,20 +34,23 @@ then return () else error "fail" +pdb :: b -> c -> IO (Either String a)+pdb _ _ = return $ Left "No puppetdb"+ testinterpreter :: FilePath -> IO (String, Bool) testinterpreter fp = do parsed <- runErrorT (parseFile fp) case parsed of Left err -> return (err, False) Right p -> do- let facts = Map.fromList [("hostname",ResolvedString "test")]+ let facts = Map.fromList [("::hostname",ResolvedString "test"), ("::fqdn", ResolvedString "fqdn")] toplevels = map convertTopLevel p oktoplevels = rights toplevels othertoplevels = lefts toplevels topclass = ClassDeclaration "::" Nothing [] othertoplevels (initialPos fp)- stmtpmap :: Map.Map (TopLevelType, String) Statement- stmtpmap = foldl' (\mp (ttype,tname,ts) -> Map.insert (ttype,tname) (TopContainer [(fp, topclass)] ts) mp) Map.empty oktoplevels- ctlg <- getCatalog (getstatement stmtpmap) gettemplate Nothing "test" facts (Just "test/modules") baseNativeTypes+ stmtpmap :: Map.Map (TopLevelType, T.Text) Statement+ stmtpmap = foldl' (\mp (ttype,tname,ts) -> Map.insert (ttype,tname) (TopContainer [(T.pack fp, topclass)] ts) mp) Map.empty oktoplevels+ ctlg <- getCatalog (getstatement stmtpmap) gettemplate pdb "test" facts (Just "test/modules") baseNativeTypes print ctlg case ctlg of (Right _, _) -> return ("PASS", True)