language-puppet 0.4.2 → 0.10.0
raw patch · 61 files changed
+4989/−4421 lines, 61 filesdep +Diffdep +ansi-wl-pprintdep +case-insensitivedep −failuredep −prettydep ~basedep ~bytestringnew-component:exe:pdbquerynew-component:exe:puppetresources
Dependencies added: Diff, ansi-wl-pprint, case-insensitive, filecache, hashable, hspec, optparse-applicative, parsers, stm, strict-base-types, yaml
Dependencies removed: failure, pretty
Dependency ranges changed: base, bytestring
Files
- Erb/Compute.hs +90/−69
- Erb/Evaluate.hs +26/−38
- Erb/Parser.hs +79/−55
- Erb/Ruby.hs +9/−0
- Facter.hs +126/−0
- LICENSE +1/−1
- Puppet/DSL/Loader.hs +0/−15
- Puppet/DSL/Parser.hs +0/−540
- Puppet/DSL/Printer.hs +0/−91
- Puppet/DSL/Types.hs +0/−160
- Puppet/Daemon.hs +110/−331
- Puppet/Init.hs +0/−46
- Puppet/Interpreter.hs +680/−0
- Puppet/Interpreter/Catalog.hs +0/−1448
- Puppet/Interpreter/Functions.hs +0/−146
- Puppet/Interpreter/PrettyPrinter.hs +111/−0
- Puppet/Interpreter/Resolve.hs +522/−0
- Puppet/Interpreter/Types.hs +546/−287
- Puppet/JsonCatalog.hs +0/−71
- Puppet/Manifests.hs +62/−0
- Puppet/NativeTypes.hs +19/−4
- Puppet/NativeTypes/Cron.hs +26/−23
- Puppet/NativeTypes/Exec.hs +8/−5
- Puppet/NativeTypes/File.hs +14/−10
- Puppet/NativeTypes/Group.hs +7/−3
- Puppet/NativeTypes/Helpers.hs +113/−83
- Puppet/NativeTypes/Host.hs +18/−14
- Puppet/NativeTypes/Mount.hs +6/−2
- Puppet/NativeTypes/Package.hs +67/−60
- Puppet/NativeTypes/SshSecure.hs +12/−8
- Puppet/NativeTypes/User.hs +5/−2
- Puppet/NativeTypes/ZoneRecord.hs +12/−8
- Puppet/PP.hs +23/−0
- Puppet/Parser.hs +589/−0
- Puppet/Parser/PrettyPrinter.hs +184/−0
- Puppet/Parser/Types.hs +166/−0
- Puppet/Plugins.hs +35/−49
- Puppet/Preferences.hs +37/−0
- Puppet/Printers.hs +0/−70
- Puppet/Stats.hs +21/−20
- Puppet/Stdlib.hs +238/−0
- Puppet/Testing.hs +82/−266
- Puppet/Utils.hs +26/−99
- PuppetDB/Common.hs +46/−0
- PuppetDB/Dummy.hs +17/−0
- PuppetDB/Query.hs +0/−70
- PuppetDB/Remote.hs +57/−0
- PuppetDB/Rest.hs +0/−44
- PuppetDB/TestDB.hs +161/−66
- SafeProcess.hs +4/−6
- Text/Parser/Parsec.hs +56/−0
- bench/lexer.hs +0/−4
- language-puppet.cabal +124/−97
- progs/PuppetResources.hs +259/−0
- progs/pdbQuery.hs +100/−0
- ruby/hrubyerb.rb +8/−4
- test/expr.hs +0/−22
- test/interpreter.hs +0/−58
- test/lexer.hs +0/−26
- tests/expr.hs +34/−0
- tests/lexer.hs +53/−0
Erb/Compute.hs view
@@ -1,25 +1,36 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}-module Erb.Compute(computeTemplate, getTemplateFile, initTemplateDaemon) where+{-# LANGUAGE CPP #-}+#ifdef HRUBY+{-# LANGUAGE ForeignFunctionInterface #-}+#endif+{-# LANGUAGE LambdaCase #-}+module Erb.Compute(computeTemplate, initTemplateDaemon) where +import Text.PrettyPrint.ANSI.Leijen hiding ((<>)) import Puppet.Interpreter.Types-import Puppet.Init+import Puppet.Preferences import Puppet.Stats+import Puppet.PP import Puppet.Utils +import qualified Data.Either.Strict as S import Control.Monad.Error import Control.Concurrent import System.Posix.Files import Paths_language_puppet (getDataFileName) import Erb.Parser import Erb.Evaluate-import qualified Data.Map as Map+import Erb.Ruby import Debug.Trace import qualified System.Log.Logger as LOG import qualified Data.Text as T import Text.Parsec+import Text.Parsec.Error+import Text.Parsec.Pos+import System.Environment+import Data.FileCache #ifdef HRUBY-import Foreign+import Foreign hiding (void) import Foreign.Ruby type RegisteredGetvariable = RValue -> RValue -> RValue -> RValue -> IO RValue@@ -32,60 +43,66 @@ 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 qualified Data.Foldable as F+import qualified Data.Vector as V #endif -type TemplateQuery = (Chan TemplateAnswer, Either T.Text T.Text, T.Text, Map.Map T.Text GeneralValue)-type TemplateAnswer = Either String T.Text-+instance Error ParseError where+ noMsg = newErrorUnknown (initialPos "dummy")+ strMsg s = newErrorMessage (Message s) (initialPos "dummy") +type TemplateQuery = (Chan TemplateAnswer, Either T.Text T.Text, T.Text, Container ScopeInformation)+type TemplateAnswer = S.Either Doc T.Text -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+initTemplateDaemon :: Preferences -> MStats -> IO (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text))+initTemplateDaemon (Preferences _ modpath templatepath _ _ _ _ _) mvstats = do controlchan <- newChan+ templatecache <- newFileCache #ifdef HRUBY- initialize- s <- (getRubyScriptPath "hrubyerb.rb" >>= \p -> rb_load_protect p 0)- unless (s == 0) $ do- msg <- showErrorStack- error msg- rubyResolveFunction <- mkRegisteredGetvariable hrresolveVariable- rb_define_global_function "varlookup" rubyResolveFunction 3- forkIO (templateDaemon modpath templatepath controlchan mvstats)+ -- forkOS is used because ruby doesn't like to change threads+ -- all initialization is done on the current thread+ void $ forkOS $ do+ initialize+ s <- (getRubyScriptPath "hrubyerb.rb" >>= \p -> rb_load_protect p 0)+ unless (s == 0) $ do+ msg <- showErrorStack+ error ("initTemplateDaemon: " ++ msg)+ rubyResolveFunction <- mkRegisteredGetvariable hrresolveVariable+ rb_define_global_function "varlookup" rubyResolveFunction 3+ templateDaemon (T.pack modpath) (T.pack templatepath) controlchan mvstats templatecache #else- replicateM_ ps (forkIO (templateDaemon modpath templatepath controlchan mvstats))+ forkIO (templateDaemon (T.pack modpath) (T.pack templatepath) controlchan mvstats templatecache) #endif return (templateQuery controlchan) -templateQuery :: Chan TemplateQuery -> Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> IO (Either String T.Text)+templateQuery :: Chan TemplateQuery -> Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text) templateQuery qchan filename scope variables = do rchan <- newChan writeChan qchan (rchan, filename, scope, variables) readChan rchan -templateDaemon :: T.Text -> T.Text -> Chan TemplateQuery -> MStats -> IO ()-templateDaemon modpath templatepath qchan mvstats = do+templateDaemon :: T.Text -> T.Text -> Chan TemplateQuery -> MStats -> FileCacheR ParseError [RubyStatement] -> IO ()+templateDaemon modpath templatepath qchan mvstats filecache = do (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]+ let prts = T.splitOn "/" filename+ searchpathes | length prts > 1 = [modpath <> "/" <> head prts <> "/templates/" <> T.intercalate "/" (tail prts), 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+ then writeChan respchan (S.Left $ "Can't find template file for" <+> ttext filename <+> ", looked in" <+> list (map ttext searchpathes))+ else measure mvstats ("total - " <> filename) (computeTemplate (Right (head acceptablefiles)) scope variables mvstats filecache) >>= writeChan respchan+ Left _ -> measure mvstats "total - inline" (computeTemplate fileinfo scope variables mvstats filecache) >>= writeChan respchan+ templateDaemon modpath templatepath qchan mvstats filecache -computeTemplate :: Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> MStats -> IO TemplateAnswer-computeTemplate fileinfo curcontext variables mstats = do+computeTemplate :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> MStats -> FileCacheR ParseError [RubyStatement] -> IO TemplateAnswer+computeTemplate fileinfo curcontext variables mstats filecache = 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+ Right _ -> measure mstats ("parsing - " <> filename) $ lazyQuery filecache ufilename $ parseErbFile ufilename Left content -> measure mstats ("parsing - " <> filename) (return (runParser erbparser () "inline" (T.unpack content))) case parsed of Left err -> do@@ -94,16 +111,13 @@ LOG.debugM "Erb.Compute" msg measure mstats ("ruby - " <> filename) $ computeTemplateWRuby fileinfo curcontext variables Right ast -> case rubyEvaluate variables curcontext ast of- Right ev -> return (Right ev)+ Right ev -> return (S.Right ev) Left err -> do let !msg = "template " ++ ufilename ++ " evaluation failed " ++ show err traceEventIO msg LOG.debugM "Erb.Compute" msg measure mstats ("ruby efail - " <> filename) $ computeTemplateWRuby fileinfo curcontext variables -getTemplateFile :: T.Text -> CatalogMonad T.Text-getTemplateFile = throwError- getRubyScriptPath :: String -> IO String getRubyScriptPath rubybin = do cabalPath <- getDataFileName $ "ruby/" ++ rubybin :: IO FilePath@@ -111,7 +125,7 @@ if exists then return cabalPath else do- path <- fmap (T.unpack . takeDirectory . T.pack) mGetExecutablePath+ path <- fmap (T.unpack . takeDirectory . T.pack) getExecutablePath let fullpath = path <> "/" <> rubybin lexists <- fileExist cabalPath return $ if lexists@@ -120,50 +134,55 @@ #ifdef HRUBY hrresolveVariable :: RValue -> RValue -> RValue -> RValue -> IO RValue--- T.Text -> Map.Map T.Text GeneralValue -> RValue -> RValue -> IO RValue-hrresolveVariable _ rscope rvariables rtoresolve = do- scope <- extractHaskellValue rscope+-- T.Text -> Container PValue -> RValue -> RValue -> IO RValue+hrresolveVariable _ rscp rvariables rtoresolve = do+ scope <- extractHaskellValue rscp variables <- extractHaskellValue rvariables toresolve <- fromRuby rtoresolve let answer = case toresolve of Just t -> getVariable variables scope t _ -> Left "The variable name is not a string" case answer of- Left _ -> getSymbol "undef"+ Left _ -> getSymbol "undef" Right r -> toRuby r -computeTemplateWRuby :: Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> IO TemplateAnswer+computeTemplateWRuby :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO TemplateAnswer computeTemplateWRuby fileinfo curcontext variables = freezeGC $ do- rscope <- embedHaskellValue curcontext+ rscp <- embedHaskellValue curcontext rvariables <- embedHaskellValue variables o <- case fileinfo of Right fname -> do rfname <- toRuby fname- safeMethodCall "Controller" "runFromFile" [rfname,rscope,rvariables]+ safeMethodCall "Controller" "runFromFile" [rfname,rscp,rvariables] Left content -> toRuby content >>= safeMethodCall "Controller" "runFromContent" . (:[]) freeHaskellValue rvariables- freeHaskellValue rscope+ freeHaskellValue rscp case o of- Left (rr, _) -> return (Left rr)- Right r -> fromRuby r >>= \x -> case x of- Just result -> return (Right result)- Nothing -> return (Left "Could not deserialiaze ruby output")+ Left (rr, _) ->+ let fname = case fileinfo of+ Right f -> T.unpack f+ Left _ -> "inline_template"+ in return (S.Left (dullred (text rr) <+> "in" <+> dullgreen (text fname)))+ Right r -> fromRuby r >>= \case+ Just result -> return (S.Right result)+ Nothing -> return (S.Left "Could not deserialiaze ruby output") #else saveTmpContent :: T.Text -> IO FilePath saveTmpContent cnt = do (name, h) <- openTempFile "/tmp" "inline_template.erb"+ T.hPutStr h cnt hClose h return name -computeTemplateWRuby :: Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> Maybe (FunPtr RegisteredGetvariable) -> IO TemplateAnswer+computeTemplateWRuby :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> 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+ let rubyvars = "{\n" <> mconcat (intersperse ",\n" (concatMap toRubyVars (itoList variables))) <> "\n}\n" :: T.Builder input = T.fromText curcontext <> "\n" <> T.fromText filename <> "\n" <> rubyvars :: T.Builder ufilename = T.unpack filename rubyscriptpath <- getRubyScriptPath "calcerb.rb"@@ -172,35 +191,37 @@ traceEventIO ("finished running ruby" ++ ufilename) F.forM_ temp removeLink case ret of- Just (Right x) -> return $! Right x+ Just (Right x) -> return $! S.Right x Just (Left er) -> do (tmpfilename, tmphandle) <- openTempFile "/tmp" "templatefail" TL.hPutStr tmphandle (T.toLazyText input) hClose tmphandle- return $ Left $ er ++ " - for template " ++ ufilename ++ " input in " ++ tmpfilename- Nothing -> return $ Left "Process did not terminate"+ return $ S.Left $ dullred (text er) <+> "- for template" <+> text ufilename <+> "input in" <+> text tmpfilename+ Nothing -> return $ S.Left "Process did not terminate" minterc :: T.Builder -> [T.Builder] -> T.Builder minterc _ [] = mempty minterc _ [a] = a-minterc !sep !(x:xs) = x <> foldl' minterc' mempty xs+minterc !separator (x:xs) = x <> foldl' minterc' mempty xs where- minterc' !curbuilder !b = curbuilder <> sep <> b+ minterc' !curbuilder !b = curbuilder <> separator <> b 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) = ["\t" <> renderString varname <> " => " <> toRuby' varval]-toRuby' (ResolvedString str) = renderString str-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+toRubyVars :: (T.Text, ScopeInformation) -> [T.Builder]+toRubyVars (ctx, scp) = concatMap (\(varname, varval :!: _) -> toRuby (ctx <> "::" <> varname, varval)) (itoList (scp ^. scopeVariables))++toRuby :: (T.Text, PValue) -> [T.Builder]+toRuby (_, PUndef) = []+toRuby (varname, varval) = ["\t" <> renderString varname <> " => " <> toRuby' varval]++toRuby' :: PValue -> T.Builder+toRuby' (PString str) = renderString str+toRuby' (PBoolean True) = "true"+toRuby' (PBoolean False) = "false"+toRuby' (PArray rr) = "[" <> minterc ", " (map toRuby' (rr ^.. traverse)) <> "]"+toRuby' (PHash hh) = "{ " <> minterc ", " (map (\(varname, varval) -> renderString varname <> " => " <> toRuby' varval) (itolist hh)) <> " }"+toRuby' PUndef = ":undef"+toRuby' (PResourceReference rtype rname) = renderString ( rtype <> "[" <> rname <> "]" ) #endif
Erb/Evaluate.hs view
@@ -1,62 +1,50 @@+{-# LANGUAGE LambdaCase #-} module Erb.Evaluate (rubyEvaluate, getVariable) where -import qualified Data.Map as Map+import Puppet.PP+import qualified Text.PrettyPrint.ANSI.Leijen as P+import Puppet.Interpreter.PrettyPrinter() import Puppet.Interpreter.Types+import Puppet.Interpreter.Resolve import Erb.Ruby-import Data.Maybe (catMaybes)-import Data.Either (rights)-import Control.Monad.Error import qualified Data.Text as T import Puppet.Utils+import Control.Lens+import qualified Data.Vector as V -rubyEvaluate :: Map.Map T.Text GeneralValue -> T.Text -> [RubyStatement] -> Either String T.Text+rubyEvaluate :: Container ScopeInformation -> T.Text -> [RubyStatement] -> Either Doc T.Text rubyEvaluate vars ctx = foldl (evalruby vars ctx) (Right "") -evalruby :: Map.Map T.Text GeneralValue -> T.Text -> Either String T.Text -> RubyStatement -> Either String T.Text+evalruby :: Container ScopeInformation -> T.Text -> Either Doc T.Text -> RubyStatement -> Either Doc 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) -evalExpression :: Map.Map T.Text GeneralValue -> T.Text -> Expression -> Either String T.Text+evalExpression :: Container ScopeInformation -> T.Text -> Expression -> Either Doc T.Text evalExpression mp ctx (LookupOperation varname varindex) = do rvname <- evalExpression mp ctx varname rvindx <- evalExpression mp ctx varindex- varvalue <- getVariable mp ctx rvname- case varvalue of- ResolvedArray arr -> do- case (a2i rvindx) of- 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 " ++ T.unpack rvname ++ "[" ++ T.unpack rvindx ++ "]"- else return $ arr !! i- return "x"- ResolvedHash hs -> case (filter (\(a,_) -> a == rvindx) hs) of- [] -> 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+ getVariable mp ctx rvname >>= \case+ PArray arr ->+ case a2i rvindx of+ Nothing -> Left $ "Can't convert index to integer when resolving" <+> ttext rvname P.<> brackets (ttext rvindx)+ Just i -> if V.length arr <= i+ then Left $ "Array out of bound" <+> ttext rvname P.<> brackets (ttext rvindx)+ else evalValue (arr V.! i)+ PHash hs -> case hs ^. at rvindx of+ Just x -> evalValue x+ _ -> Left $ "Can't index variable" <+> ttext rvname <+> ", it is " <+> pretty (PHash hs)+ varvalue -> Left $ "Can't index variable" <+> ttext rvname <+> ", it is " <+> pretty varvalue 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 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]- jsts = catMaybes vars- rghts = rights jsts- in do- 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)+evalExpression mp ctx (Object (Value (Literal x))) = getVariable mp ctx x >>= evalValue+evalExpression _ _ x = Left $ "Can't evaluate" <+> pretty x -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 $ tshow x-evalValue (Right x) = Right $ tshow x+evalValue :: PValue -> Either Doc T.Text+evalValue (PString x) = Right x+evalValue x = Right $ tshow x a2i :: T.Text -> Maybe Int a2i x = case readDecimal x of Right y -> Just y _ -> Nothing-
Erb/Parser.hs view
@@ -1,16 +1,19 @@+{-# LANGUAGE LambdaCase #-} module Erb.Parser where import Text.Parsec.String import Text.Parsec.Prim import Text.Parsec.Char+import Text.Parsec.Error import Text.Parsec.Combinator import Text.Parsec.Language (emptyDef) import Erb.Ruby import Text.Parsec.Expr import qualified Text.Parsec.Token as P import qualified Data.Text as T-+import Control.Monad.Identity +def :: P.GenLanguageDef String u Identity def = emptyDef { P.commentStart = "/*" , P.commentEnd = "*/"@@ -23,39 +26,59 @@ , P.caseSensitive = True } -lexer = P.makeTokenParser def-parens = P.parens lexer-braces = P.braces lexer-operator = P.operator lexer-symbol = P.symbol lexer-reservedOp = P.reservedOp lexer-whiteSpace = P.whiteSpace lexer-naturalOrFloat = P.naturalOrFloat lexer-identifier = P.identifier lexer+lexer :: P.GenTokenParser String u Identity+lexer = P.makeTokenParser def +parens :: Parser a -> Parser a+parens = P.parens lexer++braces :: Parser a -> Parser a+braces = P.braces lexer++operator :: Parser String+operator = P.operator lexer++symbol :: String -> Parser String+symbol = P.symbol lexer++reservedOp :: String -> Parser ()+reservedOp = P.reservedOp lexer++whiteSpace :: Parser ()+whiteSpace = P.whiteSpace lexer++naturalOrFloat :: Parser (Either Integer Double)+naturalOrFloat = P.naturalOrFloat lexer++identifier :: Parser String+identifier = P.identifier lexer++rubyexpression :: Parser Expression rubyexpression = buildExpressionParser table term <?> "expression" -table = [ [ Infix ( reservedOp "+" >> return PlusOperation ) AssocLeft- , Infix ( reservedOp "-" >> return MinusOperation ) AssocLeft ]- , [ Infix ( reservedOp "/" >> return DivOperation ) AssocLeft- , Infix ( reservedOp "*" >> return MultiplyOperation ) AssocLeft ]- , [ Infix ( reservedOp "<<" >> return ShiftLeftOperation ) AssocLeft- , Infix ( reservedOp ">>" >> return ShiftRightOperation ) AssocLeft ]- , [ Infix ( reservedOp "and" >> return AndOperation ) AssocLeft- , Infix ( reservedOp "or" >> return OrOperation ) AssocLeft ]- , [ Infix ( reservedOp "==" >> return EqualOperation ) AssocLeft- , Infix ( reservedOp "!=" >> return DifferentOperation ) AssocLeft ]- , [ Infix ( reservedOp ">" >> return AboveOperation ) AssocLeft- , Infix ( reservedOp ">=" >> return AboveEqualOperation ) AssocLeft- , Infix ( reservedOp "<=" >> return UnderEqualOperation ) AssocLeft- , Infix ( reservedOp "<" >> return UnderOperation ) AssocLeft ]- , [ Infix ( reservedOp "=~" >> return RegexpOperation ) AssocLeft- , Infix ( reservedOp "!~" >> return NotRegexpOperation ) AssocLeft ]- , [ Prefix ( symbol "!" >> return NotOperation ) ]- , [ Prefix ( symbol "-" >> return NegOperation ) ]- , [ Infix ( reservedOp "?" >> return ConditionalValue ) AssocLeft ]- , [ Infix ( reservedOp "." >> return MethodCall ) AssocLeft ]+table :: [[Operator String () Identity Expression]]+table = [ [ Infix ( reservedOp "+" >> return PlusOperation ) AssocLeft+ , Infix ( reservedOp "-" >> return MinusOperation ) AssocLeft ]+ , [ Infix ( reservedOp "/" >> return DivOperation ) AssocLeft+ , Infix ( reservedOp "*" >> return MultiplyOperation ) AssocLeft ]+ , [ Infix ( reservedOp "<<" >> return ShiftLeftOperation ) AssocLeft+ , Infix ( reservedOp ">>" >> return ShiftRightOperation ) AssocLeft ]+ , [ Infix ( reservedOp "and" >> return AndOperation ) AssocLeft+ , Infix ( reservedOp "or" >> return OrOperation ) AssocLeft ]+ , [ Infix ( reservedOp "==" >> return EqualOperation ) AssocLeft+ , Infix ( reservedOp "!=" >> return DifferentOperation ) AssocLeft ]+ , [ Infix ( reservedOp ">" >> return AboveOperation ) AssocLeft+ , Infix ( reservedOp ">=" >> return AboveEqualOperation ) AssocLeft+ , Infix ( reservedOp "<=" >> return UnderEqualOperation ) AssocLeft+ , Infix ( reservedOp "<" >> return UnderOperation ) AssocLeft ]+ , [ Infix ( reservedOp "=~" >> return RegexpOperation ) AssocLeft+ , Infix ( reservedOp "!~" >> return NotRegexpOperation ) AssocLeft ]+ , [ Prefix ( symbol "!" >> return NotOperation ) ]+ , [ Prefix ( symbol "-" >> return NegOperation ) ]+ , [ Infix ( reservedOp "?" >> return ConditionalValue ) AssocLeft ]+ , [ Infix ( reservedOp "." >> return MethodCall ) AssocLeft ] ]+term :: Parser Expression term = parens rubyexpression <|> scopeLookup@@ -63,36 +86,38 @@ <|> objectterm <|> variablereference +scopeLookup :: Parser Expression scopeLookup = do- try $ string "scope.lookupvar("+ void $ try $ string "scope.lookupvar(" expr <- rubyexpression- char ')'- return $ Object $ expr+ void $ char ')'+ return $ Object expr +blockinfo :: Parser String blockinfo = many1 $ noneOf "}" +stringLiteral :: Parser Expression stringLiteral = doubleQuoted <|> singleQuoted +doubleQuoted :: Parser Expression doubleQuoted = fmap (Value . Literal . T.pack) $ between (char '"') (char '"') (many $ noneOf "\"")++singleQuoted :: Parser Expression singleQuoted = fmap (Value . Literal . T.pack) $ between (char '\'') (char '\'') (many $ noneOf "'") +objectterm :: Parser Expression objectterm = do- methodname <- identifier >>= return . Value . Literal . T.pack- nc <- lookAhead anyChar- case nc of- '{' -> do- symbol "{"- b <- fmap T.pack blockinfo- symbol "}"- return $ MethodCall methodname (BlockOperation b)- '(' -> do- args <- parens (rubyexpression `sepBy` symbol ",")- return $ MethodCall methodname (Value $ Array args)+ methodname <- fmap (Value . Literal . T.pack) identifier+ lookAhead anyChar >>= \case+ '{' -> fmap (MethodCall methodname . BlockOperation . T.pack) (braces blockinfo)+ '(' -> fmap (MethodCall methodname . Value . Array) (parens (rubyexpression `sepBy` symbol ",")) _ -> return $ Object methodname -variablereference = identifier >>= return . Object . Value . Literal . T.pack+variablereference :: Parser Expression+variablereference = fmap (Object . Value . Literal . T.pack) identifier -rubystatement = rubyexpression >>= return . Puts+rubystatement :: Parser RubyStatement+rubystatement = fmap Puts rubyexpression textblockW :: Maybe Char -> Parser [RubyStatement] textblockW c = do@@ -101,33 +126,32 @@ Just x -> x:s Nothing -> s returned = Puts $ Value $ Literal $ T.pack ns- isend <- optionMaybe eof- case isend of+ optionMaybe eof >>= \case Just _ -> return [returned] Nothing -> do- char '<'- isrub <- optionMaybe (char '%')- n <- case isrub of+ void $ char '<'+ n <- optionMaybe (char '%') >>= \case Just _ -> rubyblock Nothing -> textblockW (Just '<') return (returned : n) +textblock :: Parser [RubyStatement] textblock = textblockW Nothing rubyblock :: Parser [RubyStatement] rubyblock = do- isequal <- optionMaybe (char '=')- parsed <- case isequal of- Just _ -> spaces >> rubyexpression >>= return . Puts+ parsed <- optionMaybe (char '=') >>= \case+ Just _ -> spaces >> fmap Puts rubyexpression Nothing -> spaces >> rubystatement spaces- string "%>"+ void $ try $ string "%>" n <- textblock return (parsed : n) erbparser :: Parser [RubyStatement] erbparser = textblock +parseErbFile :: FilePath -> IO (Either ParseError [RubyStatement]) parseErbFile fname = do input <- readFile fname return (runParser erbparser () fname input)
Erb/Ruby.hs view
@@ -1,6 +1,7 @@ module Erb.Ruby where import qualified Data.Text as T+import Text.PrettyPrint.ANSI.Leijen data Value = Literal !T.Text@@ -36,6 +37,14 @@ | BFalse | Error !String deriving (Show, Ord, Eq)++instance Pretty Expression where+ pretty (LookupOperation a b) = pretty a <> brackets (pretty b)+ pretty (PlusOperation a b) = parens (pretty a <+> text "+" <+> pretty b)+ pretty (MinusOperation a b) = parens (pretty a <+> text "-" <+> pretty b)+ pretty (DivOperation a b) = parens (pretty a <+> text "/" <+> pretty b)+ pretty (MultiplyOperation a b) = parens (pretty a <+> text "*" <+> pretty b)+ pretty op = text (show op) data RubyStatement = Puts !Expression
+ Facter.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE LambdaCase #-}+module Facter where++import Data.Char+import Text.Printf+import qualified Data.HashSet as HS+import qualified Data.HashMap.Strict as HM+import Puppet.Interpreter.Types+import System.Info+import qualified Data.Text as T+import Control.Arrow+import qualified Data.Either.Strict as S+import Control.Lens++storageunits :: [(String, Int)]+storageunits = [ ("", 0), ("K", 1), ("M", 2), ("G", 3), ("T", 4) ]++getPrefix :: Int -> String+getPrefix n | null fltr = error $ "Could not get unit prefix for order " ++ show n+ | otherwise = fst $ head fltr+ where fltr = filter (\(_, x) -> x == n) storageunits++getOrder :: String -> Int+getOrder n | null fltr = error $ "Could not get order for unit prefix " ++ show n+ | otherwise = snd $ head fltr+ where+ nu = map toUpper n+ fltr = filter (\(x, _) -> x == nu) storageunits++normalizeUnit :: (Double, Int) -> Double -> (Double, Int)+normalizeUnit (unit, order) base | unit > base = normalizeUnit (unit/base, order + 1) base+ | otherwise = (unit, order)++storagedesc :: (String, String) -> String+storagedesc (ssize, unit) = let+ size = read ssize :: Double+ uprefix | unit == "B" = ""+ | otherwise = [head unit]+ uorder = getOrder uprefix+ (osize, oorder) = normalizeUnit (size, uorder) 1024+ in printf "%.2f %sB" osize (getPrefix oorder)++factRAM :: IO [(String, String)]+factRAM = do+ meminfo <- fmap (map words . lines) (readFile "/proc/meminfo")+ let memtotal = ginfo "MemTotal:"+ memfree = ginfo "MemFree:"+ swapfree = ginfo "SwapFree:"+ swaptotal = ginfo "SwapTotal:"+ ginfo st = sdesc $ head $ filter ((== st) . head) meminfo+ sdesc [_, size, unit] = storagedesc (size, unit)+ return [("memorysize", memtotal), ("memoryfree", memfree), ("swapfree", swapfree), ("swapsize", swaptotal)]++factNET :: IO [(String, String)]+factNET = return [("ipaddress", "192.168.0.1")]++factOS :: IO [(String, String)]+factOS = do+ lsb <- fmap (map (break (== '=')) . lines) (readFile "/etc/lsb-release")+ hostname <- fmap (head . lines) (readFile "/proc/sys/kernel/hostname")+ let getval st | null filtered = "?"+ | otherwise = rvalue+ where filtered = filter (\(k,_) -> k == st) lsb+ value = (tail . snd . head) filtered+ rvalue | head value == '"' = read value+ | otherwise = value+ release = getval "DISTRIB_RELEASE"+ distid = getval "DISTRIB_ID"+ maj | release == "?" = "?"+ | otherwise = fst $ break (== '.') release+ osfam | distid == "Ubuntu" = "Debian"+ | otherwise = distid+ return [ ("lsbdistid" , distid)+ , ("operatingsystem" , distid)+ , ("lsbdistrelease" , release)+ , ("operatingsystemrelease" , release)+ , ("lsbmajdistrelease" , maj)+ , ("osfamily" , osfam)+ , ("hostname" , hostname)+ , ("lsbdistcodename" , getval "DISTRIB_CODENAME")+ , ("lsbdistdescription" , getval "DISTRIB_DESCRIPTION")+ , ("hardwaremodel" , arch)+ , ("architecture" , arch)+ ]++factMountPoints :: IO [(String, String)]+factMountPoints = do+ mountinfo <- fmap (map words . lines) (readFile "/proc/mounts")+ let ignorefs = HS.fromList+ ["NFS", "nfs", "nfs4", "nfsd", "afs", "binfmt_misc", "proc", "smbfs",+ "autofs", "iso9660", "ncpfs", "coda", "devpts", "ftpfs", "devfs",+ "mfs", "shfs", "sysfs", "cifs", "lustre_lite", "tmpfs", "usbfs", "udf",+ "fusectl", "fuse.snapshotfs", "rpc_pipefs", "configfs", "devtmpfs",+ "debugfs", "securityfs", "ecryptfs", "fuse.gvfs-fuse-daemon", "rootfs"+ ]+ goodlines = filter (\x -> not $ HS.member (x !! 2) ignorefs) mountinfo+ goodfs = map (!! 1) goodlines+ return [("mountpoints", unwords goodfs)]++version :: IO [(String, String)]+version = return [("facterversion", "0.1"),("environment","test")]++puppetDBFacts :: T.Text -> PuppetDBAPI -> IO (Container T.Text)+puppetDBFacts nodename pdbapi =+ getFacts pdbapi (QEqual FCertname nodename) >>= \case+ S.Right facts@(_:_) -> return (HM.fromList (map (\f -> (f ^. factname, f ^. factval)) facts))+ _ -> do+ rawFacts <- fmap concat (sequence [factNET, factRAM, factOS, version, factMountPoints, factOS])+ let ofacts = genFacts $ map (T.pack *** T.pack) rawFacts+ (hostname, ddomainname) = T.break (== '.') nodename+ domainname = if T.null ddomainname+ then ""+ else T.tail ddomainname+ nfacts = genFacts [ ("fqdn", nodename)+ , ("hostname", hostname)+ , ("domain", domainname)+ , ("rootrsa", "xxx")+ , ("operatingsystem", "Ubuntu")+ , ("puppetversion", "language-puppet")+ , ("virtual", "xenu")+ , ("clientcert", nodename)+ ]+ allfacts = nfacts `HM.union` ofacts+ genFacts = HM.fromList+ return allfacts+
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2012, Simon Marechal+Copyright (c) 2013, Simon Marechal All rights reserved.
− Puppet/DSL/Loader.hs
@@ -1,15 +0,0 @@-module Puppet.DSL.Loader (parseFile) where--import Text.Parsec-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 $ T.readFile fpath- case (runParser mparser () fpath result) of- Left err -> throwError (show err)- Right st -> return st
− Puppet/DSL/Parser.hs
@@ -1,540 +0,0 @@-{-|-This module exports the functions that will be useful to parse the DSL. They-should be able to parse everything you throw at them. The Puppet language is-extremely irregular, and most valid constructs are not documented in the-official language guide. This parser has been created by parsing the author's-own large manifests and the public Wikimedia ones.--Things that are known to not to be properly supported are :-- * \"plussignement\" such as foo +\> bar. How to handle this is far from- being obvious, as its actual behaviour is not documented.--}-module Puppet.DSL.Parser (- parse,- mparser,- exprparser-) where--import Puppet.DSL.Types-import Puppet.Utils--import Data.Char-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 qualified Data.Map as Map-import Puppet.NativeTypes-import Control.Monad (when)-import qualified Data.Text as T--def = P.LanguageDef- { P.commentStart = "/*"- , P.commentEnd = "*/"- , P.commentLine = "#"- , P.nestedComments = True- , P.identStart = letter- , P.identLetter = alphaNum <|> char '_'- , 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 = 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 :: 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. -}-exprparser = buildExpressionParser table term <?> "expression"--table = [- [ Infix ( reservedOp "?" >> return ConditionalValue ) AssocLeft ]- , [ Prefix ( symbol "-" >> return NegOperation ) ]- , [ Prefix ( symbol "!" >> return NotOperation ) ]- , [ Infix ( reserved "in" >> return IsElementOperation ) AssocLeft ]- , [ Infix ( reservedOp "/" >> return DivOperation ) AssocLeft- , Infix ( reservedOp "*" >> return MultiplyOperation ) AssocLeft ]- , [ Infix ( reservedOp "+" >> return PlusOperation ) AssocLeft- , Infix ( reservedOp "-" >> return MinusOperation ) AssocLeft ]- , [ Infix ( reservedOp "<<" >> return ShiftLeftOperation ) AssocLeft- , Infix ( reservedOp ">>" >> return ShiftRightOperation ) AssocLeft ]- , [ Infix ( reservedOp "==" >> return EqualOperation ) AssocLeft- , Infix ( reservedOp "!=" >> return DifferentOperation ) AssocLeft ]- , [ Infix ( reservedOp ">" >> return AboveOperation ) AssocLeft- , Infix ( reservedOp ">=" >> return AboveEqualOperation ) AssocLeft- , Infix ( reservedOp "<=" >> return UnderEqualOperation ) AssocLeft- , Infix ( reservedOp "<" >> return UnderOperation ) AssocLeft ]- , [ Infix ( reserved "and" >> return AndOperation ) AssocLeft- , Infix ( reserved "or" >> return OrOperation ) AssocLeft ]- , [ Infix ( reservedOp "=~" >> return RegexpOperation ) AssocLeft- , Infix ( reservedOp "!~" >> return NotRegexpOperation ) AssocLeft ]- ]-term = parens exprparser- <|> puppetInterpolableString- <|> puppetUndefined- <|> puppetRegexpExpr- <|> puppetVariableOrHashLookup- <|> 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 "]"- ; return e- }--puppetVariableOrHashLookup = do- v <- puppetVariable- whiteSpace- hashlist <- many hashRef- when (v == "string") $ unexpected "You are not allowed to name variables $string."- case hashlist of- [] -> return $ Value (VariableReference v)- _ -> return $ makeLookupOperation v hashlist--makeLookupOperation :: 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 :: Parser T.Text-identstring = fmap T.pack $ many1 (alphaNum <|> char '_')--identifier :: Parser T.Text-identifier = do {- x <- identstring- ; whiteSpace- ; return x- }--puppetResourceReference = do { rtype <- puppetQualifiedReference- ; symbol "["- ; rnames <- exprparser `sepBy` symbol ","- ; symbol "]"- ; if length rnames == 1- then return $ Value (ResourceReference rtype (head rnames))- else return $ Value $ PuppetArray $ map (Value . ResourceReference rtype) rnames- }--puppetResourceOverride = do { pos <- getPosition- ; rtype <- puppetQualifiedReference- ; symbol "["- ; rname <- exprparser `sepBy` symbol ","- ; symbol "]"- ; symbol "{"- ; e <- puppetAssignment `sepEndBy` symbol ","- ; symbol "}"- ; return (map (\n -> ResourceOverride rtype n e pos) rname)- }--puppetInclude = do { pos <- getPosition- ; try $ reserved "include"- ; vs <- exprparser `sepBy` (symbol ",")- ; return $ map (\v -> Include v pos) vs- }--puppetRequire = do { pos <- getPosition- ; try $ reserved "require"- ; v <- puppetLiteral `sepBy` (symbol ",")- ; return $ map (\x -> Require x pos) v- }--puppetQualifiedName = do { optional (string "::")- ; firstletter <- lower- ; parts <- identstring `sepBy` (try $ string "::")- ; whiteSpace- ; return $ T.cons firstletter (T.intercalate "::" parts)- }--puppetQualifiedReference = do { optional (string "::")- ; firstletter <- upper <?> "Uppercase letter for a reference"- ; parts <- identstring `sepBy` (string "::")- ; whiteSpace- ; return $ T.cons (toLower firstletter) (T.intercalate "::" $ map lowerFirstChar parts)- }--puppetFunctionCall = do { funcname <- identifier- ; symbol "("- ; e <- exprparser `sepEndBy` (symbol ",")- ; symbol ")"- ; return $ Value (FunctionCall funcname e)- }--puppetArrayRaw = do { symbol "["- ; e <- exprparser `sepEndBy` (symbol ",")- ; symbol "]"- ; return e- }--puppetArray = do { e <- puppetArrayRaw- ; return $ Value (PuppetArray e)- }--puppetHash = do { symbol "{"- ; e <- puppetAssignment `sepEndBy` (symbol ",")- ; symbol "}"- ; return $ Value (PuppetHash (Parameters e))- }--puppetAssignment = do { n <- exprparser- ; symbol "=>"- ; v <- exprparser- ; return $ (n, v)- }--nodeDeclaration = do { pos <- getPosition- ; try $ reserved "node"- ; whiteSpace- ; n <- puppetRegexp <|> puppetLiteral -- TODO HANDLE- ; symbol "{"- ; e <- many stmtparser- ; symbol "}"- ; return [ Node n (concat e) pos ]- }---- no trailing whiteSpace-puppetVariable :: Parser T.Text-puppetVariable = do- char '$'- choice- [ 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- pos <- getPosition- varname <- puppetVariable- whiteSpace- symbol "="- e <- exprparser- when (varname == "string") $ unexpected "You are not allowed to name variables $string."- return [VariableAssignment varname e pos]---- types de base--- puppetLiteral : toutes les strings puppet--puppetLiteral :: Parser T.Text-puppetLiteral = doubleQuotedString- <|> singleQuotedString- <|> puppetQualifiedName- <|> identifier--puppetLiteralValue = do { v <- puppetLiteral- ; return (Value (Literal v))- }--puppetRegexp :: Parser T.Text-puppetRegexp = do { char '/'- ; v <- many ( do { char '\\' ; x <- anyChar; return ['\\', x] } <|> many1 (noneOf "/\\") )- ; symbol "/"- ; return $ T.pack $ concat v- }--puppetRegexpExpr = puppetRegexp >>= return . Value . PuppetRegexp--singleQuotedString = do { char '\''- ; v <- many ( do { char '\\' ; x <- anyChar; if x=='\'' then return "'" else return ['\\',x] } <|> many1 (noneOf "'\\") )- ; char '\''- ; whiteSpace- ; return $ T.pack $ concat v- }--doubleQuotedString = do { char '"'- ; v <- option "" doubleQuotedStringContent- ; char '"'- ; whiteSpace- ; return v- }--puppetInterpolableString = do { char '"'- ; v <- many (- try ( do { x <- puppetVariable- ; when (x == "string") $ unexpected "You are not allowed to name variables $string."- ; return $ VariableReference x- } )- <|> do { x <- doubleQuotedStringContent- ; return $ Literal x- }- <|> do { char '$'- ; return $ Literal "$"- }- <?> "Interpolable string content"- )- ; char '"'- ; whiteSpace- ; return $ Value (Interpolable v)- }--doubleQuotedStringContent = do { x <- many1 (do { char '\\' ; x <- anyChar; return [stringEscape x] } <|> many1 (noneOf "\"\\$") )- ; return $ T.pack $ concat x- }--stringEscape 'n' = '\n'-stringEscape 't' = '\t'-stringEscape 'r' = '\r'-stringEscape '"' = '"'-stringEscape '\\' = '\\'-stringEscape '$' = '$'-stringEscape x = error $ "unknown escape pattern \\" ++ [x]--puppetUndefined = do- try $ string "undef"- whiteSpace- return $ Value $ Undefined--puppetNumeric = do { v <- naturalOrFloat- ; return (case v of- Left x -> (Value . Integer) x- Right x -> (Value . Double) x- )- }--puppetResourceGroup = do- (virtcount, v) <- try ( do {- virtcount <- many (char '@')- ; v <- puppetQualifiedName- ; symbol "{"- ; return (virtcount, v)- } )- x <- (resourceArrayDeclaration <|> resourceDeclaration) `sepEndBy` (symbol ";" <|> symbol ",")- symbol "}"- case virtcount of- "" -> return $ map (\(rname, rvalues, pos) -> (Resource v rname rvalues Normal pos)) (concat x)- "@" -> return $ map (\(rname, rvalues, pos) -> (Resource v rname rvalues Virtual pos)) (concat x)- "@@" -> return $ map (\(rname, rvalues, pos) -> (Resource v rname rvalues Exported pos)) (concat x)- _ -> unexpected "Too many @'s"---- todo parse resource collection properly-puppetResourceCollection = do { pos <- getPosition- ; rtype <- puppetQualifiedReference- ; chev <- many1 (char '<')- ; symbol "|"- ; e <- option BTrue exprparser- ; symbol "|"- ; many1 (char '>')- ; whiteSpace- ; overrides <- option [] (do { symbol "{"- ; ne <- puppetAssignment `sepEndBy` (symbol ",")- ; symbol "}"- ; return ne- })- ; case chev of- "<" -> return [ VirtualResourceCollection rtype e overrides pos ]- "<<" -> return [ ResourceCollection rtype e overrides pos ]- _ -> error $ "Invalid resource collection syntax at " ++ (show pos)- }--resourceArrayDeclaration = do { pos <- getPosition- ; v <- puppetArrayRaw- ; symbol ":"- ; x <- puppetAssignment `sepEndBy` symbol ","- ; return $ map (\nm -> (nm, x, pos)) v- }--resourceDeclaration = do { pos <- getPosition- ; v <- (puppetVariableOrHashLookup <|> puppetInterpolableString <|> puppetLiteralValue )- ; whiteSpace- ; symbol ":"- ; x <- puppetAssignment `sepEndBy` symbol ","- ; return [(v, x, pos)]- }--puppetResourceDefaults = do { pos <- getPosition- ; rtype <- puppetQualifiedReference- ; symbol "{"- ; e <- puppetAssignment `sepEndBy` symbol ","- ; symbol "}"- ; return [ResourceDefault rtype e pos]- }--puppetClassParameter = do { varname <- puppetVariable- ; whiteSpace- ; defaultvalue <- optionMaybe ( do { symbol "="- ; e <- exprparser- ; return e- } )- ; when (varname == "string") $ unexpected "You are not allowed to name variables $string."- ; return (varname, defaultvalue)- }--puppetClassParameters = do { symbol "("- ; pmt <- puppetClassParameter `sepBy` symbol ","- ; symbol ")"- ; return pmt- }--puppetClassDefinition = do { pos <- getPosition- ; try $ reserved "class"- ; cname <- puppetQualifiedName- ; params <- option [] puppetClassParameters- ; cparent <- optionMaybe ( do { string "inherits"; whiteSpace ; p <- puppetQualifiedName; return p } )- ; symbol "{"- ; st <- many stmtparser- ; symbol "}"- ; return [ClassDeclaration cname cparent params (concat st) pos]- }--puppetDefine = do- pos <- getPosition- try $ reserved "define"- cname <- puppetQualifiedName- params <- option [] puppetClassParameters- symbol "{"- st <- many stmtparser- symbol "}"- case Map.lookup cname baseNativeTypes of- Just _ -> unexpected "Can't use a native type name for a define."- Nothing -> return [DefineDeclaration cname params (concat st) pos]--puppetIfStyleCondition = do { cond <- exprparser <?> "Conditional expression"- ; symbol "{"- ; e <- many stmtparser- ; symbol "}"- ; return (cond, concat e)- }--puppetElseIfCondition = do { reservedOp "elsif"- ; whiteSpace- ; out <- puppetIfStyleCondition- ; return out- }--puppetElseCondition = do { reservedOp "else"- ; whiteSpace- ; symbol "{"- ; e <- many stmtparser- ; symbol "}"- ; return $ concat e- }--puppetIfCondition = do { pos <- getPosition- ; reserved "if"- ; whiteSpace- ; maincond <- puppetIfStyleCondition- ; others <- option [] (many puppetElseIfCondition)- ; elsec <- option [] puppetElseCondition- ; return [ConditionalStatement ([maincond] ++ others ++ [(BTrue, elsec)]) pos]- }--puppetCase = do {- compares <- exprparser `sepBy` symbol ","- ; symbol ":"- ; symbol "{"- ; st <- many stmtparser- ; symbol "}"- ; return ( compares, concat st )- }--puppetRegexpCase = do {- expression <- puppetRegexp- ; symbol ":"- ; symbol "{"- ; st <- many stmtparser- ; symbol "}"- ; return ( [Value (PuppetRegexp expression)], concat st )- }--defaultCase = do {- string "default"- ; symbol ":"- ; symbol "{"- ; st <- many stmtparser- ; symbol "}"- ; return ( [BTrue], concat st )- }--condsToExpression :: Expression -> ([Expression], [Statement]) -> [(Expression, [Statement])]-condsToExpression e (exprs, stmts) = map (\x -> condToExpression e (x, stmts)) exprs--condToExpression :: Expression -> (Expression, [Statement]) -> (Expression, [Statement])-condToExpression _ (BTrue, stmts) = (BTrue, stmts)-condToExpression e (Value (PuppetRegexp regexp), stmts) = (RegexpOperation e (Value (PuppetRegexp regexp)), stmts)-condToExpression e (cnd, stmts) = (EqualOperation e cnd, stmts)--puppetCaseCondition = do { pos <- getPosition- ; reservedOp "case"- ; whiteSpace- ; expr1 <- exprparser- ; symbol "{"- ; condlist <- many1 (puppetRegexpCase <|> try defaultCase <|> puppetCase)- ; symbol "}"- ; return $ [ConditionalStatement (concat (map (\x -> condsToExpression expr1 x) condlist)) pos]- }--puppetMainFunctionCall = do { pos <- getPosition- ; name <- identifier- ; whiteSpace- ; hasParens <- optionMaybe $ symbol "("- ; refs <- exprparser `sepEndBy` symbol ","- ; case hasParens of- Just _ -> symbol ")"- _ -> return ""- ; return [MainFunctionCall name refs pos]- }--puppetChains = do { pos <- getPosition- ; refs <- try (puppetResourceReference `sepBy1` symbol "->")- ; 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 | null pairs = []- | otherwise = zip pairs (tail pairs)- ; return $ map (\((n1,v1),(n2,v2)) -> DependenceChain (n1,v1) (n2,v2) pos) refpairs- }--puppetImport = do { pos <- getPosition- ; try $ reserved "import"- ; pattern <- puppetLiteral- ; return [Import pattern pos]- }--stmtparser = variableAssignment- <|> puppetInclude- <|> puppetRequire- <|> puppetImport- <|> nodeDeclaration- <|> puppetDefine- <|> puppetIfCondition- <|> puppetCaseCondition- <|> puppetResourceGroup- <|> try (puppetResourceDefaults)- <|> try (puppetResourceOverride)- <|> try (puppetResourceCollection)- <|> puppetClassDefinition- <|> puppetChains- <|> puppetMainFunctionCall- <?> "Statement"--mparser :: Parser [Statement]-mparser = do {- whiteSpace- ; result <- many stmtparser- ; eof- ; return $ concat result-}-
− Puppet/DSL/Printer.hs
@@ -1,91 +0,0 @@-module Puppet.DSL.Printer (- showAST,- showVarMap-) where--import Text.PrettyPrint-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" <+> 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" <+> 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 _) = 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)--showCondition :: (Expression, [Statement]) -> Doc-showCondition (BTrue, []) = empty-showCondition (e, stmts) = showExpression e <+> text "{" $$ nest 4 ( vcat (map showStatement stmts)) $$ text "}"--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 ')'--showExpression :: Expression -> Doc-showExpression (Value x) = showValue x-showExpression (ConditionalValue var conds) = showExpression var <+> text "=>" <+> showExpression conds-showExpression (PlusOperation a b) = showExpressionBuilder "+" a b-showExpression (MinusOperation a b) = showExpressionBuilder "-" a b-showExpression (DivOperation a b) = showExpressionBuilder "/" a b-showExpression (MultiplyOperation a b) = showExpressionBuilder "*" a b-showExpression (ShiftLeftOperation a b) = showExpressionBuilder "<<" a b-showExpression (ShiftRightOperation a b) = showExpressionBuilder ">>" a b-showExpression (AndOperation a b) = showExpressionBuilder "and" a b-showExpression (OrOperation a b) = showExpressionBuilder "or" a b-showExpression (EqualOperation a b) = showExpressionBuilder "==" a b-showExpression (DifferentOperation a b) = showExpressionBuilder "!=" a b-showExpression (AboveOperation a b) = showExpressionBuilder ">" a b-showExpression (AboveEqualOperation a b) = showExpressionBuilder ">=" a b-showExpression (UnderEqualOperation a b) = showExpressionBuilder "<=" a b-showExpression (UnderOperation a b) = showExpressionBuilder "<" a b-showExpression (RegexpOperation a b) = showExpressionBuilder "=~" a b-showExpression (NotRegexpOperation a b) = showExpressionBuilder "!~" a b-showExpression (NotOperation a) = char '(' <> char '!' <+> showExpression a <> char ')'-showExpression (NegOperation a) = char '(' <> char '-' <+> showExpression a <> char ')'-showExpression (BTrue) = text "true"-showExpression (BFalse) = text "false"-showExpression (LookupOperation a b) = showExpression a <> char '[' <> showExpression b <> char ']'-showExpression x = text (show x)--showValue :: Value -> Doc-showValue (Literal x) = text( show x )-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) = 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)--showAssignments :: [(Expression, Expression)] -> Doc-showAssignments params = vcat ( punctuate (text ", ") (map showAssignment params ) )--showAssignment :: (Expression, Expression) -> Doc-showAssignment (param, value) = showExpression param <+> text "=>" <+> showExpression value---- | Useful for displaying a map of variables.-showVarMap :: Map.Map String (Expression, SourcePos) -> String-showVarMap x = render $ vcat (map descLine (Map.toList x))- where- descLine (name, (expr, pos)) = text name <+> char '=' <+> showExpression expr <+> char '(' <> text (show pos) <> char ')'
− Puppet/DSL/Types.hs
@@ -1,160 +0,0 @@--- | Types used when parsing the Puppet DSL.--- A good knowledge of the Puppet language in required to understand them.-module Puppet.DSL.Types where--import Text.Parsec.Pos-import Data.Char (toUpper)-import qualified Data.Text as T-import Data.String--data Parameters = Parameters ![(Expression, Expression)] deriving(Show, Ord, Eq)---- |This type is used to differenciate the distinct top level types that are--- exposed by the DSL.-data TopLevelType- -- |This is for node entries.- = TopNode- -- |This is for defines.- | TopDefine- -- |This is for classes.- | TopClass- -- |This one is special. It represents top level statements that are not- -- part of a node, define or class. It is defined as spurious because it is- -- not what you are supposed to be. Also the caching system doesn't like- -- them too much right now.- | TopSpurious- deriving (Show, Ord, Eq)---- |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, 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)-convertTopLevel x = Left x---- | The 'Value' type represents a Puppet value. It is the terminal in a puppet--- 'Expression'-data Value- -- |String literal.- = 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 !T.Text- | Double !Double- | Integer !Integer- -- |Reference to a variable. The string contains what is acutally typed in- -- the manifest.- | VariableReference !T.Text- | Empty- | ResourceReference !T.Text !Expression -- restype resname- | PuppetArray ![Expression]- | PuppetHash !Parameters- | 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 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 !T.Text !Expression !SourcePos- | Include !Expression !SourcePos- | Import !T.Text !SourcePos- | Require !T.Text !SourcePos- -- | This holds the resource type, name, parameter list and virtuality.- | 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 !T.Text ![(Expression, Expression)] !SourcePos- {-| This works like 'Resource', but the 'Expression' holds the resource- name.- -}- | 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.- -}- | ConditionalStatement ![(Expression, [Statement])] !SourcePos- {-| The class declaration holds the class name, the optional name of the- class it inherits from, a list of parameters with optional default values,- and the list of statements it contains.- -}- | 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 !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 !T.Text !Expression ![(Expression, Expression)] !SourcePos- -- |Same as 'ResourceCollection', but for \<\| \|\>.- | 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 ![(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--- of the constructor.-data Expression- = LookupOperation !Expression !Expression -- ^ a[b]- | IsElementOperation !Expression !Expression -- ^ a in b- | PlusOperation !Expression !Expression -- ^ a + b- | MinusOperation !Expression !Expression -- ^ a - b- | DivOperation !Expression !Expression -- ^ a / b- | MultiplyOperation !Expression !Expression -- ^ a * b- | ShiftLeftOperation !Expression !Expression -- ^ a << b- | ShiftRightOperation !Expression !Expression -- ^ a >> b- | AndOperation !Expression !Expression -- ^ a & b- | OrOperation !Expression !Expression -- ^ a | b- | EqualOperation !Expression !Expression -- ^ a == b- | DifferentOperation !Expression !Expression -- ^ a != b- | AboveOperation !Expression !Expression -- ^ a > b- | AboveEqualOperation !Expression !Expression -- ^ a >= b- | UnderEqualOperation !Expression !Expression -- ^ a <= b- | UnderOperation !Expression !Expression -- ^ a < b- | RegexpOperation !Expression !Expression- -- ^ a =~ b (b should be a 'PuppetRegexp')- | NotRegexpOperation !Expression !Expression -- ^ a !~ b- | NotOperation !Expression -- ^ ! a- | NegOperation !Expression -- ^ - a- | ConditionalValue !Expression !Expression- -- ^ a ? b (b should be a 'PuppetHash')- | Value !Value -- ^ 'Value' terminal- | ResolvedResourceReference !T.Text !T.Text -- ^ Resolved resource reference- | BTrue -- ^ True expression, this could have been better to use a 'Value'- | BFalse -- ^ False expression- deriving(Show, Ord, Eq)--instance IsString Expression where- fromString = Value . fromString---- function that capitalizes types so that they look good-capitalizeResType :: T.Text -> T.Text-capitalizeResType = T.intercalate "::" . map capitalize' . T.splitOn "::"--capitalize' :: T.Text -> T.Text-capitalize' "" = ""-capitalize' t = T.cons (toUpper (T.head t)) (T.tail t)--
Puppet/Daemon.hs view
@@ -1,37 +1,44 @@-module Puppet.Daemon (initDaemon) where+{-# LANGUAGE LambdaCase #-}+module Puppet.Daemon (initDaemon, DaemonQuery(..), logDebug, logInfo, logWarning, logError) where -import Puppet.Init-import Puppet.Interpreter.Types-import Puppet.Interpreter.Catalog-import Puppet.DSL.Types-import Puppet.DSL.Loader+import Puppet.Parser import Puppet.Utils-+import Puppet.Preferences+import Puppet.Stats+import Puppet.Interpreter.Types+import Puppet.Parser.Types+import Puppet.Manifests+import Puppet.Interpreter+import Puppet.Plugins import Erb.Compute-import Control.Concurrent-import System.Posix.Files-import System.FilePath.Glob (globDir, compile)-import Control.Monad.State-import Control.Monad.Error++import Puppet.PP+import Text.Parsec+import Data.FileCache import qualified System.Log.Logger as LOG-import Data.List-import Data.Either (rights, lefts)-import Data.Foldable (foldlM)-import qualified Data.Map as Map-import Text.Parsec.Pos (initialPos)-import Puppet.Stats-import Debug.Trace import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as HM+import Debug.Trace+import Control.Lens+import Control.Monad+import Control.Concurrent+import qualified Data.Either.Strict as S+import Data.Tuple.Strict+import Control.Exception --- this daemon returns a catalog when asked for a node and facts-data DaemonMessage- = QCatalog (T.Text, Facts, Chan DaemonMessage)- | RCatalog (Either String (FinalCatalog, EdgeMap, FinalCatalog))+loggerName :: String+loggerName = "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+logDebug :: T.Text -> IO ()+logDebug = LOG.debugM loggerName . T.unpack+logInfo :: T.Text -> IO ()+logInfo = LOG.infoM loggerName . T.unpack+logWarning :: T.Text -> IO ()+logWarning = LOG.warningM loggerName . T.unpack+logError :: T.Text -> IO ()+logError = LOG.errorM loggerName . T.unpack {-| This is a high level function, that will initialize the parsing and interpretation infrastructure from the 'Prefs' structure, and will return a@@ -73,7 +80,7 @@ is not existent. This will need fixing. -}-initDaemon :: Prefs -> IO ( T.Text -> Facts -> IO(Either String (FinalCatalog, EdgeMap, FinalCatalog)), IO StatsTable, IO StatsTable, IO StatsTable )+initDaemon :: Preferences -> IO DaemonMethods initDaemon prefs = do logDebug "initDaemon" traceEventIO "initDaemon"@@ -81,317 +88,89 @@ templateStats <- newStats parserStats <- newStats catalogStats <- newStats- getstmts <- initParserDaemon prefs parserStats- templatefunc <- initTemplateDaemon prefs templateStats- replicateM_ (compilepoolsize prefs) (forkIO (master prefs controlChan getstmts templatefunc catalogStats))- return (gCatalog controlChan, getStats parserStats, getStats catalogStats, getStats templateStats)+ getStatements <- initParserDaemon prefs parserStats+ getTemplate <- initTemplateDaemon prefs templateStats+ let runMaster = do+ (luastate, luafunctions) <- initLua (T.pack (prefs ^. modulesPath))+ let luacontainer = HM.fromList [ (fname, puppetFunc luastate fname) | fname <- luafunctions ]+ myprefs = prefs & prefExtFuncs %~ HM.union luacontainer+ master myprefs controlChan getStatements getTemplate catalogStats+ replicateM_ (prefs ^. compilePoolSize) (forkIO runMaster)+ return (DaemonMethods (gCatalog controlChan) parserStats catalogStats templateStats) -master :: Prefs- -> Chan DaemonMessage- -> (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 " <> 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)- Right !x -> writeChan respchan (RCatalog $ Right x)- _ -> logError "Bad message type for master"- master prefs chan getstmts gettemplate mstats+gCatalog :: Chan DaemonQuery -> T.Text -> Facts -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog))+gCatalog q nodename fcts = do+ t <- newEmptyMVar+ writeChan q (DaemonQuery nodename fcts t)+ readMVar t -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)- response <- readChan respchan- case response of- RCatalog x -> return x- _ -> return $ Left "Bad answer from the master"+data DaemonQuery = DaemonQuery+ { _qNodeName :: T.Text+ , _qFacts :: Facts+ , _qQ :: MVar DaemonResponse+ } --- this daemon returns a list of statements when asked for a top class/define name-data ParserMessage- = QStatement (TopLevelType, T.Text, Chan ParserMessage)- | RStatement (Either String Statement)+type DaemonResponse = S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog) -initParserDaemon :: Prefs -> MStats -> IO- ( TopLevelType -> T.Text -> IO (Either String Statement)- )+master :: Preferences+ -> Chan DaemonQuery+ -> ( TopLevelType -> T.Text -> IO (S.Either Doc Statement) )+ -> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text))+ -> MStats+ -> IO ()+master prefs controlQ getStatements getTemplate stats = forever $ do+ (DaemonQuery nodename facts q) <- readChan controlQ+ logDebug ("Received query for node " <> nodename)+ traceEventIO ("Received query for node " <> T.unpack nodename)+ (stmts :!: warnings) <- measure stats nodename $ getCatalog getStatements getTemplate (prefs ^. prefPDB) nodename facts (prefs ^. natTypes) (prefs ^. prefExtFuncs)+ mapM_ (\(p :!: m) -> LOG.logM loggerName p (displayS (renderCompact m) "")) warnings+ traceEventIO ("getCatalog finished for " <> T.unpack nodename)+ putMVar q stmts++initParserDaemon :: Preferences -> MStats -> IO ( TopLevelType -> T.Text -> IO (S.Either Doc Statement) ) initParserDaemon prefs mstats = do- logDebug "initParserDaemon"+ let nbthreads = prefs ^. parsePoolSize+ logDebug ("initParserDaemon - " <> tshow nbthreads <> " threads") controlChan <- newChan- getparsed <- initParsedDaemon prefs mstats- replicateM_ (parsepoolsize prefs) (forkIO (pmaster prefs controlChan getparsed))- return (getStatements controlChan)---- extracts data from a filestatus-extractFStatus fs = (deviceID fs, fileID fs, modificationTime fs, fileSize fs)--getFileInfo :: FilePath -> IO (Maybe FileStatus)-getFileInfo fpath = do- fexists <- fileExist fpath- if fexists- then do- stat <- getFileStatus fpath- return $ Just stat- else return Nothing--getFirstFileInfo :: Maybe (FilePath, FileStatus) -> FilePath -> IO (Maybe (FilePath, FileStatus))-getFirstFileInfo (Just x) _ = return $ Just x-getFirstFileInfo Nothing y = do- stat <- getFileInfo y- case stat of- Just x -> return $ Just (y, x)- Nothing -> return Nothing+ filecache <- newFileCache+ replicateM_ nbthreads (forkIO (pmaster prefs controlChan filecache mstats))+ return $ \tt tn -> do+ c <- newEmptyMVar+ writeChan controlChan (ParserQuery tt tn c)+ readMVar c --- checks whether data pointed but the filepath has the corresponding file status-checkFileInfo :: FilePath -> FileStatus -> ErrorT String IO Bool-checkFileInfo fpath fstatus = do- stat <- liftIO $ getFileInfo fpath- case stat of- Just nfstatus -> return (extractFStatus nfstatus == extractFStatus fstatus)- Nothing -> return False+data ParserMessage = ParserQuery !TopLevelType !T.Text !(MVar (S.Either Doc Statement)) -compilefilelist :: Prefs -> TopLevelType -> T.Text -> [T.Text]-compilefilelist prefs TopNode _ = [manifest prefs <> "/site.pp"]-compilefilelist prefs _ name = moduleInfo+-- TODO this is wrong, see+-- http://docs.puppetlabs.com/puppet/3/reference/lang_namespaces.html#behavior+compileFileList :: Preferences -> TopLevelType -> T.Text -> S.Either Doc T.Text+compileFileList prefs TopNode _ = S.Right (T.pack (prefs ^. manifestPath) <> "/site.pp")+compileFileList prefs _ name = moduleInfo where- 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 -> T.Text -> ErrorT String IO (FilePath, FileStatus)-findFile prefs qtype resname = do- 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 ++ " " ++ T.unpack resname ++ " when looking in " ++ show filelist)--globImport :: FilePath -> Statement -> ErrorT String IO [FilePath]-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-globImport _ x = throwError $ "Should not run globImport on " ++ show x--{-- given a filename and a file status, will parse this file and update the cache with the parsed values-- it must also parse all required files and store everything about them before returning- -}-loadUpdateFile :: FilePath -> FileStatus -> (TopLevelType -> T.Text -> CacheEntry -> IO ParsedCacheResponse ) -> ErrorT String IO ([Statement], [(TopLevelType, T.Text, Statement)])-loadUpdateFile fname fstatus updatepinfo = do- let tfname = T.pack fname- liftIO $ logDebug ("Loading file " <> tfname)- parsed <- parseFile fname- let toplevels = map convertTopLevel parsed- oktoplevels = rights toplevels- othertoplevels = lefts toplevels- (imports, spurioustoplevels) = partition isImport othertoplevels- isImport (Import _ _) = True- isImport _ = False- relatedtops <- liftM (map T.pack . concat) (mapM (globImport fname) imports)- -- save this spurious top levels- unless (null spurioustoplevels) $ do- 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, tfname, fstatus, relatedtops)) oktoplevels- return (imports, oktoplevels)--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 -> 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 ++ " " ++ 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 -> 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- let fpathinfos = zip matched fileinfos- goodpathinfos = concatMap unjust fpathinfos- unjust (a, Just b) = [(a,b)]- unjust _ = []- ex <- (mapM (\(fname, finfo) -> liftM (\x -> (fname, x)) $ loadUpdateFile fname finfo updatepinfo) goodpathinfos)- -- This is a complicated and very expensive way to load imports that were imported.- -- The only way to make it faster would be to query the cache before reloading the files ..- let reloaded = concatMap (snd . snd) ex- limports = map (\(fname, (mimports, _)) -> (fname, mimports)) ex- mapM_ (\(fname, mimports) -> mapM_ (\stmt -> loadImport updatepinfo fname stmt) mimports) limports- return $ reloaded--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- Nothing -> return []- Just (stmts, _, _, related) -> do- relstatements <- liftM concat (mapM (loadRelated getpinfo) related)- return $ (filename,stmts):relstatements--handlePRequest :: Prefs ->- ( 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, tfpath, fstatus, related) -> do- -- for this to work, everything must be cached- -- this is buggy as the required stuff will not be invalidated properly- 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 tfpath- finfo <- liftIO $ getFileInfo fpath- case finfo of- Just fstat -> reparseFile fpath fstat updatepinfo qtype nodename- Nothing -> reparseStatements prefs updatepinfo qtype nodename- if null relstatements- then return statements- else return (TopContainer relstatements statements)- Nothing -> reparseStatements prefs updatepinfo qtype nodename >> handlePRequest prefs (getpinfo, updatepinfo, invalidateinfo) qtype nodename--pmaster :: Prefs -> Chan ParserMessage ->- ( 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- case pmessage of- QStatement (qtype, name, respchan) -> do- out <- runErrorT $ handlePRequest prefs cachefuncs qtype name- case out of- Left x -> writeChan respchan $ RStatement $ Left x- Right y -> writeChan respchan $ RStatement $ Right y- _ -> logError "Bad message type received by Puppet.Daemon.pmaster"- pmaster prefs chan cachefuncs--getStatements :: Chan ParserMessage -> TopLevelType -> T.Text -> IO (Either String Statement)-getStatements channel qtype classname = do- respchan <- newChan- writeChan channel $ QStatement (qtype, classname, respchan)- response <- readChan respchan- case response of- RStatement x -> return x- _ -> return $ Left "Bad answer from the pmaster"---- 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, T.Text, FileStatus, [T.Text])-data ParsedCacheQuery- = GetParsedData TopLevelType T.Text (Chan ParsedCacheResponse)- | UpdateParsedData TopLevelType T.Text CacheEntry (Chan ParsedCacheResponse)- | InvalidateCacheFile T.Text (Chan ParsedCacheResponse)-data ParsedCacheResponse- = 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 -> T.Text -> ErrorT String IO (Maybe CacheEntry)- , TopLevelType -> T.Text -> CacheEntry -> IO ParsedCacheResponse- , T.Text -> IO ParsedCacheResponse- )-initParsedDaemon prefs mstats = do- logDebug "initParsedDaemon"- controlChan <- newChan- forkIO ( evalStateT (parsedmaster prefs controlChan mstats) (Map.empty, Map.empty) )- return (getParsedInformation controlChan, updateParsedInformation controlChan, invalidateCachedFile controlChan)--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- out <- liftIO $ readChan respchan- case out of- RCacheEntry x -> return $ Just x- NoCacheEntry -> return Nothing- CacheError x -> throwError (T.unpack x)- _ -> throwError "Unknown cache response type"--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+ moduleInfo | length nameparts == 1 = S.Right (mpath <> "/" <> name <> "/manifests/init.pp")+ | null nameparts = S.Left "no name parts, error in compilefilelist"+ | otherwise = S.Right (mpath <> "/" <> head nameparts <> "/manifests/" <> T.intercalate "/" (tail nameparts) <> ".pp")+ mpath = T.pack (prefs ^. modulesPath)+ nameparts = T.splitOn "::" name -invalidateCachedFile :: Chan ParsedCacheQuery -> T.Text -> IO ParsedCacheResponse-invalidateCachedFile pchannel name = do- respchan <- newChan- writeChan pchannel $ InvalidateCacheFile name respchan- readChan respchan+parseFile :: FilePath -> IO (S.Either String (V.Vector Statement))+parseFile fname = do+ cnt <- T.readFile fname+ runParserT puppetParser () fname cnt >>= \case+ Right r -> return (S.Right r)+ Left rr -> return (S.Left (show rr)) --- state : (parsed statements map, file association map, nbrequests)-parsedmaster :: Prefs -> Chan ParsedCacheQuery -> MStats -> StateT - ( Map.Map (TopLevelType, T.Text) CacheEntry- , Map.Map T.Text (FileStatus, [(TopLevelType, T.Text)])- ) IO ()-parsedmaster prefs controlchan mstats = do- curmsg <- liftIO $ readChan controlchan- case curmsg of- GetParsedData qtype name respchan -> do- (curmap, _) <- get- case Map.lookup (qtype, name) curmap of- 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 " <> tshow qtype <> " " <> name)- (mp, fm) <- get- let- -- retrieve the current status- curstatus = Map.lookup filepath fm- fmclean = case curstatus of- Just (cs,_) -> if extractFStatus cs /= extractFStatus filestatus- then Map.delete filepath fm- else fm- _ -> fm- addsnd (a1, b1) (_, b2) = (a1, b1 ++ b2)- fileassocmap = Map.insertWith addsnd filepath (filestatus, [(qtype, name)]) fmclean- statementmap = Map.insert (qtype, name) val mp- put (statementmap, fileassocmap)- liftIO $ measure mstats "update" (writeChan respchan CacheUpdated)- InvalidateCacheFile fname respchan -> do- liftIO $ logDebug $ "Invalidating files for " <> fname- (mp, fm) <- get- let- nfm = Map.delete fname fm- nmp = case Map.lookup fname fm of- Just (_, remlist) -> foldl' (flip Map.delete) mp remlist- Nothing -> mp- put (nmp, nfm)- liftIO $ measure mstats "invalidate" (writeChan respchan CacheUpdated)- parsedmaster prefs controlchan mstats+pmaster :: Preferences -> Chan ParserMessage -> FileCache (V.Vector Statement) -> MStats -> IO ()+pmaster prefs controlqueue filecache stats = forever $ do+ (ParserQuery topleveltype toplevelname responseQ) <- readChan controlqueue+ case compileFileList prefs topleveltype toplevelname of+ S.Left rr -> putMVar responseQ (S.Left rr)+ S.Right fname -> do+ let sfname = T.unpack fname+ handleFailure :: SomeException -> IO (S.Either String (V.Vector Statement))+ handleFailure e = return (S.Left (show e))+ colorError (S.Right x) = S.Right x+ colorError (S.Left rr) = S.Left (red (text rr))+ fmap colorError ( measure stats fname (query filecache sfname (parseFile sfname `catch` handleFailure)) ) >>= \case+ S.Left rr -> putMVar responseQ (S.Left rr)+ S.Right stmts -> filterStatements topleveltype toplevelname stmts >>= putMVar responseQ
− Puppet/Init.hs
@@ -1,46 +0,0 @@-{-| This is a helper module for the "Puppet.Daemon" module -}-module Puppet.Init where--import Puppet.Interpreter.Types-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 :: 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.- 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 :: T.Text -> IO Prefs-genPrefs basedir = do- 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)- 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 :: [(T.Text,T.Text)] -> Facts-genFacts = Map.fromList . concatMap (\(a,b) -> [(a, ResolvedString b), ("::" <> a, ResolvedString b)])-
+ Puppet/Interpreter.hs view
@@ -0,0 +1,680 @@+{-# LANGUAGE LambdaCase #-}+module Puppet.Interpreter where++import Puppet.Interpreter.Types+import Puppet.Interpreter.PrettyPrinter(containerComma)+import Puppet.Interpreter.Resolve+import Puppet.Parser.Types+import Puppet.Parser.PrettyPrinter+import Puppet.PP+import Puppet.NativeTypes++import Prelude hiding (mapM)+import Puppet.Utils+import System.Log.Logger+import Data.Maybe+import Data.List (nubBy)+import qualified Data.Text as T+import Data.Tuple.Strict (Pair(..))+import qualified Data.Tuple.Strict as S+import qualified Data.Either.Strict as S+import qualified Data.HashSet as HS+import qualified Data.HashMap.Strict as HM+import Control.Monad.Trans.RWS.Strict+import Control.Monad.Error hiding (mapM)+import Control.Lens+import qualified Data.Maybe.Strict as S+import qualified Data.Graph as G+import qualified Data.Tree as T+import Data.Foldable (toList,foldl',Foldable,foldlM)+import Data.Traversable (mapM)++-- helpers+vmapM :: (Monad m, Foldable t) => (a -> m b) -> t a -> m [b]+vmapM f = mapM f . toList++getCatalog :: ( TopLevelType -> T.Text -> IO (S.Either Doc Statement) ) -- ^ get statements function+ -> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text)) -- ^ compute template function+ -> PuppetDBAPI+ -> T.Text -- ^ Node name+ -> Facts -- ^ Facts ...+ -> Container PuppetTypeMethods -- ^ List of native types+ -> Container ( [PValue] -> InterpreterMonad PValue )+ -> IO (Pair (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog)) [Pair Priority Doc])+getCatalog gtStatement gtTemplate pdbQuery ndename facts nTypes extfuncs = do+ let rdr = InterpreterReader nTypes gtStatement gtTemplate pdbQuery extfuncs ndename+ dummypos = initialPPos "dummy"+ initialclass = mempty & at "::" ?~ (IncludeStandard :!: dummypos)+ stt = InterpreterState baseVars initialclass mempty ["::"] dummypos mempty [] []+ factvars = facts & each %~ (\x -> PString x :!: initialPPos "facts" :!: ContRoot)+ callervars = ifromList [("caller_module_name", PString "::" :!: dummypos :!: ContRoot), ("module_name", PString "::" :!: dummypos :!: ContRoot)]+ baseVars = isingleton "::" (ScopeInformation (factvars <> callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing)+ (output, _, warnings) <- runRWST (runErrorT (computeCatalog ndename)) rdr stt+ return (strictifyEither output :!: _warnings warnings)++isParent :: T.Text -> CurContainerDesc -> InterpreterMonad Bool+isParent _ ContRoot = return False+isParent _ ContImported = return False+isParent _ (ContDefine _ _) = return False+isParent cur (ContClass possibleparent) = do+ preuse (scopes . ix cur . scopeParent) >>= \case+ Nothing -> throwPosError ("Internal error: could not find scope" <+> ttext cur <+> "possible parent" <+> ttext possibleparent)+ Just S.Nothing -> return False+ Just (S.Just p) -> if p == possibleparent+ then return True+ else isParent p (ContClass possibleparent)++finalize :: [Resource] -> InterpreterMonad [Resource]+finalize rlist = do+ -- step 1, apply defaults+ scp <- getScope+ defs <- use (scopes . ix scp . scopeDefaults)+ let getOver = use (scopes . ix scp . scopeOverrides) -- retrieves current overrides+ addDefaults r = do+ let thisresdefaults = defs ^. ix (r ^. rid . itype) . defValues+ foldM (addAttribute CantReplace) r (itoList thisresdefaults)+ addOverrides r = do+ overs <- getOver+ case overs ^. at (r ^. rid) of+ Just x -> do+ scopes . ix scp . scopeOverrides . at (r ^. rid) .= Nothing+ addOverrides' r x+ Nothing -> return r+ addOverrides' r (ResRefOverride _ prms p) = do+ let inter = (r ^. rattributes) `HM.intersection` prms+ unless (fnull inter) $ do+ s <- getScope+ i <- isParent s (r ^. rcontainer)+ unless i $ throwPosError ("You are not allowed to override the following parameters " <+> containerComma inter <+> "already defined at" <+> showPPos p)+ return (r & rattributes %~ (<>) prms)+ withDefaults <- mapM (addOverrides >=> addDefaults) rlist+ -- There might be some overrides that could not be applied. The only+ -- valid reason is that they override something in exported resources.+ --+ -- This will probably do something unexpected on defines, but let's do+ -- it that way for now.+ let keepforlater (ResRefOverride resid resprms ropos) = resMod %= (appended : )+ where+ appended = ResourceModifier (resid ^. itype) ModifierMustMatch DontRealize (REqualitySearch "title" (PString (resid ^. iname))) overrider ropos+ overrider r = do+ -- we must define if we can override the value+ let canOverride = CantOverride -- TODO check inheritance+ foldM (addAttribute canOverride) r (itoList resprms)+ fmap toList getOver >>= mapM_ keepforlater+ let expandableDefine (curstd, curdef) r = do+ n <- isNativeType (r ^. rid . itype)+ return $! if n || (r ^. rvirtuality /= Normal)+ then (r : curstd, curdef)+ else (curstd, r : curdef)+ (standard, defines) <- foldM expandableDefine ([], []) withDefaults+ expanded <- mapM expandDefine defines+ return $! standard ++ concat expanded++popScope :: InterpreterMonad ()+popScope = curScope %= tail++pushScope :: T.Text -> InterpreterMonad ()+pushScope s = curScope %= (s :)++evalTopLevel :: Statement -> InterpreterMonad ([Resource], Statement)+evalTopLevel (TopContainer tops s) = do+ pushScope "::"+ r <- vmapM evaluateStatement tops >>= finalize . concat+ -- popScope+ (nr, ns) <- evalTopLevel s+ popScope+ return (r <> nr, ns)+evalTopLevel x = return ([], x)++getstt :: TopLevelType -> T.Text -> InterpreterMonad ([Resource], Statement)+getstt topleveltype toplevelname = do+ -- check if this is a known class (spurious or inner class)+ use (nestedDeclarations . at (topleveltype, toplevelname)) >>= \case+ Just x -> return ([], x) -- it is known !+ Nothing -> do+ -- load the file+ getStmtfunc <- view getStatement+ liftIO (getStmtfunc topleveltype toplevelname) >>= \case+ S.Right x -> evalTopLevel x+ S.Left y -> throwPosError y++computeCatalog :: T.Text -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog)+computeCatalog ndename = do+ (restop, node) <- getstt TopNode ndename+ let finalStep [] = return []+ finalStep allres = do+ -- collect stuff and apply thingies+ (realized :!: modified) <- realize allres+ -- we need to run it again against collected stuff, especially+ -- for defines that have been realized+ refinalized <- finalize (toList modified) >>= finalStep+ -- replace the modified stuff+ let res = foldl' (\curm e -> curm & at (e ^. rid) ?~ e) realized refinalized+ return (toList res)+ resnode <- evaluateNode node >>= finalStep . (++ restop)+ let (real :!: exported) = foldl' classify (mempty :!: mempty) resnode+ classify (curr :!: cure) r =+ let i curm = curm & at (r ^. rid) ?~ r+ in case r ^. rvirtuality of+ Normal -> i curr :!: cure+ Exported -> curr :!: i cure+ ExportedRealized -> i curr :!: i cure+ _ -> curr :!: cure+ verified <- fmap (ifromList . map (\r -> (r ^. rid, r))) $ mapM validateNativeType (toList real)+ mp <- makeEdgeMap verified+ return (verified, mp, exported)++dependencyErrors :: [T.Tree G.Vertex] -> (G.Vertex -> (RIdentifier, RIdentifier, [RIdentifier])) -> InterpreterMonad ()+dependencyErrors _ _ = throwPosError "Undefined dependency cycle"++makeEdgeMap :: FinalCatalog -> InterpreterMonad EdgeMap+makeEdgeMap ct = do+ -- merge the looaded classes and resources+ defs' <- use definedResources+ clss' <- use loadedClasses+ let defs = defs' <> classes' <> aliases' <> names'+ names' = HM.map _rpos ct+ -- generate fake resources for all extra aliases+ aliases' = ifromList $ do+ r <- ct ^.. traversed :: [Resource]+ extraAliases <- r ^.. ralias . folded . filtered (/= r ^. rid . iname) :: [T.Text]+ return (r ^. rid & iname .~ extraAliases, r ^. rpos)+ classes' = ifromList $ do+ (cn, _ :!: cp) <- itoList clss'+ return (RIdentifier "class" cn, cp)+ -- Preparation step : all relations to a container become relations to+ -- the stuff that's contained. We build a map of resources, stored by+ -- container.+ let containerMap :: HM.HashMap RIdentifier [RIdentifier]+ !containerMap = ifromListWith (<>) $ do+ r <- toList ct+ let toResource ContRoot = RIdentifier "class" "::"+ toResource (ContClass cn) = RIdentifier "class" cn+ toResource (ContDefine t n) = RIdentifier t n+ toResource ContImported = RIdentifier "class" "::"+ return (toResource (r ^. rcontainer), [r ^. rid])+ -- This function uses the previous map in order to resolve to non+ -- container resources.+ resolveDestinations :: RIdentifier -> [RIdentifier]+ resolveDestinations r = case containerMap ^. at r of+ Just x -> concatMap resolveDestinations x+ Nothing -> [r]+ -- step 1 - add relations that are stored in resources+ let reorderlink :: (RIdentifier, RIdentifier, LinkType) -> (RIdentifier, RIdentifier, LinkType)+ reorderlink (s, d, RBefore) = (d, s, RRequire)+ reorderlink (s, d, RNotify) = (d, s, RSubscribe)+ reorderlink x = x+ addRR curmap r = iunionWith (<>) curmap newmap+ where+ newmap = ifromListWith (<>) $ do+ (rawdst, lts) <- itoList (r ^. rrelations)+ dst <- resolveDestinations rawdst+ lt <- toList lts+ let (nsrc, ndst, nlt) = reorderlink (r ^. rid, dst, lt)+ return (r ^. rid, [LinkInformation nsrc ndst nlt (r ^. rpos)])+ step1 = foldl' addRR mempty ct+ -- step 2 - add other relations (mainly stuff made from the "->"+ -- operator)+ let realign (LinkInformation s d t p) = do+ let (ns, nd, nt) = reorderlink (s, d, t)+ rs <- resolveDestinations ns+ rd <- resolveDestinations nd+ return (rs, [LinkInformation rs rd nt p])+ rels <- fmap (concatMap realign) (use extraRelations)+ let step2 = iunionWith (<>) step1 (ifromList rels)+ -- check that all resources are defined, and build graph+ let checkResDef :: (RIdentifier, [LinkInformation]) -> InterpreterMonad (RIdentifier, RIdentifier, [RIdentifier])+ checkResDef (ri, lifs) = do+ let checkExists r msg = unless (defs ^. contains r) (throwPosError msg)+ errmsg = "Unknown resource" <+> pretty ri <+> "used in the following relationships:" <+> vcat prels+ prels = [ pretty (li ^. linksrc) <+> "->" <+> pretty (li ^. linkdst) <+> showPPos (li ^. linkPos) | li <- lifs ]+ checkExists ri errmsg+ let genlnk :: LinkInformation -> InterpreterMonad RIdentifier+ genlnk lif = do+ let d = lif ^. linkdst+ checkExists d ("Unknown resource" <+> pretty d <+> "used in a relation at" <+> showPPos (lif ^. linkPos))+ return d+ ds <- mapM genlnk lifs+ return (ri, ri, ds)+ (graph, gresolver) <- fmap G.graphFromEdges' $ mapM checkResDef (itoList step2)+ -- now check for scc+ let sccs = filter ((>1) . length . T.flatten) (G.scc graph)+ unless (null sccs) (dependencyErrors sccs gresolver)+ return step2++realize :: [Resource] -> InterpreterMonad (Pair FinalCatalog FinalCatalog)+realize rs = do+ let rma = ifromList (map (\r -> (r ^. rid, r)) rs)+ mutate :: Pair FinalCatalog FinalCatalog -> ResourceModifier -> InterpreterMonad (Pair FinalCatalog FinalCatalog)+ mutate (curmap :!: modified) rmod = do+ let filtrd = curmap ^.. folded . filtered fmod+ vcheck f r = f (r ^. rvirtuality)+ (isGoodvirtuality, alterVirtuality) = case rmod ^. rmType of+ RealizeVirtual -> (vcheck (/= Exported), \r -> return (r & rvirtuality .~ Normal))+ RealizeCollected -> (vcheck (`elem` [Exported, ExportedRealized]), \r -> return (r & rvirtuality .~ ExportedRealized))+ DontRealize -> (vcheck (`elem` [Normal, ExportedRealized]), return)+ fmod r = (r ^. rid . itype == rmod ^. rmResType) && checkSearchExpression (rmod ^. rmSearch) r && isGoodvirtuality r+ mutation = alterVirtuality >=> rmod ^. rmMutation+ applyModification :: Pair (Pair FinalCatalog FinalCatalog) Bool -> Resource -> InterpreterMonad (Pair (Pair FinalCatalog FinalCatalog) Bool)+ applyModification (cma :!: cmo :!: matched) r = do+ nr <- mutation r+ let i m = m & at (nr ^. rid) ?~ nr+ return $ if nr /= r+ then i cma :!: i cmo :!: True+ else cma :!: cmo :!: matched+ (result :!: mtch) <- foldM applyModification (curmap :!: modified :!: False) filtrd+ when (rmod ^. rmModifierType == ModifierMustMatch && not mtch) (throwError ("Could not apply this resource override :" <+> pretty rmod))+ return result+ equalModifier (ResourceModifier a1 b1 c1 d1 _ e1) (ResourceModifier a2 b2 c2 d2 _ e2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2+ result <- use resMod >>= foldM mutate (rma :!: mempty) . nubBy equalModifier+ resMod .= []+ return result++evaluateNode :: Statement -> InterpreterMonad [Resource]+evaluateNode (Node _ stmts inheritance p) = do+ curPos .= p+ pushScope "::"+ unless (S.isNothing inheritance) $ throwPosError "Node inheritance is not handled yet, and will probably never be"+ vmapM evaluateStatement stmts >>= finalize . concat+evaluateNode x = throwPosError ("Asked for a node evaluation, but got this instead:" <$> pretty x)++evaluateStatementsVector :: Foldable f => f Statement -> InterpreterMonad [Resource]+evaluateStatementsVector = fmap concat . vmapM evaluateStatement++-- | Converts a list of pairs into a container, checking there is no+-- duplicate+fromArgumentList :: [Pair T.Text a] -> InterpreterMonad (Container a)+fromArgumentList = foldM insertArgument mempty+ where+ insertArgument curmap (k :!: v) =+ case curmap ^. at k of+ Just _ -> throwPosError ("Parameter" <+> dullyellow (ttext k) <+> "already defined!")+ Nothing -> return (curmap & at k ?~ v)++evaluateStatement :: Statement -> InterpreterMonad [Resource]+evaluateStatement r@(ClassDeclaration cname _ _ _ _) =+ if "::" `T.isInfixOf` cname+ then nestedDeclarations . at (TopClass, cname) ?= r >> return []+ else do+ scp <- getScope+ if scp == "::"+ then nestedDeclarations . at (TopClass, cname) ?= r >> return []+ else nestedDeclarations . at (TopClass, scp <> "::" <> cname) ?= r >> return []+evaluateStatement r@(DefineDeclaration dname _ _ _) =+ if "::" `T.isInfixOf` dname+ then nestedDeclarations . at (TopDefine, dname) ?= r >> return []+ else do+ scp <- getScope+ if scp == "::"+ then nestedDeclarations . at (TopDefine, dname) ?= r >> return []+ else nestedDeclarations . at (TopDefine, scp <> "::" <> dname) ?= r >> return []+evaluateStatement r@(ResourceCollection e resType searchExp mods p) = do+ curPos .= p+ unless (fnull mods || e == Collector) (throwPosError ("It doesnt seem possible to amend attributes with an exported resource collector:" <$> pretty r))+ rsearch <- resolveSearchExpression searchExp+ let et = case e of+ Collector -> RealizeVirtual+ ExportedCollector -> RealizeCollected+ resMod %= (ResourceModifier resType ModifierCollector et rsearch return p : )+ -- Now collectd from the PuppetDB !+ if et == RealizeCollected+ then do+ let q = searchExpressionToPuppetDB resType rsearch+ pdb <- view pdbAPI+ interpreterIO (getResources pdb q)+ else return []+evaluateStatement (Dependency (t1 :!: n1) (t2 :!: n2) p) = do+ curPos .= p+ rn1 <- resolveExpressionStrings n1+ rn2 <- resolveExpressionStrings n2+ forM_ rn1 $ \an1 -> forM_ rn2 $ \an2 ->+ extraRelations %= (LinkInformation (RIdentifier t1 an1) (RIdentifier t2 an2) RBefore p :)+ return []+evaluateStatement (ResourceDeclaration rt ern eargs virt p) = do+ curPos .= p+ resnames <- resolveExpressionStrings ern+ args <- vmapM resolveArgument eargs >>= fromArgumentList+ fmap concat (mapM (\n -> registerResource rt n args virt p) resnames)+evaluateStatement (MainFunctionCall funcname funcargs p) = do+ curPos .= p+ vmapM resolveExpression funcargs >>= mainFunctionCall funcname+evaluateStatement (VariableAssignment varname varexpr p) = do+ curPos .= p+ varval <- resolveExpression varexpr+ loadVariable varname varval+ return []+evaluateStatement (ConditionalStatement conds p) = do+ curPos .= p+ let checkCond [] = return []+ checkCond ((e :!: stmts) : xs) = do+ result <- fmap pValue2Bool (resolveExpression e)+ if result+ then evaluateStatementsVector stmts+ else checkCond xs+ checkCond (toList conds)+evaluateStatement (DefaultDeclaration resType decls p) = do+ curPos .= p+ let resolveDefaultValue (prm :!: v) = fmap (prm :!:) (resolveExpression v)+ rdecls <- vmapM resolveDefaultValue decls >>= fromArgumentList+ scp <- getScope+ -- invariant that must be respected : the current scope must me create+ -- in "scopes", or nothing gets saved+ let newDefaults = ResDefaults resType scp rdecls p+ addDefaults x = scopes . ix scp . scopeDefaults . at resType ?= x+ -- default merging with parent+ mergedDefaults curdef = newDefaults & defValues .~ (rdecls <> (curdef ^. defValues))+ preuse (scopes . ix scp . scopeDefaults . ix resType) >>= \case+ Nothing -> addDefaults newDefaults+ Just de -> if de ^. defSrcScope == scp+ then throwPosError ("Defaults for resource" <+> ttext resType <+> "already declared at" <+> showPPos (de ^. defPos))+ else addDefaults (mergedDefaults de)+ return []+evaluateStatement (ResourceOverride rt urn eargs p) = do+ curPos .= p+ raassignements <- vmapM resolveArgument eargs >>= fromArgumentList+ rn <- resolveExpressionString urn+ scp <- getScope+ curoverrides <- use (scopes . ix scp . scopeOverrides)+ let rident = RIdentifier rt rn+ withAssignements <- case curoverrides ^. at rident of+ Just (ResRefOverride _ prevass prevpos) -> do+ let cm = prevass `HM.intersection` raassignements+ unless (fnull cm) (throwPosError ("The following parameters were already overriden at" <+> showPPos prevpos <+> ":" <+> containerComma cm))+ return (prevass <> raassignements)+ Nothing -> return raassignements+ scopes . ix scp . scopeOverrides . at rident ?= ResRefOverride rident withAssignements p+ return []+evaluateStatement (SHFunctionCall c p) = curPos .= p >> evaluateHFC c+evaluateStatement r = throwError ("Do not know how to evaluate this statement:" <$> pretty r)++-----------------------------------------------------------+-- Class evaluation+-----------------------------------------------------------++loadVariable :: T.Text -> PValue -> InterpreterMonad ()+loadVariable varname varval = do+ curcont <- getCurContainer+ scp <- getScope+ p <- use curPos+ scopeDefined <- use (scopes . contains scp)+ variableDefined <- preuse (scopes . ix scp . scopeVariables . ix varname)+ case (scopeDefined, variableDefined) of+ (False, _) -> throwPosError ("Internal error: trying to save a variable in unknown scope" <+> ttext scp)+ (_, Just (_ :!: pp :!: ctx)) -> do+ isParent scp (curcont ^. cctype) >>= \case+ True -> do+ warn ("The variable"+ <+> pretty (UVariableReference varname)+ <+> "had been overriden because of some arbitrary inheritance rule that was set up to emulate puppet behaviour. It was defined at"+ <+> showPPos pp+ )+ scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype)+ False -> throwPosError ("Variable" <+> pretty (UVariableReference varname) <+> "already defined at" <+> showPPos pp+ </> "Context:" <+> pretty ctx+ </> "Value:" <+> pretty varval+ </> "Current scope:" <+> ttext scp+ )+ _ -> scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype)++loadParameters :: Foldable f => Container PValue -> f (Pair T.Text (S.Maybe Expression)) -> PPosition -> InterpreterMonad ()+loadParameters params classParams defaultPos = do+ let !classParamSet = HS.fromList (map S.fst (toList classParams))+ !mandatoryParamSet = HS.fromList (map S.fst (classParams ^.. folded . filtered (S.isNothing . S.snd)))+ !definedParamSet = ikeys params+ !unsetParams = mandatoryParamSet `HS.difference` definedParamSet+ !spuriousParams = definedParamSet `HS.difference` classParamSet+ unless (fnull unsetParams) $ throwPosError ("The following mandatory parameters where not set:" <+> tupled (map ttext $ toList unsetParams))+ unless (fnull spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ttext) $ toList spuriousParams))+ let isDefault = not . flip HS.member definedParamSet . S.fst+ mapM_ (uncurry loadVariable) (itoList params)+ curPos .= defaultPos+ forM_ (filter isDefault (toList classParams)) $ \(k :!: v) -> do+ rv <- case v of+ S.Nothing -> throwPosError "Internal error: invalid invariant at loadParameters"+ S.Just e -> resolveExpression e+ loadVariable k rv++-- | Enters a new scope, checks it is not already defined, and inherits the+-- defaults from the current scope+--+-- Inheriting the defaults is necessary for non native types, because they+-- will be expanded in "finalize", so if this was not done, we would be+-- expanding the defines without the defaults applied+enterScope :: S.Maybe T.Text -> CurContainerDesc -> InterpreterMonad T.Text+enterScope parent cont = do+ let scopename = case cont of+ ContRoot -> "::"+ ContImported -> "::"+ ContClass x -> x+ ContDefine dt dn -> "#define/" <> dt <> "/" <> dn+ scopeAlreadyDefined <- use (scopes . contains scopename)+ when scopeAlreadyDefined (throwPosError ("Internal error: scope already defined when loading scope for" <+> pretty cont))+ scp <- getScope+ -- TODO fill tags+ basescope <- case parent of+ S.Nothing -> do+ curdefs <- use (scopes . ix scp . scopeDefaults)+ return $ ScopeInformation mempty curdefs mempty (CurContainer cont mempty) mempty parent+ S.Just p -> do+ parentscope <- use (scopes . at p)+ when (isNothing parentscope) (throwPosError ("Internal error: could not find parent scope" <+> ttext p))+ let Just psc = parentscope+ return (psc & scopeParent .~ parent)+ scopes . at scopename ?= basescope+ return scopename++expandDefine :: Resource -> InterpreterMonad [Resource]+expandDefine r = do+ let deftype = r ^. rid . itype+ defname = r ^. rid . iname+ modulename = case T.splitOn "::" deftype of+ [] -> deftype+ (x:_) -> x+ curcaller <- resolveVariable "module_name"+ let curContType = ContDefine deftype defname+ scopename <- enterScope S.Nothing curContType+ (spurious, dls) <- getstt TopDefine deftype+ case dls of+ (DefineDeclaration _ defineParams stmts cp) -> do+ p <- use curPos+ curPos .= r ^. rpos+ pushScope scopename+ loadVariable "title" (PString defname)+ loadVariable "name" (PString defname)+ -- not done through loadvariable because of override+ -- errors+ scopes . ix scopename . scopeVariables . at "module_name" ?= (PString modulename :!: p :!: curContType)+ scopes . ix scopename . scopeVariables . at "callermodule_name" ?= (curcaller :!: p :!: curContType)+ loadParameters (r ^. rattributes) defineParams cp+ curPos .= cp+ res <- evaluateStatementsVector stmts+ out <- finalize (spurious ++ res)+ popScope+ return out+ _ -> throwPosError ("Internal error: we did not retrieve a DefineDeclaration, but had" <+> pretty dls)++loadClass :: T.Text+ -> Container PValue+ -> ClassIncludeType+ -> InterpreterMonad [Resource]+loadClass classname params cincludetype = do+ p <- use curPos+ -- check if the class has already been loaded+ -- http://docs.puppetlabs.com/puppet/3/reference/lang_classes.html#using-resource-like-declarations+ use (loadedClasses . at classname) >>= \case+ Just (_ :!: pp) -> do+ when (cincludetype == IncludeResource) (throwPosError ("Can't include class" <+> ttext classname <+> "twice when using the resource-like syntax (first occurance at" <+> showPPos pp <> ")"))+ return []+ -- already loaded, go on+ Nothing -> do+ loadedClasses . at classname ?= (cincludetype :!: p)+ -- load the actual class, note we are not changing the current position+ -- right now+ (spurious, cls) <- getstt TopClass classname+ case cls of+ (ClassDeclaration _ classParams inh stmts cp) -> do+ -- check if we need to define a resource representing the class+ -- This will be the case for the first standard include+ inhstmts <- case inh of+ S.Nothing -> return []+ S.Just ihname -> loadClass ihname mempty IncludeResource+ scopename <- enterScope inh (ContClass classname)+ classresource <- if cincludetype == IncludeStandard+ then do+ scp <- use curScope+ return [Resource (RIdentifier "class" classname) (HS.singleton classname) mempty mempty scp ContRoot Normal mempty p Nothing]+ else return []+ pushScope scopename+ let modulename = case T.splitOn "::" classname of+ [] -> classname+ (x:_) -> x+ -- not done through loadvariable because of override+ -- errors+ scopes . ix scopename . scopeVariables . at "module_name" ?= (PString modulename :!: p :!: ContClass classname)+ loadParameters params classParams cp+ curPos .= cp+ res <- evaluateStatementsVector stmts+ out <- finalize (classresource ++ spurious ++ inhstmts ++ res)+ popScope+ return out+ _ -> throwPosError ("Internal error: we did not retrieve a ClassDeclaration, but had" <+> pretty cls)+-----------------------------------------------------------+-- Resource stuff+-----------------------------------------------------------++addRelationship :: LinkType -> PValue -> Resource -> InterpreterMonad Resource+addRelationship lt (PResourceReference dt dn) r = return (r & rrelations %~ insertLt)+ where+ insertLt = iinsertWith (<>) (RIdentifier dt dn) (mempty & contains lt .~ True)+addRelationship lt (PArray vals) r = foldlM (flip (addRelationship lt)) r vals+addRelationship _ PUndef r = return r+addRelationship _ notrr _ = throwPosError ("Expected a resource reference, not:" <+> pretty notrr)++addTagResource :: Resource -> T.Text -> Resource+addTagResource r rv = r & rtags . contains rv .~ True++addAttribute :: OverrideType -> Resource -> (T.Text, PValue) -> InterpreterMonad Resource+addAttribute _ r ("alias", v) = fmap (\rv -> r & ralias . contains rv .~ True) (resolvePValueString v)+addAttribute _ r ("audit", _) = use curPos >>= \p -> warn ("Metaparameter audit ignored at" <+> showPPos p) >> return r+addAttribute _ r ("noop", _) = use curPos >>= \p -> warn ("Metaparameter noop ignored at" <+> showPPos p) >> return r+addAttribute _ r ("loglevel", _) = use curPos >>= \p -> warn ("Metaparameter loglevel ignored at" <+> showPPos p) >> return r+addAttribute _ r ("schedule", _) = use curPos >>= \p -> warn ("Metaparameter schedule ignored at" <+> showPPos p) >> return r+addAttribute _ r ("stage", _) = use curPos >>= \p -> warn ("Metaparameter stage ignored at" <+> showPPos p) >> return r+addAttribute _ r ("tag", PArray v) = foldM (\cr cv -> fmap (addTagResource cr) (resolvePValueString cv)) r (toList v)+addAttribute _ r ("tag", v) = fmap (addTagResource r) (resolvePValueString v)+addAttribute _ r ("before", d) = addRelationship RBefore d r+addAttribute _ r ("notify", d) = addRelationship RNotify d r+addAttribute _ r ("require", d) = addRelationship RRequire d r+addAttribute _ r ("subscribe", d) = addRelationship RSubscribe d r+addAttribute b r (t,v) = case (r ^. rattributes . at t, b) of+ (_, Replace) -> return (r & rattributes . at t ?~ v)+ (Nothing, _) -> return (r & rattributes . at t ?~ v)+ (_, CantReplace) -> return r+ _ -> do+ -- we must check if the resource scope is+ -- a parent of the current scope+ curscope <- getScope+ i <- isParent curscope (r ^. rcontainer)+ if i+ then return (r & rattributes . at t ?~ v)+ else throwPosError ("Attribute" <+> ttext t <+> "defined multiple times for" <+> pretty (r ^. rid) <+> showPPos (r ^. rpos))++registerResource :: T.Text -> T.Text -> Container PValue -> Virtuality -> PPosition -> InterpreterMonad [Resource]+registerResource "class" _ _ Virtual p = curPos .= p >> throwPosError "Cannot declare a virtual class (or perhaps you can, but I do not know what this means)"+registerResource "class" _ _ Exported p = curPos .= p >> throwPosError "Cannot declare an exported class (or perhaps you can, but I do not know what this means)"+registerResource rt rn arg vrt p = do+ curPos .= p+ CurContainer cnt tgs <- getCurContainer+ -- default tags+ -- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#automatic-tagging+ -- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#containment+ let !defaulttags = {-# SCC "rrGetTags" #-} HS.fromList (rt : classtags) <> tgs+ allsegs x = x : T.splitOn "::" x+ !classtags = case cnt of+ ContRoot -> []+ ContImported -> []+ ContClass cn -> allsegs cn+ ContDefine dt _ -> allsegs dt+ allScope <- use curScope+ let baseresource = Resource (RIdentifier rt rn) (HS.singleton rn) mempty mempty allScope cnt vrt defaulttags p Nothing+ r <- foldM (addAttribute CantOverride) baseresource (itoList arg)+ let resid = RIdentifier rt rn+ case rt of+ "class" -> {-# SCC "rrClass" #-} do+ definedResources . at resid ?= p+ fmap (r:) $ loadClass rn (r ^. rattributes) IncludeResource+ _ -> {-# SCC "rrGeneralCase" #-}+ use (definedResources . at resid) >>= \case+ Just apos -> throwPosError ("Resource" <+> pretty resid <+> "already defined at" <+> showPPos apos)+ Nothing -> do+ definedResources . at resid ?= p+ return [r]++-- A helper function for the various loggers+logWithModifier :: Priority -> (Doc -> Doc) -> [PValue] -> InterpreterMonad [Resource]+logWithModifier prio m [t] = do+ p <- use curPos+ rt <- resolvePValueString t+ logWriter prio (m (ttext rt) <+> showPPos p)+ return []+logWithModifier _ _ _ = throwPosError "This function takes a single argument"++-- functions : this can't really be exported as it uses a lot of stuff from+-- this module ...+mainFunctionCall :: T.Text -> [PValue] -> InterpreterMonad [Resource]+mainFunctionCall "showscope" _ = use curScope >>= warn . list . map ttext >> return []+-- The logging functions+mainFunctionCall "alert" a = logWithModifier ALERT red a+mainFunctionCall "crit" a = logWithModifier CRITICAL red a+mainFunctionCall "debug" a = logWithModifier DEBUG dullwhite a+mainFunctionCall "emerg" a = logWithModifier EMERGENCY red a+mainFunctionCall "err" a = logWithModifier ERROR dullred a+mainFunctionCall "info" a = logWithModifier INFO green a+mainFunctionCall "notice" a = logWithModifier NOTICE white a+mainFunctionCall "warning" a = logWithModifier WARNING dullyellow a+mainFunctionCall "include" includes =+ fmap concat $ forM includes $ \e -> do+ classname <- resolvePValueString e+ loadClass classname mempty IncludeStandard+mainFunctionCall "create_resources" [rtype, hs] = mainFunctionCall "create_resources" [rtype, hs, PHash mempty]+mainFunctionCall "create_resources" [PString rtype, PHash hs, PHash defs] = do+ p <- use curPos+ let genRes (rname, PHash rargs) = registerResource rtype rname (rargs <> defs) Normal p+ genRes (rname, x) = throwPosError ("create_resource(): the value corresponding to key" <+> ttext rname <+> "should be a hash, not" <+> pretty x)+ fmap concat (mapM genRes (itoList hs))+mainFunctionCall "create_resources" args = throwPosError ("create_resource(): expects between two and three arguments, of type [string,hash,hash], and not:" <+> pretty args)+mainFunctionCall "realize" args = do+ p <- use curPos+ let realiz (PResourceReference rt rn) = resMod %= (ResourceModifier rt ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) return p : )+ realiz x = throwPosError ("realize(): all arguments must be resource references, not" <+> pretty x)+ mapM_ realiz args >> return []+mainFunctionCall "tag" args = do+ scp <- getScope+ let addTag x = scopes . ix scp . scopeExtraTags . contains x .= True+ mapM_ (resolvePValueString >=> addTag) args+ return []+mainFunctionCall "fail" [x] = fmap (("fail:" <+>) . dullred . ttext) (resolvePValueString x) >>= throwPosError+mainFunctionCall "fail" _ = throwPosError "fail(): This function takes a single argument"+mainFunctionCall fname args = do+ p <- use curPos+ let representation = MainFunctionCall fname mempty p+ external <- view externalFunctions+ rs <- case external ^. at fname of+ Just f -> f args+ Nothing -> throwPosError ("Unknown function:" <+> pretty representation)+ unless (rs == PUndef) $ throwPosError ("This function call should return" <+> pretty PUndef <+> "and not" <+> pretty rs <$> pretty representation)+ return []++-- Method stuff++evaluateHFC :: HFunctionCall -> InterpreterMonad [Resource]+evaluateHFC hf = do+ varassocs <- hfGenerateAssociations hf+ let runblock :: [(T.Text, PValue)] -> InterpreterMonad [Resource]+ runblock assocs = do+ saved <- hfSetvars assocs+ res <- evaluateStatementsVector (hf ^. hfstatements)+ hfRestorevars saved+ return res+ results <- mapM runblock varassocs+ return (concat results)
− Puppet/Interpreter/Catalog.hs
@@ -1,1448 +0,0 @@-{-| 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-extremely vague. It might be possible to delve into the source code or to write-tests, but ruby is unreadable and tests are boring.--Here is a list of known discrepencies with Puppet :--* Resources references using the \<| |\> syntax are not yet supported.--* Things defined in classes that are not included cannot be accessed. In vanilla-puppet, you can use subclass to classes that are not imported themselves.--* Amending attributes with a reference will not cause an error when done out of-an inherited class.--* Variables $0 to $9, set after regexp matching, are not handled.--* Tags work like regular parameters, and are not automatically populated or inherited.--* Modules, nodes, classes and type names starting with _ are allowed.--* Arrows between resource declarations or collectors are not yet handled.--* Reversed form arrows are not handled.--* Node inheritance is not handled, and class inheritance seems to work well,-but is probably not Puppet-perfect.---}-module Puppet.Interpreter.Catalog (- getCatalog- ) where--import Puppet.DSL.Types-import Puppet.Interpreter.Functions-import Puppet.Interpreter.Types-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 Data.List-import Data.Char (isAlpha, isAlphaNum)-import Data.Maybe (isJust, fromJust, catMaybes, isNothing, fromMaybe)-import Data.Either (lefts, rights, partitionEithers)-import Data.Ord (comparing)-import Text.Parsec.Pos-import Control.Monad.State-import Control.Monad.Error-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.Traversable as DT-import qualified Data.Graph as Graph-import qualified Data.Tree as Tree-import qualified Data.Text as T-import Control.Lens--qualified :: T.Text -> Bool-qualified = T.isInfixOf "::"---- Int handling stuff-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 -> T.Text -> IO (Either String Statement))- -- ^ The \"get statements\" function. Given a top level type and its name it- -- should return the corresponding statement.- -> (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.- -> (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- -- JSON value, or some error.- -> T.Text -- ^ Name of the node.- -> Facts -- ^ Facts of this node.- -> 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), [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 (first Just) (initLua m)- Nothing -> return (Nothing, [])- (!output, !finalstate) <- runStateT ( runErrorT ( computeCatalog getstatements nodename ) )- ScopeState- { _curScope = [["::"]]- , _curVariables = convertedfacts- , _curClasses = Map.empty- , _curDefaults = Map.empty- , _curResId = 1- , _curPos = (initialPos "dummy")- , _nestedtoplevels = Map.empty- , _getStatementsFunction = getstatements- , _getWarnings = []- , _curCollect = []- , _unresolvedRels = []- , _computeTemplateFunction = gettemplate- , _puppetDBFunction = puppetdb- , _luaState = luastate- , _userFunctions = Set.fromList userfunctions- , _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 (T.unpack x), finalstate ^. getWarnings)- Right x -> return (Right x, finalstate ^. getWarnings)--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 (T.pack x)- Right nodestmts -> evaluateStatements nodestmts >>= finalResolution--resolveResource :: CResource -> CatalogMonad (ResIdentifier, RResource)-resolveResource cr@(CResource cid cname ctype cparams _ scopes cpos) = do- curPos .= 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 scopes cpos- return ((ctype, rname), prefinalresource)---- this validates the resolved resources--- it should only be called with native types or the validatefunction lookup with abord with an error-finalizeResource :: CResource -> CatalogMonad (ResIdentifier, RResource)-finalizeResource cr = do- ((_, 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)- curPos .= cpos- ntypes <- use nativeTypes- 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 -> 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--- resource, the resource with a "normal" virtuality, or both,--- for exported resources (so that they can still be found as collected)-collectionChecks :: CResource -> CatalogMonad [CResource]-collectionChecks res =- if res ^. crvirtuality == Normal- then return [res]- else do- -- Note that amending attributes with a collector does collect virtual- -- values. Hence no filtering on the collectors is done here.- isCollected <- use curCollect >>= mapM (`_colFunction` res)- case (or isCollected, res ^. crvirtuality) of- (True, Exported) -> return [res & crvirtuality .~ Normal, res]- (True, _) -> return [res & crvirtuality .~ Normal ]- (False, _) -> return [res ]--processOverride :: CResource -> Map.Map T.Text ResolvedValue -> CatalogMonad (Map.Map T.Text ResolvedValue)-processOverride cr prms =- let applyOverride :: CResource -> Map.Map T.Text ResolvedValue -> CollectionFunction -> CatalogMonad (Map.Map T.Text ResolvedValue)- -- this checks if the collection function matches- applyOverride c prm colf = do- check <- (colf ^. colFunction) c- if check- then foldM tryReplace prm (Map.toList (colf^.colOverrides))- else return prm- 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- rs <- resolveGeneralString gs- rv <- resolveGeneralValue gv- return $ Map.insert rs rv curmap- -- Collectors are filtered so that only those with overrides are passed to the fold.- in use curCollect >>= foldlMOf (traversed.filtered (has (colOverrides.each))) (applyOverride cr) prms--retrieveRemoteResources :: (PDB.Query -> IO (Either String [CResource])) -> PDB.Query -> CatalogMonad [CResource]-retrieveRemoteResources f q = do- res <- liftIO $ f q- case res of- Right h -> return h- Left err -> throwError $ "PuppetDB error: " <> T.pack err--extractRelations :: CResource -> CatalogMonad CResource-extractRelations cr = do- curPos .= cr ^. pos- (params, relations) <- partitionParamsRelations (cr ^. crparams)- addUnresRel (relations, (cr ^. crtype, cr ^. crname), UNormal, cr ^. pos, cr ^. crscope)- return (cr & crparams .~ params)---- resolves a single relationship-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- resolveGeneralValue udname >>= rstrings >>= mapM (\dname -> return (ltype, (dtype, dname)))- dsts <- fmap concat (mapM resolveSrcRel udsts)- sname <- resolveGeneralString usname- return (dsts, (stype, sname), uptype, spos, scop)---- this does all the relation stuff-finalizeRelations :: FinalCatalog -> FinalCatalog -> CatalogMonad (FinalCatalog, EdgeMap)-finalizeRelations exported cat = do- grels <- use unresolvedRels >>= mapM resolveRelationship- drs <- use definedResources- let extr :: ([(LinkType, ResIdentifier)], ResIdentifier, RelUpdateType, SourcePos, [[ScopeName]])- -> [(ResIdentifier, ResIdentifier, LinkInfo)]- extr (dsts, src, rutype, spos, scp) = do- (ltype, dst) <- dsts- 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,!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,lscope))- RBefore -> return $ Just (dst, src, (RRequire , lutype,lpos,lscope))- _ -> return (Just o)- (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] -> T.Text- describe [] = "[]"- describe x = let rx = map (\i -> (i, drs Map.! i)) x- 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" <> T.intercalate "\n\t" (map describe cycles)---finalResolution :: Catalog -> CatalogMonad (FinalCatalog, EdgeMap, FinalCatalog)-finalResolution cat = do- pdbfunction <- use puppetDBFunction- fqdnr <- getVariable "::fqdn"- collectedRemote <- do- fqdn <- case fqdnr of- Just (Right (ResolvedString f'), _) -> return f'- _ -> throwError "Could not get FQDN during final resolution"- remoteCollects <- fmap (toListOf (traversed . colQuery . _Just)) (use curCollect)- let- isNotLocal :: CResource -> Bool- isNotLocal cr = case cr ^. crparams . at (Right "EXPORTEDSOURCE") 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 = cr ^. crtype- rname <- resolveGeneralString (cr ^. crname)- isdef <- checkDefine rtype- case isdef of- Just _ -> addDefinedResource (rtype, rname) (cr ^. pos)- Nothing -> return ()- collectedRemote' <- mapM extractRelations collectedRemote- 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 (Right (ResolvedArray [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 (x ^. crname)- mapM_ addCollectedRemoteResource collectedRemoteD- let collected = collectedLocalD ++ collectedRemoteD- (real, allvirtual) = partition (( == Normal) . _crvirtuality) collected- (_, exported) = partition (( == Virtual) . _crvirtuality) allvirtual- rexported <- mapM resolveResource exported- let !exportMap = Map.fromList rexported- -- TODO- --export stuff- --liftIO $ putStrLn "EXPORTED:" - --liftIO $ mapM print exported- --get >>= return . unresolvedRels >>= liftIO . (mapM print)- (fc, em) <- mapM finalizeResource real >>= createResourceMap >>= finalizeRelations exportMap- return (fc, em, exportMap)--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 " <> 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 -> T.Text -> CatalogMonad Statement-getstatement qtype name = do- stmtsfunc <- use getStatementsFunction- estatement <- liftIO $ stmtsfunc qtype name- case estatement of- Left x -> throwPosError (T.pack x)- Right y -> return y---- State alteration functions--pushDefaults :: ResDefaults -> CatalogMonad ()-pushDefaults d = do- curscope <- use ( curScope . _head )- curDefaults %= Map.insertWith (++) curscope [d]--emptyDefaults :: CatalogMonad ()-emptyDefaults = do- curscope <- use ( curScope . _head )- curDefaults %= Map.delete curscope--getCurDefaults :: CatalogMonad [ResDefaults]-getCurDefaults = do- curscope <- use ( curScope . _head )- use ( curDefaults . at curscope . each )--pushDependency :: ResIdentifier -> CatalogMonad ()-pushDependency x = currentDependencyStack %= cons x--popDependency :: CatalogMonad ()-popDependency = currentDependencyStack %= tail--pushScope :: [ScopeName] -> CatalogMonad ()-pushScope x = curScope %= cons x--popScope :: CatalogMonad ()-popScope = curScope %= tail--getScope :: CatalogMonad [T.Text]-getScope = do- scope <- use curScope- if null scope- then throwError "empty scope, shouldn't happen"- else return $ head scope-addLoaded :: T.Text -> SourcePos -> CatalogMonad ()-addLoaded name p = curClasses.at name ?= p-getNextId :: CatalogMonad Int-getNextId = do- curResId += 1- use curResId---- qualifies a variable k depending on the context cs-qualify :: T.Text -> T.Text -> T.Text-qualify k cs | qualified k || (cs == "::") = cs <> k- | otherwise = cs <> "::" <> k---- It adds the variable to all the scopes that are currently active.-putVariable :: T.Text -> (GeneralValue, SourcePos) -> CatalogMonad ()-putVariable k v = getScope- >>= mapM_ (\x -> do- let q = qualify k x- defined <- use (curVariables.at q)- case defined of- Just nv -> throwPosError ("Variable $" <> k <> " already defined at " <> tshow nv)- Nothing -> curVariables.at (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 <- use curPos- curVariables.at "::caller_module_name" ?= (Right (ResolvedString modulename), cpos)--getVariable :: T.Text -> CatalogMonad (Maybe (GeneralValue, SourcePos))-getVariable vname = use (curVariables . at vname)---- BUG TODO : top levels are qualified only with the head of the scopes-addNestedTopLevel :: TopLevelType -> T.Text -> Statement -> CatalogMonad ()-addNestedTopLevel rtype rname rstatement = do- curscope <- use (curScope . _head . _head)- let nname = qualify rname curscope- nstatement = case rstatement of- DefineDeclaration _ prms stms cpos -> DefineDeclaration nname prms stms cpos- ClassDeclaration _ inhe prms stms cpos -> ClassDeclaration nname inhe prms stms cpos- x -> x- nestedtoplevels . at (rtype, nname) ?= nstatement--addWarning :: T.Text -> CatalogMonad ()-addWarning x = getWarnings %= cons x--addCollect :: ((CResource -> CatalogMonad Bool, Maybe PDB.Query), Map.Map GeneralString GeneralValue) -> CatalogMonad ()-addCollect ((func, query), overrides) = curCollect %= cons (CollectionFunction func overrides query)---- this pushes the relations only if they exist--- the parameter is of the form--- ( [dstrelations], srcresource, type, pos )-addUnresRel :: ([(LinkType, GeneralValue, GeneralValue)], (T.Text, GeneralString), RelUpdateType, SourcePos, [[ScopeName]]) -> CatalogMonad ()-addUnresRel ncol@(rels, _, _, _, _) = unless (null rels) (unresolvedRels %= cons ncol)---- finds out if a resource name refers to a define-checkDefine :: T.Text -> CatalogMonad (Maybe Statement)-checkDefine dname = use (nativeTypes . contains dname) >>= \nt -> if nt- then return Nothing- else do- check <- use (nestedtoplevels . at (TopDefine, dname))- getsmts <- use getStatementsFunction- case check of- Nothing -> do- def1 <- liftIO $ getsmts TopDefine dname- case def1 of- Left err -> throwPosError ("Could not find the definition of " <> dname <> " err = " <> T.pack err)- Right s -> return $ Just s- x -> return x--{--Partition parameters between those that are actual parameters and those that define relationships.--Those that define relationship must be properly resolved or hell will break loose. This is a BUG.--}-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 = fmap isJust (use (curClasses . at name))---- function that takes a pair of Expressions and try to resolve the first as a string, the second as a generalvalue-resolveParams :: (Expression, Expression) -> CatalogMonad (GeneralString, GeneralValue)-resolveParams (a,b) = do- ra <- tryResolveExpressionString a- rb <- tryResolveExpression b- return (ra, rb)---- safely insert parameters, checking they are not already defined-addParameters :: Map.Map GeneralString GeneralValue -> [(Expression, Expression)] -> CatalogMonad (Map.Map GeneralString GeneralValue)-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 " <> tshow k <> " had been declared twice!"- Nothing -> return (Map.insert k v curmap)---- apply default values to a resource-applyDefaults :: CResource -> CatalogMonad CResource-applyDefaults res = getCurDefaults >>= foldM applyDefaults' res--applyDefaults' :: CResource -> ResDefaults -> CatalogMonad CResource-applyDefaults' r@(CResource i rname rtype rparams rvirtuality scopes rpos) (RDefaults dtype rdefs _) =- let nparams = mergeParams rparams rdefs False- 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- 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 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- evaluateDefineDeclaration dtype args dstmts dpos = do- 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)- let expr = Right (ResolvedString rexpr)- defineparamset = Set.fromList $ map fst args- mandatoryparams = Set.fromList $ map fst $ filter (isNothing . snd) args- resourceparamset = Map.keysSet mparams- extraparams = Set.difference resourceparamset (defineparamset `Set.union` metaparameters)- unsetparams = Set.difference mandatoryparams resourceparamset- 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-- curPos .= dpos- setModuleName dtype- -- parse statements- res <- mapM evaluateStatements dstmts- nres <- handleDelayedActions (concat res)- popDependency- popScope- return nres- in do- curPos .= rpos- isdef <- checkDefine rtype- case (rvirtuality, isdef) of- (Normal, Just (TopContainer topstmts (DefineDeclaration dtype args dstmts dpos))) -> do- mapM_ (\(n,x) -> evaluateClass x Map.empty (Just n)) topstmts- evaluateDefineDeclaration dtype args dstmts dpos- (Normal, Just (DefineDeclaration dtype args dstmts dpos)) -> evaluateDefineDeclaration dtype args dstmts dpos- _ -> return [r]----- handling delayed actions (such as defaults and define resolution)-handleDelayedActions :: Catalog -> CatalogMonad Catalog-handleDelayedActions res = do- dres <- liftM concat (mapM applyDefaults res >>= mapM evaluateDefine)- emptyDefaults- return dres--addResource :: T.Text -> [(Expression, Expression)] -> Virtuality -> SourcePos -> GeneralValue -> CatalogMonad [CResource]-addResource rtype parameters virtuality position grname = do- resid <- getNextId- rparameters <- addParameters Map.empty parameters- case grname of- Right e -> do- rse <- rstring e- curpos <- use curPos- 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) <- gets (head . _currentDependencyStack) -- LIENS- let defaultdependency = (RRequire, Right (ResolvedString curdeptype), Right (ResolvedString curdepname))- scopes <- use curScope- 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-evaluateStatements (Node _ stmts position) = do- curPos .= position- res <- mapM evaluateStatements stmts- handleDelayedActions (concat res)---- include-evaluateStatements (Include includename position) = curPos .= position >> resolveExpressionString includename >>= getstatement TopClass >>= \st -> evaluateClass st Map.empty Nothing-evaluateStatements x@(ClassDeclaration cname _ _ _ _) = do- addNestedTopLevel TopClass cname x- return []-evaluateStatements n@(DefineDeclaration dtype _ _ _) = do- addNestedTopLevel TopDefine dtype n- return []-evaluateStatements (ConditionalStatement exprs position) = do- curPos .= position- trues <- filterM (\(expr, _) -> resolveBoolean (Left expr)) exprs- case trues of- ((_,stmts):_) -> liftM concat (mapM evaluateStatements stmts)- _ -> return []--evaluateStatements (Resource rtype rname parameters virtuality position) = do- curPos .= position- case rtype of- -- checks whether we are handling a parametrized class- "class" -> do- 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 T.Text (GeneralValue, SourcePos)- evaluateClass topstatement classparameters Nothing- _ -> do- srname <- tryResolveExpression rname- case srname of- (Right (ResolvedArray arr)) -> fmap concat (mapM (addResource rtype parameters virtuality position . Right) arr)- _ -> addResource rtype parameters virtuality position srname--evaluateStatements (ResourceDefault rdtype rdparams rdpos) = do- rrdparams <- addParameters Map.empty rdparams- pushDefaults $ RDefaults rdtype rrdparams rdpos- return []-evaluateStatements (ResourceOverride rotype roname roparams ropos) = do- rroname <- tryResolveExpressionString roname- rroparams <- addParameters Map.empty roparams- pushDefaults $ ROverride rotype rroname rroparams ropos- return []-evaluateStatements (DependenceChain (srctype, srcname) (dsttype, dstname) position) = do- curPos .= position- gdstname <- tryResolveExpression dstname- gsrcname <- tryResolveExpressionString srcname- scp <- use curScope- addUnresRel ( [(RRequire, Right $ ResolvedString dsttype, gdstname)], (srctype, gsrcname), UPlus, position, scp)- return []--- <<| |>>-evaluateStatements (ResourceCollection rtype expr overrides position) = do- curPos .= position- unless (null overrides) $ throwPosError "Amending attributes with a Collector only works with <| |>, not <<| |>>."- func <- collectFunction Exported rtype expr- addCollect (func, Map.empty)- return []--- <| |>--- TODO : check that this is a native type when overrides are defined.--- The behaviour is not explained in the documentation, so I won't support it.-evaluateStatements (VirtualResourceCollection rtype expr overrides position) = do- curPos .= position- func <- collectFunction Virtual rtype expr- prms <- addParameters Map.empty overrides- addCollect (func, prms)- return []--evaluateStatements (VariableAssignment vname vexpr position) = do- curPos .= position- rvexpr <- tryResolveExpression vexpr- putVariable vname (rvexpr, position)- return []--evaluateStatements (MainFunctionCall fname fargs position) = do- curPos .= position- rargs <- mapM resolveExpression fargs- executeFunction fname rargs--evaluateStatements (TopContainer toplevels curstatement) = do- mapM_ (\(fname, stmt) -> evaluateClass stmt Map.empty (Just fname)) toplevels- evaluateStatements curstatement--evaluateStatements x = throwError ("Can't evaluate " <> tshow x)---- function used to load defines / class variables into the global context-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 " <> tshow position- rv <- tryResolveGeneralValue v- putVariable paramname (rv, vpos)- return (paramname, rv)---- class--- ClassDeclaration String (Maybe String) [(String, Maybe Expression)] [Statement] SourcePos--- nom, heritage, parametres, contenu-evaluateClass :: Statement -> Map.Map T.Text (GeneralValue, SourcePos) -> Maybe T.Text -> CatalogMonad Catalog-evaluateClass (ClassDeclaration classname inherits parameters statements position) inputparams actualname = do- isloaded <- checkLoaded (fromMaybe classname actualname)- if isloaded- then return []- else do- oldpos <- use curPos -- saves where we were at class declaration so that we known were the class was included- addDefinedResource ("class", classname) oldpos- -- detection of spurious parameters- let classparamset = Set.fromList $ map fst parameters- 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 " <> 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- 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- curPos .= 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- Just parentclass -> do- mystatement <- getstatement TopClass parentclass- case mystatement of- ClassDeclaration _ ni np ns no -> evaluateClass (ClassDeclaration classname ni np ns no) Map.empty (Just parentclass)- _ -> throwError "Should not happen : TopClass return something else than a ClassDeclaration in evaluateClass"- Nothing -> return []- addLoaded (fromMaybe classname actualname) oldpos-- -- parse statements- res <- mapM evaluateStatements statements- nres <- handleDelayedActions (concat res)- mapM_ (addClassDependency classname) nres -- this adds a dummy dependency to this class- -- 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 <- use curScope- popScope- popDependency- return $- [CResource resid (Right classname) "class" (Map.fromList $ map (first Right) mparameters) Normal scopes position]- ++ inherited- ++ nres--evaluateClass (TopContainer topstmts myclass) inputparams actualname = do- mapM_ (\(n,x) -> evaluateClass x Map.empty (Just n)) topstmts- evaluateClass myclass inputparams actualname--evaluateClass x _ _ = throwError ("Someone managed to run evaluateClass against " <> tshow x)--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--tryResolveGeneralValue :: GeneralValue -> CatalogMonad GeneralValue-tryResolveGeneralValue n@(Right _) = return n-tryResolveGeneralValue (Left BTrue) = return $ Right $ ResolvedBool True-tryResolveGeneralValue (Left BFalse) = return $ Right $ ResolvedBool False-tryResolveGeneralValue (Left (Value x)) = tryResolveValue x-tryResolveGeneralValue n@(Left (ResolvedResourceReference _ _)) = return n-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 " <> 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]-tryResolveGeneralValue n@(Left (AboveOperation a b)) = compareGeneralValue n a b [GT]-tryResolveGeneralValue n@(Left (UnderEqualOperation a b)) = compareGeneralValue n a b [LT,EQ]-tryResolveGeneralValue n@(Left (UnderOperation a b)) = compareGeneralValue n a b [LT]-tryResolveGeneralValue n@(Left (DifferentOperation a b)) = compareGeneralValue n a b [LT,GT]-tryResolveGeneralValue n@(Left (RegexpOperation a b)) = do- ra <- tryResolveExpression a- rb <- tryResolveExpression b- case (ra, rb) of- (Right (ResolvedString src), Right (ResolvedRegexp reg)) -> do- m <- liftIO $ regmatch src reg- case m of- Right x -> return $ Right $ ResolvedBool x- Left err -> throwPosError $ "Error with regexp " <> 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)- then return $ Right $ ResolvedBool True- else do- rb <- tryResolveBoolean $ Left b- case (ra, rb) of- (_, Right (ResolvedBool True)) -> return $ Right $ ResolvedBool True- (Right (ResolvedBool rra), Right (ResolvedBool rrb)) -> return $ Right $ ResolvedBool $ rra || rrb- _ -> return n-tryResolveGeneralValue n@(Left (AndOperation a b)) = do- ra <- tryResolveBoolean $ Left a- if ra == Right (ResolvedBool False)- then return $ Right $ ResolvedBool False- else do- rb <- tryResolveBoolean $ Left b- case (ra, rb) of- (_, Right (ResolvedBool False)) -> return $ Right $ ResolvedBool False- (Right (ResolvedBool rra), Right (ResolvedBool rrb)) -> return $ Right $ ResolvedBool $ rra && rrb- _ -> return n-tryResolveGeneralValue (Left (NotOperation x)) = do- rx <- tryResolveBoolean $ Left x- case rx of- Right (ResolvedBool b) -> return $ Right $ ResolvedBool $ not b- _ -> return rx-tryResolveGeneralValue (Left (LookupOperation a b)) = do- ra <- tryResolveExpression a- rb <- tryResolveExpressionString b- case (ra, rb) of- (Right (ResolvedArray ar), Right num) -> do- bnum <- readint num- let nnum = fromIntegral bnum- if length ar <= nnum- then throwPosError ("Invalid array index " <> num <> " " <> tshow ar)- else return $ Right (ar !! nnum)- (Right (ResolvedHash ar), Right idx) -> do- let filterd = filter (\(x,_) -> x == idx) ar- case filterd of- [] -> do- getWarnings <>= ["Cannot find index " <> tshow rb <> " in " <> tshow ra]- return $ Right ResolvedUndefined- [(_,x)] -> return $ Right x- x -> return $ Right $ snd $ last 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) ->- let filterd = filter (compareRValues (ResolvedString idx)) ar- in return $! Right $! ResolvedBool $! not $! null filterd- (Right (ResolvedHash h), Right idx) ->- let filterd = filter (\(fa,_) -> fa == idx) h- in return $! Right $! ResolvedBool $! not $! null filterd- (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 " <> 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-tryResolveGeneralValue o@(Left (MinusOperation a b)) = arithmeticOperation a b (-) (-) o-tryResolveGeneralValue o@(Left (DivOperation a b)) = arithmeticOperation a b div (/) o-tryResolveGeneralValue o@(Left (MultiplyOperation a b)) = arithmeticOperation a b (*) (*) o--tryResolveGeneralValue e = throwPosError ("tryResolveGeneralValue not implemented for " <> tshow e)--resolveGeneralValue :: GeneralValue -> CatalogMonad ResolvedValue-resolveGeneralValue e = do- x <- tryResolveGeneralValue e- case x of- Left n -> throwPosError ("Could not resolveGeneralValue " <> tshow n)- Right p -> return p--tryResolveExpressionString :: Expression -> CatalogMonad GeneralString-tryResolveExpressionString s = do- resolved <- tryResolveExpression s- case resolved of- Right e -> liftM Right (rstring e)- Left e -> return $ Left e--rstring :: ResolvedValue -> CatalogMonad T.Text-rstring resolved = case resolved of- ResolvedString s -> return s- 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- resolved <- tryResolveExpression e- case resolved of- Right r -> return r- Left x -> do- p <- use curPos- throwError ("Can't resolve expression '" <> tshow x <> "' at " <> tshow p <> " was '" <> tshow e <> "'")--resolveExpressionString :: Expression -> CatalogMonad T.Text-resolveExpressionString x = do- resolved <- resolveExpression x- case resolved of- ResolvedString s -> return s- ResolvedInt i -> return (tshow i)- e -> do- p <- use curPos- 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- case rvals of- Right resolved -> return $ Right $ ResolvedRReference rtype resolved- _ -> return $ Left $ Value n--- special variables first-tryResolveValue (VariableReference "module_name") = liftM (\x ->- 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- varnames = concatMap gvarnm curscp- remtopscope x | T.isPrefixOf "::" x = [T.drop 2 x]- | otherwise = []- matching <- liftM catMaybes (mapM getVariable varnames)- if null matching- then do- position <- use curPos- addWarning ("Could not resolveValue variables " <> tshow varnames <> " at " <> tshow position)- return $ Left $ Value $ VariableReference (head varnames)- else return $ case head matching of- (x,_) -> x--tryResolveValue (Interpolable x) = do- resolved <- mapM tryResolveValueString x- if null $ lefts 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)- (mapM tryResolveValue x >>= mapM generalValue2Value)--tryResolveValue n@(PuppetHash (Parameters x)) = do- resolvedKeys <- mapM (tryResolveExpressionString . fst) x- resolvedValues <- mapM (tryResolveExpression . snd) x- 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- return $ if null $ lefts resolvedExpressions- then Right $ ResolvedArray $ rights resolvedExpressions- else Left $ Value n---tryResolveValue (FunctionCall "generate" args) = if null args- then throwPosError "Empty argument list in generate"- else do- nargs <- mapM resolveExpressionString args- let cmdname:cmdargs = nargs- gens <- liftIO $ generate cmdname cmdargs- case gens of- Just w -> return $ Right $ ResolvedString w- Nothing -> throwPosError $ "Function call generate for command " <> cmdname <> " (" <> tshow cmdargs <> ") failed"--tryResolveValue (FunctionCall "values" [x]) = do- rx <- tryResolveExpression x- case rx of- Right (ResolvedHash h) -> return (Right (ResolvedArray (map snd h)))- Right z -> throwPosError ("The values function works on arrays, not " <> tshow z)- Left l -> return (Left (Value (FunctionCall "values" [l])))-tryResolveValue (FunctionCall "values" args) = throwPosError ("The values function online takes a single argument, not " <> tshow (length args))-tryResolveValue (FunctionCall "keys" [x]) = do- rx <- tryResolveExpression x- case rx of- Right (ResolvedHash h) -> return (Right (ResolvedArray (map (ResolvedString . fst) h)))- Right z -> throwPosError ("The keys function works on arrays, not " <> tshow z)- Left l -> return (Left (Value (FunctionCall "keys" [l])))-tryResolveValue (FunctionCall "keys" args) = throwPosError ("The keys function online takes a single argument, not " <> tshow (length args))--tryResolveValue n@(FunctionCall "pdbresourcequery" (query:xs)) = do- 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 opr -> fmap (PDB.Query opr) (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 = 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) = 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--tryResolveValue (FunctionCall "fqdn_rand" args) = if null args- then throwPosError "Empty argument list in fqdn_rand call"- else do- nargs <- mapM resolveExpressionString args- curmax <- readint (head 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- es <- tryResolveExpressionString (head args)- case es of- Right s -> liftM (Right . ResolvedString) (mysql_password s)- Left u -> return $ Left u-tryResolveValue (FunctionCall "template" [name]) = do- fname <- tryResolveExpressionString name- case fname of- Left x -> throwPosError $ "Can't resolve template path " <> tshow x- Right filename -> do- vars <- use curVariables >>= DT.mapM (\(v,p) -> fmap (\x -> (x,p)) (tryResolveGeneralValue v))- curVariables .= vars- scp <- fmap head getScope -- TODO check if that sucks- templatefunc <- use computeTemplateFunction- out <- liftIO (templatefunc (Right filename) scp (Map.map fst vars))- case out of- Right x -> return $ Right $ ResolvedString x- 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 <- use curVariables >>= DT.mapM (\(v,p) -> fmap (\x -> (x,p)) (tryResolveGeneralValue v))- curVariables .= vars- scp <- fmap head getScope -- TODO check if that sucks- templatefunc <- use computeTemplateFunction- 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- Left n -> return $ Left n- -- TODO BUG- Right (ResolvedString typeorclass) -> do- ntypes <- use nativeTypes- -- is it a loaded class or a define ?- if Map.member typeorclass ntypes- then return $ Right $ ResolvedBool True- else do- isdefine <- checkDefine typeorclass- case isdefine of- Just _ -> return $ Right $ ResolvedBool True- Nothing -> gets (Right . ResolvedBool . Map.member typeorclass . _curClasses)- Right (ResolvedRReference rtype (ResolvedString rname)) -> do- defset <- use definedResources- return $ Right $ ResolvedBool (Map.member (rtype, rname) defset)- 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- rdst <- tryResolveExpressionString dst- rflags <- tryResolveExpressionString flags- case (rstr, rsrc, rdst, rflags) of- (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 " <> tshow args)--tryResolveValue n@(FunctionCall "chomp" [str]) = do- 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- Right (ResolvedArray arr) -> fmap (Right . ResolvedArray) (mapM mmychomp arr)- Right x -> fmap Right (mmychomp x)--tryResolveValue n@(FunctionCall "split" [str, reg]) = do- rstr <- tryResolveExpressionString str- rreg <- tryResolveExpressionString reg- case (rstr, rreg) of- (Right sstr, Right sreg) -> do- sp <- liftIO $ puppetSplit sstr sreg- case sp of- Right o -> return $ Right $ ResolvedArray $ map ResolvedString o- Left r -> throwPosError $ "split error: " <> tshow r- _ -> return $ Left $ Value n-tryResolveValue (FunctionCall "split" _) = throwPosError "Bad argument count for function split"-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--tryResolveValue n@(FunctionCall "versioncmp" [a,b]) = do- ra <- tryResolveExpressionString a- rb <- tryResolveExpressionString b- case (ra, rb) of- (Right sa, Right sb) -> return $ Right $ ResolvedInt (versioncmp sa sb)- _ -> return $ Left $ Value n-tryResolveValue n@(FunctionCall "file" filelist) = do- -- resolving the list of file pathes- rfilelist <- mapM tryResolveExpressionString filelist- let (lf, rf) = partitionEithers rfilelist- if null lf- then do- content <- liftIO $ file rf- case content of- 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 <- use userFunctions- l <- use luaState- case (l, Set.member fname ufunctions) of- (Just ls, True) -> do- rargs <- mapM tryResolveExpression args- if null (lefts rargs)- then fmap Right (puppetFunc ls fname (rights rargs))- else return $ Left $ Value n- _ -> throwPosError ("FunctionCall " <> fname <> " not implemented")--tryResolveValue Undefined = return $ Right ResolvedUndefined-tryResolveValue (PuppetRegexp x) = return $ Right $ ResolvedRegexp 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 (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-getRelationParameterType (Right "notify" ) = Just RNotify-getRelationParameterType (Right "before" ) = Just RBefore-getRelationParameterType (Right "subscribe") = Just RSubscribe-getRelationParameterType _ = Nothing---- this function saves a new condition for collection-pushRealize :: ResolvedValue -> CatalogMonad ()-pushRealize (ResolvedRReference rtype (ResolvedString rname)) = do- let myfunction :: CResource -> CatalogMonad Bool- 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 (tshow x <> " was not resolved to a string")-pushRealize x = throwPosError ("A reference was expected instead of " <> tshow x)--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 <- use curVariables- 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------- mrrtype <- case mrtype of- ResolvedString x -> return x- _ -> 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 " <> tshow rdefs- position <- use curPos- defaults <- case rest of- [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: " <> tshow rest)- let prestatements = map (\(rname, rargs) -> (Value $ Literal rname, resolved2expression rargs)) arghash- resources <- mapM (\(resname, pval) -> do- realargs <- case pval of- Value (PuppetHash (Parameters h)) -> return h- _ -> throwPosError "This should not happen, create_resources argument is not a hash"- 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: " <> tshow x)-executeFunction "validate_array" [x] = case x of- ResolvedArray _ -> return []- y -> throwPosError $ tshow y <> " is not an array"-executeFunction "validate_hash" [x] = case x of- ResolvedHash _ -> return []- y -> throwPosError $ tshow y <> " is not a hash"-executeFunction "validate_string" [x] = case x of- ResolvedString _ -> return []- y -> throwPosError $ tshow y <> " is not an string"-executeFunction "validate_re" [x,reg] = case (x,reg) of- (ResolvedString z, ResolvedString rre) -> do- m <- liftIO $ regmatch z rre- case m of- Right True -> return []- 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 $ tshow y <> " is not a boolean"-executeFunction fname args = do- ufunctions <- use userFunctions- l <- use luaState- 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 <- use curPos- addWarning $ "Function " <> fname <> "(" <> tshow args <> ") not handled at " <> tshow position- return []--compareExpression :: Expression -> Expression -> CatalogMonad (Maybe Ordering)-compareExpression a b = do- ra <- tryResolveExpression a- rb <- tryResolveExpression b- case (ra, rb) of- (Right rra, Right rrb) -> return $ Just $ compareValues rra rrb- _ -> return $ compareSemiResolved ra rb--compareSemiResolved :: GeneralValue -> GeneralValue -> Maybe Ordering-compareSemiResolved a@(Right _) b@(Left _) = compareSemiResolved b a-compareSemiResolved (Left (Value (VariableReference _))) (Left (Value (VariableReference _))) = Just EQ-compareSemiResolved (Left (Value (VariableReference _))) (Left (Value (Literal ""))) = Just EQ-compareSemiResolved (Left (Value (VariableReference _))) (Left (Value (Literal "false"))) = Just EQ-compareSemiResolved a b = Just (compare a b)--compareGeneralValue :: GeneralValue -> Expression -> Expression -> [Ordering] -> CatalogMonad GeneralValue-compareGeneralValue n a b acceptable = do- cmp <- compareExpression a b- case cmp of- 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) = 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-compareRValues a b = compareValues a b == EQ---- used to handle the special cases when we know it is a boolean context-tryResolveBoolean :: GeneralValue -> CatalogMonad GeneralValue-tryResolveBoolean v = do- rv <- tryResolveGeneralValue v- case rv of- Left BFalse -> return $ Right $ ResolvedBool False- Left BTrue -> return $ Right $ ResolvedBool True- Right (ResolvedString "") -> return $ Right $ ResolvedBool False- Right (ResolvedString _) -> return $ Right $ ResolvedBool True- Right (ResolvedInt _) -> return $ Right $ ResolvedBool True- Right ResolvedUndefined -> return $ Right $ ResolvedBool False- Right (ResolvedArray _) -> return $ Right $ ResolvedBool True- Right (ResolvedRReference _ _) -> return $ Right $ ResolvedBool True- Left (Value (VariableReference _)) -> return $ Right $ ResolvedBool False- Left (EqualOperation (Value (VariableReference _)) (Value (Literal ""))) -> return $ Right $ ResolvedBool True -- case where a variable was not resolved and compared to the empty string- Left (EqualOperation (Value (VariableReference _)) (Value (Literal "true"))) -> return $ Right $ ResolvedBool False -- case where a variable was not resolved and compared to the string "true"- Left (EqualOperation (Value (VariableReference _)) (Value (Literal "false"))) -> return $ Right $ ResolvedBool True -- case where a variable was not resolved and compared to the string "false"- _ -> return rv--resolveBoolean :: GeneralValue -> CatalogMonad Bool-resolveBoolean v = do- rv <- tryResolveBoolean v- case rv of- Right (ResolvedBool x) -> return x- n -> throwPosError ("Could not resolve " <> tshow n <> "(was " <> tshow rv <> ") as a boolean")--resolveGeneralString :: GeneralString -> CatalogMonad T.Text-resolveGeneralString (Right x) = return x-resolveGeneralString (Left y) = resolveExpressionString y--collectFunction :: Virtuality -> T.Text -> Expression -> CatalogMonad (CResource -> CatalogMonad Bool, Maybe PDB.Query)-collectFunction virt mrtype exprs = do- (finalfunc, pdbquery) <- case exprs of- BTrue -> return (\_ -> return True, Just (PDB.collectAll mrtype))- EqualOperation a b -> do- ra <- resolveExpression a- rb <- resolveExpression b- paramname <- case ra of- ResolvedString pname -> return pname- _ -> throwPosError "We only support collection of the form 'parameter == value'"- defstatement <- checkDefine mrtype- paramset <- case defstatement of- Nothing -> use nativeTypes >>= \nt -> case Map.lookup mrtype nt of- Just (PuppetTypeMethods _ ps) -> return ps- 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 " <> 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 r ^. crparams . at (Right paramname) of- Nothing -> return False- Just prmmatch -> do- cmp <- resolveGeneralValue prmmatch- case (paramname, cmp) of- ("tag", ResolvedArray xs) ->- let filterd = filter (compareRValues rb) xs- in return $ not $ null filterd- _ -> return $ compareRValues cmp rb- , case (paramname, rb) of- ("tag", ResolvedString tagval) -> Just (PDB.collectTag mrtype tagval)- (param, ResolvedString prmval) -> Just (PDB.collectParam mrtype param prmval)- _ -> Nothing- )- 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- then pdbquery- else Nothing- )---generalValue2Expression :: GeneralValue -> Expression-generalValue2Expression (Left x) = x-generalValue2Expression (Right y) = resolved2expression y--generalValue2Value :: GeneralValue -> CatalogMonad Value-generalValue2Value x = case generalValue2Expression x of- (Value z) -> return z- y -> throwPosError $ "Could not downgrade this to a value: " <> tshow y--resolved2expression :: ResolvedValue -> Expression-resolved2expression (ResolvedString str) = Value $ Literal str-resolved2expression (ResolvedInt i) = Value $ Integer i-resolved2expression (ResolvedBool True) = BTrue-resolved2expression (ResolvedBool False) = BFalse-resolved2expression (ResolvedRReference mrtype name) = Value $ ResourceReference mrtype (resolved2expression name)-resolved2expression (ResolvedArray vals) = Value $ PuppetArray $ map resolved2expression vals-resolved2expression (ResolvedHash hash) = Value $ PuppetHash $ Parameters $ map (\(s,v) -> (Value $ Literal s, resolved2expression v)) hash-resolved2expression ResolvedUndefined = Value Undefined-resolved2expression (ResolvedRegexp a) = Value $ PuppetRegexp a-resolved2expression (ResolvedDouble d) = Value $ Double d--arithmeticOperation :: Expression -> Expression -> (Integer -> Integer -> Integer) -> (Double -> Double -> Double) -> GeneralValue -> CatalogMonad GeneralValue-arithmeticOperation a b opi opf def = do- ra <- tryResolveExpression a- rb <- tryResolveExpression b- case (ra, rb) of- (Right (ResolvedInt sa) , Right (ResolvedInt sb)) -> return $ Right $ ResolvedInt $ opi sa sb- (Right (ResolvedDouble sa), Right (ResolvedInt sb)) -> return $ Right $ ResolvedDouble $ opf sa (fromIntegral sb)- (Right (ResolvedInt sa) , Right (ResolvedDouble sb)) -> return $ Right $ ResolvedDouble $ opf (fromIntegral sa) sb- (Right (ResolvedDouble sa), Right (ResolvedDouble sb)) -> return $ Right $ ResolvedDouble $ opf sa sb- _ -> return def---stringTransform :: [Expression] -> Value -> (T.Text -> T.Text) -> CatalogMonad GeneralValue-stringTransform [u] n f = do- r <- tryResolveExpressionString u- case r of- Right s -> return $ Right $ ResolvedString $ f s- Left _ -> return $ Left $ Value n-stringTransform _ _ _ = throwPosError "This function takes a single argument."
− Puppet/Interpreter/Functions.hs
@@ -1,146 +0,0 @@-module Puppet.Interpreter.Functions- ( fqdn_rand- , regsubst- , mysql_password- , regmatch- , versioncmp- , file- , puppetSplit- , puppetSHA1- , puppetMD5- , generate- , pdbresourcequery- ) where--import PuppetDB.Query-import Puppet.Printers-import Puppet.Interpreter.Types-import Puppet.Interpreter.RubyRandom-import Puppet.Utils--import Control.Monad.State-import Prelude hiding (catch)-import Control.Exception-import qualified Crypto.Hash.SHA1 as SHA1-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.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-import Control.Lens--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 -> [T.Text] -> CatalogMonad Integer-fqdn_rand n args = return val- where- 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 :: T.Text -> CatalogMonad T.Text-mysql_password pwd = return $ T.cons '*' hash- where- hash = T.toUpper $ puppetMysql pwd--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)----- TODO-versioncmp :: T.Text -> T.Text -> Integer-versioncmp a b | a > b = 1- | a < b = -1- | otherwise = 0--file :: [T.Text] -> IO (Maybe T.Text)-file [] = return Nothing--- this is bad, is should be rewritten as a ByteString-file (x:xs) = catch- (fmap Just (T.readFile (T.unpack x)))- (\SomeException{} -> file xs)--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 :: T.Text -> [T.Text] -> IO (Maybe T.Text)-generate command args = do- cmdout <- safeReadProcessTimeout (T.unpack command) (map T.unpack args) TL.empty 60000- case cmdout of- Just (Right x) -> return $ Just x- _ -> return Nothing--pdbresourcequery :: Query -> Maybe T.Text -> CatalogMonad ResolvedValue-pdbresourcequery query key = do- let- extractSubHash :: T.Text -> [ResolvedValue] -> Either String ResolvedValue- extractSubHash k vals = let o = map (extractSubHash' k) vals- in if null (lefts o)- then Right $ ResolvedArray $ rights o- else Left $ "Something wrong happened while extracting the subhashes for key " ++ 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 " ++ T.unpack (showValue x)- qf <- use puppetDBFunction- 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: " <> 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 (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/PrettyPrinter.hs view
@@ -0,0 +1,111 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Puppet.Interpreter.PrettyPrinter(containerComma) where++import Puppet.PP+import Puppet.Parser.Types+import Puppet.Interpreter.Types+import Puppet.Parser.PrettyPrinter++import Data.Monoid+import qualified Data.Vector as V+import qualified Data.Text as T+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import Control.Arrow (first,second)+import Control.Lens+import Data.List+import GHC.Exts++containerComma'' :: Pretty a => [(Doc, a)] -> Doc+containerComma'' x = indent 2 ins+ where+ ins = mconcat $ intersperse (comma <$> empty) (map showC x)+ showC (a,b) = a <+> text "=>" <+> pretty b++containerComma' :: Pretty a => [(Doc, a)] -> Doc+containerComma' = braces . containerComma''++containerComma :: Pretty a => Container a -> Doc+containerComma hm = containerComma' (map (\(a,b) -> (fill maxalign (ttext a), b)) hml)+ where+ hml = HM.toList hm+ maxalign = maximum (map (T.length . fst) hml)++instance Pretty PValue where+ pretty (PBoolean True) = dullmagenta $ text "true"+ pretty (PBoolean False) = dullmagenta $ text "false"+ pretty (PString s) = dullcyan (text (show s))+ pretty PUndef = dullmagenta (text "undef")+ pretty (PResourceReference t n) = capitalize t <> brackets (text (T.unpack n))+ pretty (PArray v) = list (map pretty (V.toList v))+ pretty (PHash g) = containerComma g++instance Pretty TopLevelType where+ pretty TopNode = dullyellow (text "node")+ pretty TopDefine = dullyellow (text "define")+ pretty TopClass = dullyellow (text "class")+ pretty TopSpurious = dullyellow (text "spurious")++instance Pretty RIdentifier where+ pretty (RIdentifier t n) = pretty (PResourceReference t n)++meta :: Resource -> Doc+meta r = showPPos (r ^. rpos) <+> (green (node <> brackets cont <+> brackets scp) )+ where+ node = maybe mempty ((<+> mempty) . red . ttext) (r ^. rnode)+ cont = case r ^. rcontainer of+ ContRoot -> magenta "top level"+ ContClass cname -> magenta "class" <+> ttext cname+ ContDefine t n -> pretty (PResourceReference t n)+ ContImported -> magenta "imported"+ scp = "Scope" <+> pretty (r ^.. rscope . folded . filtered (/="::") . to (white . ttext))++resourceBody :: Resource -> Doc+resourceBody r = virtuality <> blue (ttext (r ^. rid . iname)) <> ":" <+> meta r <$> containerComma'' insde <> ";"+ where+ virtuality = case r ^. rvirtuality of+ Normal -> empty+ Virtual -> dullred "@"+ Exported -> dullred "@@"+ ExportedRealized -> dullred "<@@>"+ insde = alignlst dullblue attriblist1 ++ alignlst dullmagenta attriblist2+ alignlst col = map (first (fill maxalign . col . ttext))+ attriblist1 = sortWith fst $ HM.toList (r ^. rattributes) ++ aliasdiff+ aliasWithoutTitle = r ^. ralias & contains (r ^. rid . iname) .~ False+ aliasPValue = aliasWithoutTitle & PArray . V.fromList . map PString . HS.toList+ aliasdiff | HS.null aliasWithoutTitle = [("alias", aliasPValue)]+ | otherwise = []+ attriblist2 = map totext (resourceRelations r)+ totext (RIdentifier t n, lt) = (rel2text lt , PResourceReference t n)+ maxalign = max (maxalign' attriblist1) (maxalign' attriblist2)+ maxalign' [] = 0+ maxalign' x = maximum . map (T.length . fst) $ x++instance Pretty Resource where+ prettyList lst =+ let grouped = HM.toList $ HM.fromListWith (++) [ (r ^. rid . itype, [r]) | r <- lst ] :: [ (T.Text, [Resource]) ]+ sorted = sortWith fst (map (second (sortWith (_iname . _rid) )) grouped)+ showGroup :: (T.Text, [Resource]) -> Doc+ showGroup (rt, res) = dullyellow (ttext rt) <+> lbrace <$> indent 2 (vcat (map resourceBody res)) <$> rbrace+ in vcat (map showGroup sorted)+ pretty r = dullyellow (ttext (r ^. rid . itype)) <+> lbrace <$> indent 2 (resourceBody r) <$> rbrace++instance Pretty CurContainerDesc where+ pretty ContImported = magenta "imported"+ pretty ContRoot = dullyellow (text "::")+ pretty (ContClass cname) = dullyellow (text "class") <+> dullgreen (text (T.unpack cname))+ pretty (ContDefine dtype dname) = pretty (PResourceReference dtype dname)++instance Pretty ResDefaults where+ pretty (ResDefaults t _ v p) = capitalize t <+> showPPos p <$> containerComma v++instance Pretty ResourceModifier where+ pretty (ResourceModifier rt ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString x)) _ p) = "realize" <> parens (pretty (PResourceReference rt x)) <+> showPPos p+ pretty _ = "TODO pretty ResourceModifier"++instance Pretty RSearchExpression where+ pretty (REqualitySearch a v) = ttext a <+> "==" <+> pretty v+ pretty (RNonEqualitySearch a v) = ttext a <+> "!=" <+> pretty v+ pretty (RAndSearch a b) = parens (pretty a) <+> "&&" <+> parens (pretty b)+ pretty (ROrSearch a b) = parens (pretty a) <+> "||" <+> parens (pretty b)+ pretty RAlwaysTrue = mempty
+ Puppet/Interpreter/Resolve.hs view
@@ -0,0 +1,522 @@+{-# LANGUAGE LambdaCase #-}+module Puppet.Interpreter.Resolve where++import Puppet.PP+import Puppet.Interpreter.Types+import Puppet.Parser.Types+import Puppet.Interpreter.PrettyPrinter()+import Puppet.Parser.PrettyPrinter()++import Data.Version (parseVersion)+import Text.ParserCombinators.ReadP (readP_to_S)++import Data.Aeson hiding ((.=))+import Data.CaseInsensitive ( mk )+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Text.Encoding as T+import Data.Monoid+import Control.Applicative hiding ((<$>))+import Control.Exception+import Control.Monad+import Control.Monad.Error+import Data.Tuple.Strict+import Control.Lens+import Data.Attoparsec.Number+import Data.Attoparsec.Text+import qualified Data.Either.Strict as S+import qualified Data.Maybe.Strict as S+import Text.Regex.PCRE.ByteString+import Puppet.Interpreter.RubyRandom+import qualified Data.ByteString as BS+import qualified Crypto.Hash.MD5 as MD5+import qualified Crypto.Hash.SHA1 as SHA1+import qualified Data.ByteString.Base16 as B16+import Text.Regex.PCRE.ByteString.Utils+import Data.Bits++type NumberPair = S.Either (Pair Integer Integer) (Pair Double Double)++-- | Tries to convert a pair of PValues into numbers, as defined in+-- attoparsec. If the two values can be converted, it will convert them so+-- that they are of the same type+toNumbers :: PValue -> PValue -> S.Maybe NumberPair+toNumbers (PString a) (PString b) =+ case parseOnly number a :!: parseOnly number b of+ (Right (I x) :!: Right (I y)) -> S.Just (S.Left (x :!: y))+ (Right (D x) :!: Right (D y)) -> S.Just (S.Right (x :!: y))+ (Right (I x) :!: Right (D y)) -> S.Just (S.Right (fromIntegral x :!: y))+ (Right (D x) :!: Right (I y)) -> S.Just (S.Right (x :!: fromIntegral y))+ _ -> S.Nothing+toNumbers _ _ = S.Nothing++binaryOperation :: Expression -> Expression -> (Integer -> Integer -> Integer) -> (Double -> Double -> Double) -> InterpreterMonad PValue+binaryOperation a b opi opd = do+ ra <- resolveExpression a+ rb <- resolveExpression b+ case toNumbers ra rb of+ S.Nothing -> throwPosError ("Expected numbers, not" <+> pretty ra <+> "or" <+> pretty rb)+ S.Just (S.Right (na :!: nb)) -> return (pvnum # D (opd na nb))+ S.Just (S.Left (na :!: nb)) -> return (pvnum # I (opi na nb))++integerOperation :: Expression -> Expression -> (Integer -> Integer -> Integer) -> InterpreterMonad PValue+integerOperation a b opr = do+ ra <- resolveExpression a+ rb <- resolveExpression b+ case toNumbers ra rb of+ S.Nothing -> throwPosError ("Expected numbers, not" <+> pretty ra <+> "or" <+> pretty rb)+ S.Just (S.Right _) -> throwPosError ("Expected integer values, not" <+> pretty ra <+> "or" <+> pretty rb)+ S.Just (S.Left (na :!: nb)) -> return (pvnum # I (opr na nb))++-- | Converting PValue to and from Number with a prism!+pvnum :: Prism' PValue Number+pvnum = prism num2PValue toNumber+ where+ num2PValue :: Number -> PValue+ num2PValue (I x) = PString (T.pack (show x))+ num2PValue (D x) = PString (T.pack (show x))+ toNumber :: PValue -> Either PValue Number+ toNumber p@(PString x) = case parseOnly number x of+ Right y -> Right y+ _ -> Left p+ toNumber p = Left p++_PString :: Prism' PValue T.Text+_PString = prism PString $ \x -> case x of+ PString s -> Right s+ n -> Left n++_PInteger :: Prism' PValue Integer+_PInteger = prism (PString . T.pack . show) $ \x -> case x ^? pvnum of+ Just (I z) -> Right z+ _ -> Left x++resolveVariable :: T.Text -> InterpreterMonad PValue+resolveVariable fullvar = do+ scps <- use scopes+ scp <- getScope+ case getVariable scps scp fullvar of+ Left rr -> throwPosError rr+ Right x -> return x++isNativeType :: T.Text -> InterpreterMonad Bool+isNativeType t = view (nativeTypes . contains t)++getVariable :: Container ScopeInformation -> T.Text -> T.Text -> Either Doc PValue+getVariable scps scp fullvar = do+ (varscope, varname) <- case T.splitOn "::" fullvar of+ [] -> throwError "This doesn't make any sense in resolveVariable"+ [vn] -> return (scp, vn) -- Non qualified variables+ rst -> return (T.intercalate "::" (filter (not . T.null) (init rst)), last rst) -- qualified variables+ let extractVariable (varval :!: _ :!: _) = return varval+ case scps ^? ix varscope . scopeVariables . ix varname of+ Just pp -> extractVariable pp+ Nothing -> -- check top level scope+ case scps ^? ix "::" . scopeVariables . ix varname of+ Just pp -> extractVariable pp+ Nothing -> throwError ("Could not resolve variable" <+> pretty (UVariableReference fullvar) <+> "in context" <+> ttext varscope <+> "or root")++numberCompare :: Expression -> Expression -> (Integer -> Integer -> Bool) -> (Double -> Double -> Bool) -> InterpreterMonad PValue+numberCompare a b compi compd = do+ ra <- resolveExpression a+ rb <- resolveExpression b+ case toNumbers ra rb of+ S.Nothing -> throwPosError ("Comparison functions expect numbers, not:" <+> pretty ra <+> comma <+> pretty rb)+ S.Just (S.Right (na :!: nb)) -> return (PBoolean (compd na nb))+ S.Just (S.Left (na :!: nb)) -> return (PBoolean (compi na nb))++puppetEquality :: PValue -> PValue -> Bool+puppetEquality ra rb =+ case toNumbers ra rb of+ (S.Just (S.Right (na :!: nb))) -> na == nb+ (S.Just (S.Left (na :!: nb))) -> na == nb+ _ -> case (ra, rb) of+ (PUndef , PBoolean x) -> not x+ (PString "true", PBoolean x) -> x+ (PString "false", PBoolean x) -> not x+ (PBoolean x, PString "true") -> x+ (PBoolean x, PString "false") -> not x+ (PString sa, PString sb) -> mk sa == mk sb+ -- TODO, check if array / hash equality should be recursed+ -- for case insensitive matching+ _ -> ra == rb++resolveExpression :: Expression -> InterpreterMonad PValue+resolveExpression (PValue v) = resolveValue v+resolveExpression (Not e) = fmap (PBoolean . not . pValue2Bool) (resolveExpression e)+resolveExpression (And a b) = do+ ra <- fmap pValue2Bool (resolveExpression a)+ rb <- fmap pValue2Bool (resolveExpression b)+ return (PBoolean (ra && rb))+resolveExpression (Or a b) = do+ ra <- fmap pValue2Bool (resolveExpression a)+ rb <- fmap pValue2Bool (resolveExpression b)+ return (PBoolean (ra || rb))+resolveExpression (LessThan a b) = numberCompare a b (<) (<)+resolveExpression (MoreThan a b) = numberCompare a b (>) (>)+resolveExpression (LessEqualThan a b) = numberCompare a b (<=) (<=)+resolveExpression (MoreEqualThan a b) = numberCompare a b (>=) (>=)+resolveExpression (RegexMatch a (PValue ur@(URegexp _ rv))) = do+ ra <- fmap T.encodeUtf8 (resolveExpressionString a)+ liftIO (execute rv ra) >>= \case+ Left rr -> throwPosError ("Regexp matching critical failure" <+> text (show rr) <+> parens ("Regexp was" <+> pretty ur))+ Right Nothing -> return (PBoolean False)+ Right _ -> return (PBoolean True)+resolveExpression (RegexMatch _ t) = throwPosError ("The regexp matching operator expects a regular expression, not" <+> pretty t)+resolveExpression (NotRegexMatch a v) = resolveExpression (Not (RegexMatch a v))+resolveExpression (Equal a b) = do+ ra <- resolveExpression a+ rb <- resolveExpression b+ return $ PBoolean $ puppetEquality ra rb+resolveExpression (Different a b) = resolveExpression (Not (Equal a b))+resolveExpression (Contains idx a) =+ resolveExpression a >>= \case+ PHash h -> do+ ridx <- resolveExpressionString idx+ case h ^. at ridx of+ Just _ -> return (PBoolean True)+ Nothing -> return (PBoolean False)+ PArray ar -> do+ ridx <- resolveExpression idx+ return (PBoolean (ridx `V.elem` ar))+ PString st -> do+ ridx <- resolveExpressionString idx+ return (PBoolean (ridx `T.isInfixOf` st))+ src -> throwPosError ("Can't use the 'in' operator with" <+> pretty src)+resolveExpression (Lookup a idx) =+ resolveExpression a >>= \case+ PHash h -> do+ ridx <- resolveExpressionString idx+ case h ^. at ridx of+ Just v -> return v+ Nothing -> throwPosError ("Can't find index '" <> ttext ridx <> "' in" <+> pretty (PHash h))+ PArray ar -> do+ ridx <- resolveExpression idx+ i <- case ridx ^? pvnum of+ Just (I n) -> return (fromIntegral n)+ _ -> throwPosError ("Need an integral number for indexing an array, not" <+> pretty ridx)+ let arl = V.length ar+ if arl <= i+ then throwPosError ("Out of bound indexing, array size is" <+> int arl <+> "index is" <+> int i)+ else return (ar V.! i)+ src -> throwPosError ("This data can't be indexed:" <+> pretty src)+resolveExpression stmt@(ConditionalValue e conds) = do+ rese <- resolveExpression e+ let checkCond [] = throwPosError ("The selector didn't match anything for input" <+> pretty rese </> pretty stmt)+ checkCond ((SelectorDefault :!: ce) : _) = resolveExpression ce+ checkCond ((SelectorValue ur@(URegexp _ rg) :!: ce) : xs) = do+ rs <- fmap T.encodeUtf8 (resolvePValueString rese)+ liftIO (execute rg rs) >>= \case+ Left rr -> throwPosError ("Regexp matching critical failure" <+> text (show rr) <+> parens ("Regexp was" <+> pretty ur))+ Right Nothing -> checkCond xs+ Right _ -> resolveExpression ce+ checkCond ((SelectorValue uv :!: ce) : xs) = do+ rv <- resolveValue uv+ if puppetEquality rese rv+ then resolveExpression ce+ else checkCond xs+ checkCond (V.toList conds)+resolveExpression (Addition a b) = binaryOperation a b (+) (+)+resolveExpression (Substraction a b) = binaryOperation a b (-) (-)+resolveExpression (Division a b) = binaryOperation a b div (/)+resolveExpression (Multiplication a b) = binaryOperation a b (*) (*)+resolveExpression (Modulo a b) = integerOperation a b mod+resolveExpression (RightShift a b) = integerOperation a b (\x -> shiftR x . fromIntegral)+resolveExpression (LeftShift a b) = integerOperation a b (\x -> shiftL x . fromIntegral)+resolveExpression a@(FunctionApplication e (PValue (UHFunctionCall hf))) = do+ unless (S.isNothing (hf ^. hfexpr)) (throwPosError ("You can't combine chains of higher order functions (with .) and giving them parameters, in:" <+> pretty a))+ resolveValue (UHFunctionCall (hf & hfexpr .~ S.Just e))+resolveExpression (FunctionApplication _ x) = throwPosError ("Expected function application here, not" <+> pretty x)+resolveExpression x = throwPosError ("Don't know how to resolve this expression:" <$> pretty x)++resolveValue :: UValue -> InterpreterMonad PValue+resolveValue n@(URegexp _ _) = throwPosError ("Regular expressions are not allowed in this context: " <+> pretty n)+resolveValue (UBoolean x) = return (PBoolean x)+resolveValue (UString x) = return (PString x)+resolveValue UUndef = return PUndef+resolveValue (UInterpolable vals) = fmap (PString . mconcat) (mapM resolveValueString (V.toList vals))+resolveValue (UResourceReference t e) = PResourceReference `fmap` pure t <*> resolveExpressionString e+resolveValue (UArray a) = fmap PArray (V.mapM resolveExpression a)+resolveValue (UHash a) = fmap (PHash . HM.fromList) (mapM resPair (V.toList a))+ where+ resPair (k :!: v) = (,) `fmap` resolveExpressionString k <*> resolveExpression v+resolveValue (UVariableReference v) = resolveVariable v+resolveValue (UFunctionCall fname args) = resolveFunction fname args+resolveValue (UHFunctionCall hf) = evaluateHFCPure hf++resolveValueString :: UValue -> InterpreterMonad T.Text+resolveValueString = resolveValue >=> resolvePValueString++resolvePValueString :: PValue -> InterpreterMonad T.Text+resolvePValueString (PString x) = return x+resolvePValueString (PBoolean True) = return "true"+resolvePValueString (PBoolean False) = return "false"+resolvePValueString x = throwPosError ("Don't know how to convert this to a string:" <$> pretty x)++resolveExpressionString :: Expression -> InterpreterMonad T.Text+resolveExpressionString = resolveExpression >=> resolvePValueString++resolveExpressionStrings :: Expression -> InterpreterMonad [T.Text]+resolveExpressionStrings x =+ resolveExpression x >>= \case+ PArray a -> mapM resolvePValueString (V.toList a)+ y -> fmap return (resolvePValueString y)++resolveArgument :: Pair T.Text Expression -> InterpreterMonad (Pair T.Text PValue)+resolveArgument (argname :!: argval) = (:!:) `fmap` pure argname <*> resolveExpression argval++pValue2Bool :: PValue -> Bool+pValue2Bool PUndef = False+pValue2Bool (PString "") = False+pValue2Bool (PBoolean x) = x+pValue2Bool _ = True++resolveFunction :: T.Text -> V.Vector Expression -> InterpreterMonad PValue+resolveFunction "fqdn_rand" args = do+ let nbargs = V.length args+ when (nbargs < 1 || nbargs > 2) (throwPosError "fqdn_rand(): Expects one or two arguments")+ fqdn <- resolveVariable "::fqdn" >>= resolvePValueString+ (mx:targs) <- mapM resolveExpressionString (V.toList args)+ curmax <- case PString mx ^? pvnum of+ Just (I x) -> return x+ _ -> throwPosError ("fqdn_rand(): the first argument must be an integer, not" <+> ttext mx)+ let rargs = if null targs+ then [fqdn, ""]+ else fqdn : targs+ val = fromIntegral (Prelude.fst (limitedRand (randInit myhash) (fromIntegral curmax)))+ myhash = toint (MD5.hash (T.encodeUtf8 fullstring)) :: Integer+ toint = BS.foldl' (\c nx -> c*256 + fromIntegral nx) 0+ fullstring = T.intercalate ":" rargs+ return (pvnum # I val)+resolveFunction fname args = mapM resolveExpression (V.toList args) >>= resolveFunction' fname++resolveFunction' :: T.Text -> [PValue] -> InterpreterMonad PValue+resolveFunction' "defined" [PResourceReference rt rn] = fmap PBoolean (use (definedResources . contains (RIdentifier rt rn)))+resolveFunction' "defined" [ut] = do+ t <- resolvePValueString ut+ -- case 1, netsted thingie+ nestedStuff <- use nestedDeclarations+ if (nestedStuff ^. contains (TopDefine, t)) || (nestedStuff ^. contains (TopClass, t))+ then return (PBoolean True)+ else do -- case 2, loadeded class+ lc <- use loadedClasses+ if lc ^. contains t+ then return (PBoolean True)+ else fmap PBoolean (isNativeType t)+resolveFunction' "defined" x = throwPosError ("defined(): expects a single resource reference, type or class name, and not" <+> pretty x)+resolveFunction' "fail" x = throwPosError ("fail:" <+> pretty x)+resolveFunction' "inline_template" [templatename] = calcTemplate Left templatename+resolveFunction' "inline_template" _ = throwPosError "inline_template(): Expects a single argument"+resolveFunction' "md5" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . MD5.hash . T.encodeUtf8) (resolvePValueString pstr)+resolveFunction' "md5" _ = throwPosError "md5(): Expects a single argument"+resolveFunction' "regsubst" [ptarget, pregexp, preplacement] = resolveFunction' "regsubst" [ptarget, pregexp, preplacement, PString "G"]+resolveFunction' "regsubst" [ptarget, pregexp, preplacement, pflags] = do+ -- TODO handle all the flags+ -- http://docs.puppetlabs.com/references/latest/function.html#regsubst+ when (pflags /= "G") (throwPosError "regsubst(): Currently only supports a single flag (G)")+ target <- fmap T.encodeUtf8 (resolvePValueString ptarget)+ regexp <- fmap T.encodeUtf8 (resolvePValueString pregexp)+ replacement <- fmap T.encodeUtf8 (resolvePValueString preplacement)+ liftIO (substituteCompile regexp target replacement) >>= \case+ Left rr -> throwPosError ("regsubst():" <+> text rr)+ Right x -> fmap PString (safeDecodeUtf8 x)+resolveFunction' "regsubst" _ = throwPosError "regsubst(): Expects 3 or 4 arguments"+resolveFunction' "split" [psrc, psplt] = do+ src <- fmap T.encodeUtf8 (resolvePValueString psrc)+ splt <- fmap T.encodeUtf8 (resolvePValueString psplt)+ liftIO (splitCompile splt src) >>= \case+ Left rr -> throwPosError ("regsubst():" <+> text rr)+ Right x -> fmap (PArray . V.fromList) $ mapM (fmap PString . safeDecodeUtf8) x+resolveFunction' "sha1" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . SHA1.hash . T.encodeUtf8) (resolvePValueString pstr)+resolveFunction' "sha1" _ = throwPosError "sha1(): Expects a single argument"+resolveFunction' "mysql_password" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . SHA1.hash . SHA1.hash . T.encodeUtf8) (resolvePValueString pstr)+resolveFunction' "mysql_password" _ = throwPosError "mysql_password(): Expects a single argument"+resolveFunction' "file" args = mapM resolvePValueString args >>= fmap PString . interpreterIO . file+ where+ file :: [T.Text] -> IO (S.Either Doc T.Text)+ file [] = return $ S.Left ("No file found in" <+> pretty args)+ file (x:xs) = fmap S.Right (T.readFile (T.unpack x)) `catch` (\SomeException{} -> file xs)+resolveFunction' "tagged" ptags = do+ tags <- fmap HS.fromList (mapM resolvePValueString ptags)+ scp <- getScope+ scpset <- use (scopes . ix scp . scopeExtraTags)+ return (PBoolean (scpset `HS.intersection` tags == tags))+resolveFunction' "template" [templatename] = calcTemplate Right templatename+resolveFunction' "template" _ = throwPosError "template(): Expects a single argument"+resolveFunction' "versioncmp" [pa,pb] = do+ a <- resolvePValueString pa+ b <- resolvePValueString pb+ let parser x = case filter (null . Prelude.snd) (readP_to_S parseVersion (T.unpack x)) of+ ( (v, _) : _ ) -> return v+ _ -> throwPosError ("Could not parse this string as a version:" <+> ttext x)+ va <- parser a+ vb <- parser b+ return $ PString $ case compare va vb of+ EQ -> "0"+ LT -> "-1"+ GT -> "1"+resolveFunction' "versioncmp" _ = throwPosError "versioncmp(): Expects two arguments"+-- some custom functions+resolveFunction' "pdbresourcequery" [q] = pdbresourcequery q Nothing+resolveFunction' "pdbresourcequery" [q,k] = fmap Just (resolvePValueString k) >>= pdbresourcequery q+resolveFunction' "pdbresourcequery" _ = throwPosError "pdbresourcequery(): Expects one or two arguments"+-- user functions+resolveFunction' fname args = do+ external <- view externalFunctions+ case external ^. at fname of+ Just f -> f args+ Nothing -> throwPosError ("Unknown function" <+> dullred (ttext fname))++pdbresourcequery :: PValue -> Maybe T.Text -> InterpreterMonad PValue+pdbresourcequery q key = do+ pdb <- view pdbAPI+ rrv <- case fromJSON (toJSON q) of+ Success rq -> interpreterIO (getResources pdb rq)+ Error rr -> throwPosError ("Invalid resource query:" <+> Puppet.PP.string rr)+ rv <- case fromJSON (toJSON rrv) of+ Success x -> return x+ Error rr -> throwPosError ("For some reason we could not convert a resource list to Puppet internal values!!" <+> Puppet.PP.string rr <+> pretty rrv)+ let extractSubHash :: T.Text -> PValue -> InterpreterMonad PValue+ extractSubHash ky (PHash h) = case h ^. at ky of+ Just val -> return val+ Nothing -> throwPosError ("pdbresourcequery strange error, could not find key" <+> ttext ky <+> "in" <+> pretty (PHash h))+ extractSubHash _ x = throwPosError ("pdbresourcequery strange error, expected a hash, had" <+> pretty x)+ case key of+ Nothing -> return (PArray rv)+ (Just k) -> fmap PArray (V.mapM (extractSubHash k) rv)++calcTemplate :: (T.Text -> Either T.Text T.Text) -> PValue -> InterpreterMonad PValue+calcTemplate templatetype templatename = do+ fname <- resolvePValueString templatename+ scps <- use scopes+ scp <- getScope+ computeFunc <- view computeTemplateFunction+ liftIO (computeFunc (templatetype fname) scp scps)+ >>= \case+ S.Left rr -> throwPosError ("template error for" <+> ttext fname <+> ":" <$> rr)+ S.Right r -> return (PString r)++resolveExpressionSE :: Expression -> InterpreterMonad PValue+resolveExpressionSE e = resolveExpression e >>=+ \case+ PArray _ -> throwPosError "The use of an array in a search expression is undefined"+ PHash _ -> throwPosError "The use of an array in a search expression is undefined"+ resolved -> return resolved++resolveSearchExpression :: SearchExpression -> InterpreterMonad RSearchExpression+resolveSearchExpression AlwaysTrue = return RAlwaysTrue+resolveSearchExpression (EqualitySearch a e) = REqualitySearch `fmap` pure a <*> resolveExpressionSE e+resolveSearchExpression (NonEqualitySearch a e) = RNonEqualitySearch `fmap` pure a <*> resolveExpressionSE e+resolveSearchExpression (AndSearch e1 e2) = RAndSearch `fmap` resolveSearchExpression e1 <*> resolveSearchExpression e2+resolveSearchExpression (OrSearch e1 e2) = ROrSearch `fmap` resolveSearchExpression e1 <*> resolveSearchExpression e2++searchExpressionToPuppetDB :: T.Text -> RSearchExpression -> Query ResourceField+searchExpressionToPuppetDB rtype res = QAnd ( QEqual RType rtype : mkSE res )+ where+ mkSE (RAndSearch a b) = [QAnd (mkSE a ++ mkSE b)]+ mkSE (ROrSearch a b) = [QOr (mkSE a ++ mkSE b)]+ mkSE (RNonEqualitySearch a b) = fmap QNot (mkSE (REqualitySearch a b))+ mkSE (REqualitySearch a (PString b)) = [QEqual (mkFld a) b]+ mkSE _ = []+ mkFld "tag" = RTag+ mkFld "title" = RTitle+ mkFld z = RParameter z++checkSearchExpression :: RSearchExpression -> Resource -> Bool+checkSearchExpression RAlwaysTrue _ = True+checkSearchExpression (RAndSearch a b) r = checkSearchExpression a r && checkSearchExpression b r+checkSearchExpression (ROrSearch a b) r = checkSearchExpression a r || checkSearchExpression b r+checkSearchExpression (RNonEqualitySearch a b) r = not (checkSearchExpression (REqualitySearch a b) r)+checkSearchExpression (REqualitySearch "tag" (PString s)) r = r ^. rtags . contains s+checkSearchExpression (REqualitySearch "tag" _) _ = False+checkSearchExpression (REqualitySearch "title" v) r =+ let nameequal = puppetEquality v (PString (r ^. rid . iname))+ aliasequal = case r ^. rattributes . at "alias" of+ Just a -> puppetEquality v a+ Nothing -> False+ in nameequal || aliasequal+checkSearchExpression (REqualitySearch attributename v) r = case r ^. rattributes . at attributename of+ Nothing -> False+ Just x -> puppetEquality x v++{---------------------------------------+- Higher order functions part+----------------------------------------}++-- | Generates associations for evaluation of blocks+hfGenerateAssociations :: HFunctionCall -> InterpreterMonad [[(T.Text, PValue)]]+hfGenerateAssociations hf = do+ sourceexpression <- case hf ^. hfexpr of+ S.Just x -> return x+ S.Nothing -> throwPosError ("No expression to run the function on" <+> pretty hf)+ sourcevalue <- resolveExpression sourceexpression+ case (sourcevalue, hf ^. hfparams) of+ (PArray pr, BPSingle varname) -> return (map (\x -> [(varname, x)]) (V.toList pr))+ (PArray pr, BPPair idx var) -> return $ do+ (i,v) <- Prelude.zip ([0..] :: [Int]) (V.toList pr)+ return [(idx,PString (T.pack (show i))),(var,v)]+ (PHash hh, BPSingle varname) -> return $ do+ (k,v) <- HM.toList hh+ return [(varname, PArray (V.fromList [PString k,v]))]+ (PHash hh, BPPair idx var) -> return $ do+ (k,v) <- HM.toList hh+ return [(idx,PString k),(var,v)]+ (invalid, _) -> throwPosError ("Can't iterate on this data type:" <+> pretty invalid)++-- | Sets the proper variables, and returns the scope variables the way+-- they were before being modified.+hfSetvars :: [(T.Text, PValue)] -> InterpreterMonad (Container (Pair (Pair PValue PPosition) CurContainerDesc))+hfSetvars vals =+ do+ scp <- getScope+ p <- use curPos+ container <- getCurContainer+ save <- use (scopes . ix scp . scopeVariables)+ let hfSetvar (varname, varval) = scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: (container ^. cctype))+ mapM_ hfSetvar vals+ return save++-- | Restores what needs restoring. This will erase all allocation.+hfRestorevars :: Container (Pair (Pair PValue PPosition) CurContainerDesc) -> InterpreterMonad ()+hfRestorevars save =+ do+ scp <- getScope+ scopes . ix scp . scopeVariables .= save++-- | Evaluates a statement in "pure" mode.+evalPureStatement :: Statement -> InterpreterMonad ()+evalPureStatement = undefined++-- | All the "higher order function" stuff, for "value" mode. In this case+-- we are in "pure" mode, and only a few statements are allowed.+evaluateHFCPure :: HFunctionCall -> InterpreterMonad PValue+evaluateHFCPure hf = do+ varassocs <- hfGenerateAssociations hf+ finalexpression <- case hf ^. hfexpression of+ S.Just x -> return x+ S.Nothing -> throwPosError ("The statement block must end with an expression" <+> pretty hf)+ let runblock :: [(T.Text, PValue)] -> InterpreterMonad PValue+ runblock assocs = do+ saved <- hfSetvars assocs+ V.mapM_ evalPureStatement (hf ^. hfstatements)+ r <- resolveExpression finalexpression+ hfRestorevars saved+ return r+ case hf ^. hftype of+ HFEach -> throwPosError "The 'each' function can't be used at the value level in language-puppet. Please use map."+ HFMap -> fmap (PArray . V.fromList) (mapM runblock varassocs)+ HFFilter -> do+ res <- mapM (fmap pValue2Bool . runblock) varassocs+ sourcevalue <- case hf ^. hfexpr of+ S.Just x -> resolveExpression x+ S.Nothing -> throwPosError "Internal error evaluateHFCPure 1"+ case sourcevalue of+ PArray ar -> return $ PArray $ V.map Prelude.fst $ V.filter Prelude.snd $ V.zip ar (V.fromList res)+ PHash hh -> return $ PHash $ HM.fromList $ map Prelude.fst $ filter Prelude.snd $ Prelude.zip (HM.toList hh) res+ x -> throwPosError ("Can't iterate on this data type:" <+> pretty x)+ x -> throwPosError ("This type of function is not supported yet by language-puppet!" <+> pretty x)++
Puppet/Interpreter/Types.hs view
@@ -1,342 +1,601 @@-{-# LANGUAGE TemplateHaskell, CPP #-}-+{-# LANGUAGE DeriveGeneric, TemplateHaskell, CPP, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Puppet.Interpreter.Types where -import Puppet.DSL.Types hiding (Value) -- conflicts with aeson-import Puppet.Utils--import qualified PuppetDB.Query as PDB-import qualified Scripting.Lua as Lua+import Puppet.Parser.Types+import Puppet.Stats+import Puppet.Parser.PrettyPrinter import Text.Parsec.Pos-import Control.Monad.State-import Control.Monad.Error-import qualified Data.Map as Map-import qualified Data.Set as Set-import GHC.Exts-import Data.Aeson++import Data.Aeson as A+import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) import qualified Data.HashMap.Strict as HM-import Control.Applicative+import qualified Data.HashSet as HS import qualified Data.Text as T-import Data.Attoparsec.Number-import qualified Text.Parsec.Pos as TPP+import qualified Data.Text.Encoding as T import qualified Data.Vector as V-import Control.Arrow ( (***) )-import Data.Maybe (fromMaybe)-import Control.Lens hiding ((.=))+import Data.Tuple.Strict+import Control.Monad.RWS.Strict hiding ((<>))+import Control.Monad.Error+import Control.Lens+import Data.String (IsString(..))+import qualified Data.Either.Strict as S+import qualified Data.Maybe.Strict as S+import Data.Hashable+import GHC.Generics hiding (to)+import qualified Data.Traversable as TR+import Control.Exception+import qualified Data.ByteString as BS+import System.Log.Logger+import Data.List (foldl')+import Control.Applicative hiding (empty)+import Data.Time.Clock+import GHC.Stack #ifdef HRUBY import Foreign.Ruby #endif -type ScopeName = T.Text+metaparameters :: HS.HashSet T.Text+metaparameters = HS.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"] --- | Types for the native type system.-type PuppetTypeName = T.Text+type Nodename = T.Text --- | This is the potentially unsolved list of resources in the catalog.-type Catalog =[CResource]-type Facts = Map.Map T.Text ResolvedValue+type Container = HM.HashMap T.Text +data PValue = PBoolean !Bool+ | PUndef+ | PString !T.Text -- integers and doubles are internally serialized as strings by puppet+ | PResourceReference !T.Text !T.Text+ | PArray !(V.Vector PValue)+ | PHash !(Container PValue)+ deriving (Eq, Show)++data RSearchExpression+ = REqualitySearch !T.Text !PValue+ | RNonEqualitySearch !T.Text !PValue+ | RAndSearch !RSearchExpression !RSearchExpression+ | ROrSearch !RSearchExpression !RSearchExpression+ | RAlwaysTrue+ deriving Eq++instance IsString PValue where+ fromString = PString . T.pack++data ClassIncludeType = IncludeStandard | IncludeResource+ deriving (Eq)++type Scope = T.Text++type Facts = Container T.Text++-- |This type is used to differenciate the distinct top level types that are+-- exposed by the DSL.+data TopLevelType+ -- |This is for node entries.+ = TopNode+ -- |This is for defines.+ | TopDefine+ -- |This is for classes.+ | TopClass+ -- |This one is special. It represents top level statements that are not+ -- part of a node, define or class. It is defined as spurious because it is+ -- not what you are supposed to be. Also the caching system doesn't like+ -- them too much right now.+ | TopSpurious+ deriving (Generic,Eq)++instance Hashable TopLevelType++data ResDefaults = ResDefaults { _defType :: !T.Text+ , _defSrcScope :: !T.Text+ , _defValues :: !(Container PValue)+ , _defPos :: !PPosition+ }++data CurContainerDesc = ContRoot | ContClass !T.Text | ContDefine !T.Text !T.Text | ContImported+ deriving Eq++data CurContainer = CurContainer { _cctype :: !CurContainerDesc+ , _cctags :: !(HS.HashSet T.Text)+ }+ deriving Eq++data ResRefOverride = ResRefOverride { _rrid :: !RIdentifier+ , _rrparams :: !(Container PValue)+ , _rrpos :: !PPosition+ }+ deriving Eq++data ScopeInformation = ScopeInformation { _scopeVariables :: !(Container (Pair (Pair PValue PPosition) CurContainerDesc))+ , _scopeDefaults :: !(Container ResDefaults)+ , _scopeExtraTags :: !(HS.HashSet T.Text)+ , _scopeContainer :: !CurContainer+ , _scopeOverrides :: !(HM.HashMap RIdentifier ResRefOverride)+ , _scopeParent :: !(S.Maybe T.Text)+ }++data InterpreterState = InterpreterState { _scopes :: !(Container ScopeInformation)+ , _loadedClasses :: !(Container (Pair ClassIncludeType PPosition))+ , _definedResources :: !(HM.HashMap RIdentifier PPosition)+ , _curScope :: ![Scope]+ , _curPos :: !PPosition+ , _nestedDeclarations :: !(HM.HashMap (TopLevelType, T.Text) Statement)+ , _extraRelations :: ![LinkInformation]+ , _resMod :: ![ResourceModifier]+ }++data InterpreterReader = InterpreterReader { _nativeTypes :: !(Container PuppetTypeMethods)+ , _getStatement :: TopLevelType -> T.Text -> IO (S.Either Doc Statement)+ , _computeTemplateFunction :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text)+ , _pdbAPI :: PuppetDBAPI+ , _externalFunctions :: Container ( [PValue] -> InterpreterMonad PValue )+ , _thisNodename :: T.Text+ }++data Warning = Warning !Doc++data InterpreterWriter = InterpreterWriter { _warnings :: ![Pair Priority Doc] }++warn :: Doc -> InterpreterMonad ()+warn d = tell (InterpreterWriter [WARNING :!: d])++logWriter :: Priority -> Doc -> InterpreterMonad ()+logWriter prio d = tell (InterpreterWriter [prio :!: d])++instance Monoid InterpreterWriter where+ mempty = InterpreterWriter []+ mappend (InterpreterWriter a) (InterpreterWriter b) = {-# SCC "mappendInterpreterWriter" #-} InterpreterWriter (a ++ b)++type InterpreterMonad = ErrorT Doc (RWST InterpreterReader InterpreterWriter InterpreterState IO)++instance Error Doc where+ noMsg = empty+ strMsg = text++data RIdentifier = RIdentifier { _itype :: !T.Text+ , _iname :: !T.Text+ } deriving(Show, Eq, Generic, Ord)++instance Hashable RIdentifier+ -- | Relationship link type.-data LinkType = RNotify | RRequire | RBefore | RSubscribe deriving(Show, Ord, Eq)+data LinkType = RNotify | RRequire | RBefore | RSubscribe deriving(Show, Eq,Generic)+instance Hashable LinkType --- | 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--- many fairly acceptable behaviours and the correct one is not documented.-data RelUpdateType = UNormal | UOverride | UDefault | UPlus deriving (Show, Ord, Eq)+data ModifierType = ModifierCollector -- ^ For collectors, optional resources+ | ModifierMustMatch -- ^ For stuff like realize+ deriving Eq -type LinkInfo = (LinkType, RelUpdateType, SourcePos, [[ScopeName]])+data OverrideType = CantOverride -- ^ Overriding forbidden, will throw an error+ | Replace -- ^ Can silently replace+ | CantReplace --- | 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 !T.Text- | ResolvedRegexp !T.Text- | ResolvedInt !Integer- | ResolvedDouble !Double- | ResolvedBool !Bool- | ResolvedRReference !T.Text !ResolvedValue- | ResolvedArray ![ResolvedValue]- | ResolvedHash ![(T.Text, ResolvedValue)]- | ResolvedUndefined- deriving(Show, Eq, Ord)+data ResourceCollectorType = RealizeVirtual+ | RealizeCollected+ | DontRealize+ deriving Eq -instance IsString ResolvedValue where- fromString = ResolvedString . fromString+data ResourceModifier = ResourceModifier { _rmResType :: !T.Text+ , _rmModifierType :: !ModifierType+ , _rmType :: !ResourceCollectorType+ , _rmSearch :: !RSearchExpression+ , _rmMutation :: !(Resource -> InterpreterMonad Resource)+ , _rmDeclaration :: !PPosition+ } -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+data LinkInformation = LinkInformation { _linksrc :: !RIdentifier+ , _linkdst :: !RIdentifier+ , _linkType :: !LinkType+ , _linkPos :: !PPosition+ } -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+type EdgeMap = HM.HashMap RIdentifier [LinkInformation] -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 is a fully resolved resource that will be used in the+ 'FinalCatalog'.+-}+data Resource = Resource+ { _rid :: !RIdentifier -- ^ Resource name.+ , _ralias :: !(HS.HashSet T.Text) -- ^ All the resource aliases+ , _rattributes :: !(Container PValue) -- ^ Resource parameters.+ , _rrelations :: !(HM.HashMap RIdentifier (HS.HashSet LinkType)) -- ^ Resource relations.+ , _rscope :: ![T.Text] -- ^ Resource scope when it was defined+ , _rcontainer :: !CurContainerDesc -- ^ The class that contains this resource+ , _rvirtuality :: !Virtuality+ , _rtags :: !(HS.HashSet T.Text)+ , _rpos :: !PPosition -- ^ Source code position of the resource definition.+ , _rnode :: !(Maybe T.Text) -- ^ The node were this resource was created, if remote+ }+ deriving Eq +-- |This is a function type than can be bound. It is the type of all+-- subsequent validators.+type PuppetTypeValidate = Resource -> Either Doc Resource +data PuppetTypeMethods = PuppetTypeMethods+ { _puppetValidate :: PuppetTypeValidate+ , _puppetFields :: HS.HashSet T.Text+ }++type FinalCatalog = HM.HashMap RIdentifier Resource++data DaemonMethods = DaemonMethods { _dGetCatalog :: T.Text -> Facts -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog))+ , _dParserStats :: MStats+ , _dCatalogStats :: MStats+ , _dTemplateStats :: MStats+ }++data PuppetEdge = PuppetEdge RIdentifier RIdentifier LinkType++-- | Wire format, see <http://docs.puppetlabs.com/puppetdb/1.5/api/wire_format/catalog_format.html>.+data WireCatalog = WireCatalog { _wirecatalogNodename :: !Nodename+ , _wirecatalogWVersion :: !T.Text+ , _wirecatalogWEdges :: !(V.Vector PuppetEdge)+ , _wirecatalogWResources :: !(V.Vector Resource)+ , _wirecatalogTransactionUUID :: !T.Text+ }++data PFactInfo = PFactInfo { _pfactinfoNodename :: !T.Text+ , _pfactinfoFactname :: !T.Text+ , _pfactinfoFactval :: !T.Text+ }++data PNodeInfo = PNodeInfo { _pnodeinfoNodename :: !Nodename+ , _pnodeinfoDeactivated :: !Bool+ , _pnodeinfoCatalogT :: !(S.Maybe UTCTime)+ , _pnodeinfoFactsT :: !(S.Maybe UTCTime)+ , _pnodeinfoReportT :: !(S.Maybe UTCTime)+ }++data PuppetDBAPI = PuppetDBAPI { pdbInformation :: IO Doc+ , replaceCatalog :: WireCatalog -> IO (S.Either Doc ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>+ , replaceFacts :: [(Nodename, Facts)] -> IO (S.Either Doc ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>+ , deactivateNode :: Nodename -> IO (S.Either Doc ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>+ , getFacts :: Query FactField -> IO (S.Either Doc [PFactInfo]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>+ , getResources :: Query ResourceField -> IO (S.Either Doc [Resource]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>+ , getNodes :: Query NodeField -> IO (S.Either Doc [PNodeInfo])+ , commitDB :: IO (S.Either Doc ()) -- ^ This is only here to tell the test PuppetDB to save its content to disk.+ , getResourcesOfNode :: Nodename -> Query ResourceField -> IO (S.Either Doc [Resource])+ }++-- | Pretty straightforward way to define the various PuppetDB queries+data Query a = QEqual a T.Text+ | QG a Integer+ | QL a Integer+ | QGE a Integer+ | QLE a Integer+ | QMatch T.Text T.Text+ | QAnd [Query a]+ | QOr [Query a]+ | QNot (Query a)+ | QEmpty++-- | Fields for the fact endpoint+data FactField = FName | FValue | FCertname++-- | Fields for the node endpoint+data NodeField = NName | NFact T.Text++-- | Fields for the resource endpoint+data ResourceField = RTag+ | RCertname+ | RParameter T.Text+ | RType+ | RTitle+ | RExported+ | RFile+ | RLine++makeClassy ''RIdentifier+makeClassy ''ResRefOverride+makeClassy ''LinkInformation+makeClassy ''ResDefaults+makeClassy ''ResourceModifier+makeClassy ''DaemonMethods+makeClassy ''PuppetTypeMethods+makeClassy ''ScopeInformation+makeClassy ''Resource+makeClassy ''InterpreterState+makeClassy ''InterpreterReader+makeClassy ''CurContainer+makeFields ''WireCatalog+makeFields ''PFactInfo+makeFields ''PNodeInfo++throwPosError :: Doc -> InterpreterMonad a+throwPosError s = do+ p <- use (curPos . _1)+ stack <- liftIO currentCallStack+ let dstack = if null stack+ then mempty+ else mempty </> string (renderStack stack)+ throwError (s <+> "at" <+> showPos p <> dstack)++getCurContainer :: InterpreterMonad CurContainer+{-# INLINE getCurContainer #-}+getCurContainer = do+ scp <- getScope+ preuse (scopes . ix scp . scopeContainer) >>= \case+ Just x -> return x+ Nothing -> throwPosError ("Internal error: can't find the current container for" <+> string (show scp))++getScope :: InterpreterMonad Scope+{-# INLINE getScope #-}+getScope = use curScope >>= \s -> if null s+ then throwPosError "Internal error: empty scope!"+ else return (head s)++-- instance++instance FromJSON PValue where+ parseJSON Null = return PUndef+ parseJSON (Number n) = return (PString (T.pack (show n)))+ parseJSON (String s) = return (PString s)+ parseJSON (Bool b) = return (PBoolean b)+ parseJSON (Array v) = fmap PArray (V.mapM parseJSON v)+ parseJSON (Object o) = fmap PHash (TR.mapM parseJSON o)++instance ToJSON PValue where+ toJSON (PBoolean b) = Bool b+ toJSON PUndef = Null+ toJSON (PString s) = String s+ toJSON (PResourceReference _ _) = Null -- TODO+ toJSON (PArray r) = Array (V.map toJSON r)+ toJSON (PHash x) = Object (HM.map toJSON x)+ #ifdef HRUBY-instance ToRuby ResolvedValue where- toRuby = toRuby . toJSON-instance FromRuby ResolvedValue where- fromRuby v = do- j <- fromRuby v- case j of- Nothing -> return Nothing- Just x -> case fromJSON x of- Error _ -> return Nothing- Success v -> return (Just v)+instance ToRuby PValue where+ toRuby = toRuby . toJSON+instance FromRuby PValue where+ fromRuby v = fromRuby v >>= \case+ Nothing -> return Nothing+ Just x -> case fromJSON x of+ Error _ -> return Nothing+ Success suc -> return (Just suc) #endif --- | This type holds a value that is either from the ASL or fully resolved.-type GeneralValue = Either Expression ResolvedValue+interpreterIO :: IO (S.Either Doc a) -> InterpreterMonad a+{-# INLINE interpreterIO #-}+interpreterIO f = do+ liftIO (f `catch` (\e -> return $ S.Left $ dullred $ text $ show (e :: SomeException))) >>= \case+ S.Right x -> return x+ S.Left rr -> throwPosError rr --- | This type holds a value that is either from the ASL or a fully resolved--- String.-type GeneralString = Either Expression T.Text+safeDecodeUtf8 :: BS.ByteString -> InterpreterMonad T.Text+{-# INLINE safeDecodeUtf8 #-}+safeDecodeUtf8 i = return (T.decodeUtf8 i) +interpreterError :: InterpreterMonad (S.Either Doc a) -> InterpreterMonad a+{-# INLINE interpreterError #-}+interpreterError f = f >>= \case+ S.Right r -> return r+ S.Left rr -> throwPosError rr -{-| 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-'Statement' order should not alter the catalog's content.+resourceRelations :: Resource -> [(RIdentifier, LinkType)]+resourceRelations = concatMap expandSet . HM.toList . _rrelations+ where+ expandSet (ri, lts) = [(ri, lt) | lt <- HS.toList lts] -The relations are not stored here, as they are pushed into a separate internal-data structure by the interpreter.--}-data CResource = CResource {- _crid :: !Int, -- ^ Resource ID, used in the Puppet YAML.- _crname :: !GeneralString, -- ^ Resource name.- _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)+-- | helper for hashmap, in case we want another kind of map ..+ifromList :: (Monoid m, At m) => [(Index m, IxValue m)] -> m+{-# INLINE ifromList #-}+ifromList = foldl' (\curm (k,v) -> curm & at k ?~ v) mempty -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+ikeys :: (Eq k, Hashable k) => HM.HashMap k v -> HS.HashSet k+{-# INLINE ikeys #-}+ikeys = HS.fromList . HM.keys --- | 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+isingleton :: (Monoid b, At b) => Index b -> IxValue b -> b+{-# INLINE isingleton #-}+isingleton k v = mempty & at k ?~ v --- | Resource identifier, made of a type, name pair.-type ResIdentifier = (T.Text, T.Text)+ifromListWith :: (Monoid m, At m) => (IxValue m -> IxValue m -> IxValue m) -> [(Index m, IxValue m)] -> m+{-# INLINE ifromListWith #-}+ifromListWith f = foldl' (\curmap (k,v) -> iinsertWith f k v curmap) mempty --- | Resource relation, made of a 'LinkType', 'ResIdentifier' pair.-type Relation = (LinkType, ResIdentifier)+iinsertWith :: At m => (IxValue m -> IxValue m -> IxValue m) -> Index m -> IxValue m -> m -> m+{-# INLINE iinsertWith #-}+iinsertWith f k v m = m & at k %~ mightreplace+ where+ mightreplace Nothing = Just v+ mightreplace (Just x) = Just (f v x) -{-| This is a fully resolved resource that will be used in the 'FinalCatalog'.--}-data RResource = RResource {- rrid :: !Int, -- ^ Resource ID.- 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)+iunionWith :: (Hashable k, Eq k) => (v -> v -> v) -> HM.HashMap k v -> HM.HashMap k v -> HM.HashMap k v+{-# INLINE iunionWith #-}+iunionWith = HM.unionWith --- |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 T.Text- }+fnull :: (Eq x, Monoid x) => x -> Bool+{-# INLINE fnull #-}+fnull = (== mempty) -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- ]+rel2text :: LinkType -> T.Text+rel2text RNotify = "notify"+rel2text RRequire = "require"+rel2text RBefore = "before"+rel2text RSubscribe = "subscribe" -type FinalCatalog = Map.Map ResIdentifier RResource+rid2text :: RIdentifier -> T.Text+rid2text (RIdentifier t n) = t `T.append` "[" `T.append` n `T.append` "]" -{-| A data type to hold defaults values- -}-data ResDefaults = RDefaults T.Text (Map.Map GeneralString GeneralValue) SourcePos- | ROverride T.Text GeneralString (Map.Map GeneralString GeneralValue) SourcePos- deriving (Show, Ord, Eq)+instance ToJSON Resource where+ toJSON r = object [ ("type", String $ r ^. rid . itype)+ , ("title", String $ r ^. rid . iname)+ , ("aliases", toJSON $ r ^. ralias)+ , ("exported", Bool $ r ^. rvirtuality == Exported)+ , ("tags", toJSON $ r ^. rtags)+ , ("parameters", Object ( (HM.map toJSON $ r ^. rattributes) `HM.union` relations ))+ , ("sourceline", r ^. rpos . _1 . to sourceLine . to toJSON)+ , ("sourcefile", r ^. rpos . _1 . to sourceName . to toJSON)+ ]+ where+ relations = r ^. rrelations & HM.fromListWith (V.++) . concatMap changeRelations . HM.toList & HM.map toValue+ toValue v | V.length v == 1 = V.head v+ | otherwise = Array v+ changeRelations :: (RIdentifier, HS.HashSet LinkType) -> [(T.Text, V.Vector Value)]+ changeRelations (k,v) = do+ c <- HS.toList v+ return (rel2text c,V.singleton (String (rid2text k))) --- | The monad all the interpreter lives in. It is 'ErrorT' with a state.-type CatalogMonad = ErrorT T.Text (StateT ScopeState IO)+instance FromJSON Resource where+ parseJSON (Object v) = do+ isExported <- v .: "exported"+ let virtuality = if isExported+ then Exported+ else Normal+ -- TODO : properly handle metaparameters+ separate :: (Container PValue, HM.HashMap RIdentifier (HS.HashSet LinkType)) -> T.Text -> PValue -> (Container PValue, HM.HashMap RIdentifier (HS.HashSet LinkType))+ separate (curAttribs, curRelations) k val = (curAttribs & at k ?~ val, curRelations)+ (attribs,relations) <- HM.foldlWithKey' separate (mempty,mempty) <$> v .: "parameters"+ Resource+ <$> (RIdentifier <$> v .: "type" <*> v .: "title")+ <*> v .:? "aliases" .!= mempty+ <*> pure attribs+ <*> pure relations+ <*> pure ["JSON"]+ <*> pure ContImported+ <*> pure virtuality+ <*> v .: "tags"+ <*> (toPPos <$> v .:? "sourcefile" .!= "dummy" <*> v .:? "sourceline" .!= 0)+ <*> pure Nothing --- | The type of collection functions-data CollectionFunction = CollectionFunction { _colFunction :: CResource -> CatalogMonad Bool -- ^ the actual collection function, telling you whether something should be collected- , _colOverrides :: Map.Map GeneralString GeneralValue -- ^ The list of overrides- , _colQuery :: Maybe PDB.Query -- ^ The puppetDB query- }+ parseJSON _ = mempty -{-| The most important data structure for the interpreter. It stores its-internal state.--}-data ScopeState = ScopeState {- _curScope :: ![[ScopeName]],- -- ^ The list of scopes. It works like a stack, and its initial value must- -- 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 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 T.Text SourcePos),- -- ^ The list of classes that have already been included, along with the- -- place where this happened.- _curDefaults :: !(Map.Map [ScopeName] [ResDefaults]),- -- ^ List of defaults to apply. All defaults are applied at the end of the- -- interpretation of each top level statement.- _curResId :: !Int, -- ^ Stores the value of the current 'crid'.- _curPos :: !SourcePos,- -- ^ Current position of the evaluated statement. This is mostly used to- -- give useful error messages.- _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 -> 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 :: ![T.Text], -- ^ List of warnings.- _curCollect :: ![CollectionFunction],- -- ^ 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)], (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 :: 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 :: 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 T.Text),- -- ^ The list of registered user functions- _nativeTypes :: !(Map.Map PuppetTypeName PuppetTypeMethods),- -- ^ The list of native types.- _definedResources :: !(Map.Map ResIdentifier SourcePos),- -- ^ Horrible hack to kind of support the "defined" function- _currentDependencyStack :: [ResIdentifier]-}+instance ToJSON a => ToJSON (Query a) where+ toJSON (QOr qs) = toJSON ("or" : map toJSON qs)+ toJSON (QAnd qs) = toJSON ("and" : map toJSON qs)+ toJSON (QNot q) = toJSON [ "not" , toJSON q ]+ toJSON (QEqual flds val) = toJSON [ "=", toJSON flds, toJSON val ]+ toJSON (QMatch flds val) = toJSON [ "~", toJSON flds, toJSON val ]+ toJSON (QL flds val) = toJSON [ "<", toJSON flds, toJSON val ]+ toJSON (QG flds val) = toJSON [ ">", toJSON flds, toJSON val ]+ toJSON (QLE flds val) = toJSON [ "<=", toJSON flds, toJSON val ]+ toJSON (QGE flds val) = toJSON [ ">=", toJSON flds, toJSON val ]+ toJSON (QEmpty) = Null -makeClassy ''ScopeState-makeClassy ''CollectionFunction-makeClassy ''RResource-makeClassy ''CResource+instance FromJSON a => FromJSON (Query a) where+ parseJSON Null = pure QEmpty+ parseJSON (Array elems) = case V.toList elems of+ ("or":xs) -> QOr <$> mapM parseJSON xs+ ("and":xs) -> QAnd <$> mapM parseJSON xs+ ["not",x] -> QNot <$> parseJSON x+ [ "=", flds, val ] -> QEqual <$> parseJSON flds <*> parseJSON val+ [ "~", flds, val ] -> QEqual <$> parseJSON flds <*> parseJSON val+ [ ">", flds, val ] -> QG <$> parseJSON flds <*> parseJSON val+ [ "<", flds, val ] -> QL <$> parseJSON flds <*> parseJSON val+ [">=", flds, val ] -> QGE <$> parseJSON flds <*> parseJSON val+ ["<=", flds, val ] -> QLE <$> parseJSON flds <*> parseJSON val+ x -> fail ("unknown query" ++ show x)+ parseJSON _ = fail "Expected an array" -instance Error T.Text where- noMsg = ""- strMsg = T.pack+instance ToJSON FactField where+ toJSON FName = "name"+ toJSON FValue = "value"+ toJSON FCertname = "certname" --- | This is the map of all edges associated with the 'FinalCatalog'.--- The key is (source, target).-type EdgeMap = Map.Map (ResIdentifier, ResIdentifier) LinkInfo+instance FromJSON FactField where+ parseJSON "name" = pure FName+ parseJSON "value" = pure FValue+ parseJSON "certname" = pure FCertname+ parseJSON _ = fail "Can't parse fact field" -generalizeValueE :: Expression -> GeneralValue-generalizeValueE = Left-generalizeValueR :: ResolvedValue -> GeneralValue-generalizeValueR = Right-generalizeStringE :: Expression -> GeneralString-generalizeStringE = Left-generalizeStringS :: T.Text -> GeneralString-generalizeStringS = Right+instance ToJSON NodeField where+ toJSON NName = "name"+ toJSON (NFact t) = toJSON [ "fact", t ] --- |This is the set of meta parameters-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+instance FromJSON NodeField where+ parseJSON (Array xs) = case V.toList xs of+ ["fact", x] -> NFact <$> parseJSON x+ _ -> fail "Invalid field syntax"+ parseJSON (String "name") = pure NName+ parseJSON _ = fail "invalid field" -{--getPos = liftM curPos get-modifyScope f sc = sc { curScope = f $ curScope sc }-modifyDeps f sc = sc { currentDependencyStack = f $ currentDependencyStack sc }-modifyVariables f sc = sc { curVariables = f $ curVariables sc }-modifyClasses f sc = sc { curClasses = f $ curClasses sc }-incrementResId sc = sc { curResId = curResId sc + 1 }-setStatePos npos sc = sc { curPos = npos }-pushWarning t sc = sc { getWarnings = getWarnings sc ++ [t] }-pushCollect r sc = sc { curCollect = r : curCollect sc }-pushUnresRel r sc = sc { unresolvedRels = r : unresolvedRels sc }-addDefinedResource r p = modify (\st -> st { definedResources = Map.insert r p (definedResources st) } )-saveVariables vars = modify (\st -> st { curVariables = vars })--}+instance ToJSON ResourceField where+ toJSON RTag = "tag"+ toJSON RCertname = "certname"+ toJSON (RParameter t) = toJSON ["parameter", t]+ toJSON RType = "type"+ toJSON RTitle = "title"+ toJSON RExported = "exported"+ toJSON RFile = "file"+ toJSON RLine = "line" -addDefinedResource :: ResIdentifier -> SourcePos -> CatalogMonad ()-addDefinedResource r p = definedResources.at r ?= p+instance FromJSON ResourceField where+ parseJSON (Array xs) = case V.toList xs of+ ["parameter", x] -> RParameter <$> parseJSON x+ _ -> fail "Invalid field syntax"+ parseJSON (String "tag" ) = pure RTag+ parseJSON (String "certname") = pure RCertname+ parseJSON (String "type" ) = pure RType+ parseJSON (String "title" ) = pure RTitle+ parseJSON (String "exported") = pure RExported+ parseJSON (String "file" ) = pure RFile+ parseJSON (String "line" ) = pure RLine+ parseJSON _ = fail "invalid field" -showScope :: [[ScopeName]] -> T.Text-showScope = tshow . reverse . concatMap (take 1)+instance FromJSON LinkType where+ parseJSON (String "require") = pure RRequire+ parseJSON (String "notify") = pure RNotify+ parseJSON (String "subscribe") = pure RSubscribe+ parseJSON (String "before") = pure RBefore+ parseJSON _ = fail "invalid linktype" -throwPosError :: T.Text -> CatalogMonad a-throwPosError msg = do- p <- use curPos- st <- fmap (map T.pack) (liftIO currentCallStack)- throwError (msg <> " at " <> tshow p <> "\n\t" <> T.intercalate "\n\t" st)+instance ToJSON LinkType where+ toJSON = String . rel2text -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)+instance FromJSON RIdentifier where+ parseJSON (Object v) = RIdentifier <$> v .: "type" <*> v .: "title"+ parseJSON _ = fail "invalid resource" -insertparam :: RResource -> T.Text -> ResolvedValue -> RResource-insertparam res param value = res { rrparams = Map.insert param value (rrparams res) }+instance ToJSON RIdentifier where+ toJSON (RIdentifier t n) = object [("type", String t), ("title", String n)] +instance FromJSON PuppetEdge where+ parseJSON (Object v) = PuppetEdge <$> v .: "source" <*> v .: "target" <*> v .: "relationship"+ parseJSON _ = fail "invalid puppet edge"++instance ToJSON PuppetEdge where+ toJSON (PuppetEdge s t r) = object [("source", toJSON s), ("target", toJSON t), ("relationship", toJSON r)]++instance FromJSON WireCatalog where+ parseJSON (Object d) = d .: "data" >>= \case+ (Object v) -> WireCatalog+ <$> v .: "name"+ <*> v .: "version"+ <*> v .: "edges"+ <*> v .: "resources"+ <*> v .: "transaction-uuid"+ _ -> fail "Data is not an object"+ parseJSON _ = fail "invalid wire catalog"++instance ToJSON WireCatalog where+ toJSON (WireCatalog n v e r t) = object [("metadata", object [("api_version", Number 1)]), ("data", object d)]+ where d = [ ("name", String n)+ , ("version", String v)+ , ("edges", toJSON e)+ , ("resources", toJSON r)+ , ("transaction-uuid", String t)+ ]++instance ToJSON PFactInfo where+ toJSON (PFactInfo n f v) = object [("certname", String n), ("name", String f), ("value", String v)]++instance FromJSON PFactInfo where+ parseJSON (Object v) = PFactInfo <$> v .: "certname" <*> v .: "name" <*> v .: "value"+ parseJSON _ = fail "invalid fact info"++instance ToJSON PNodeInfo where+ toJSON p = object [ ("name" , toJSON (p ^. nodename))+ , ("deactivated" , toJSON (p ^. deactivated))+ , ("catalog_timestamp", toJSON (p ^. catalogT))+ , ("facts_timestamp" , toJSON (p ^. factsT))+ , ("report_timestamp" , toJSON (p ^. reportT))+ ]++instance FromJSON PNodeInfo where+ parseJSON (Object v) = PNodeInfo <$> v .: "name"+ <*> v .:? "deactivated" .!= False+ <*> v .: "catalog_timestamp"+ <*> v .: "facts_timestamp"+ <*> v .: "report_timestamp"+ parseJSON _ = fail "invalide node info"
− Puppet/JsonCatalog.hs
@@ -1,71 +0,0 @@-module Puppet.JsonCatalog where--import Puppet.DSL.Types hiding (Value)-import Puppet.Interpreter.Types-import Puppet.Printers--import qualified Data.Text as T-import qualified Data.HashMap.Strict as HM-import qualified Data.Map as Map-import Data.Aeson-import qualified Data.Vector as V-import Data.Attoparsec.Number-import Text.Parsec.Pos-import qualified Data.ByteString.Lazy as BSL--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)]))]- where- datahash = Object $ HM.fromList [ ("classes" , Array (V.fromList classes))- , ("edges" , Array (V.fromList ledges))- , ("environment", String "production")- , ("name" , String nodename)- , ("resources" , Array (V.fromList resources))- , ("tags" , Array V.empty)- , ("version" , Number (I version))- ]- lcat = Map.toList cat- 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 [] [["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 _ 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"- then capitalizeResType ctitle- else ctitle- ctitle = case Map.lookup "title" rp of- Just (ResolvedString s) -> s- _ -> rn- paramlist = map (\(k,v) -> (k, rv2json v)) $ Map.toList $ Map.delete "title" rp--rv2json :: ResolvedValue -> Value-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) -> (k, rv2json v)) h-rv2json _ = Null--catalog2JSon :: T.Text -> Integer -> FinalCatalog -> FinalCatalog -> EdgeMap -> BSL.ByteString-catalog2JSon nodename version dc de dm = encode (mkJsonCatalog nodename version dc de dm)
+ Puppet/Manifests.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE LambdaCase #-}+module Puppet.Manifests (filterStatements) where++import Puppet.PP+import Puppet.Parser.Types+import Puppet.Interpreter.Types++import Text.Regex.PCRE.ByteString+import Control.Lens+import Control.Applicative+import Control.Monad.Error+import qualified Data.Vector as V+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Tuple.Strict+import qualified Data.Either.Strict as S+import qualified Data.HashMap.Strict as HM++-- TODO pre-triage stuff+filterStatements :: TopLevelType -> T.Text -> V.Vector Statement -> IO (S.Either Doc Statement)+-- the most complicated case, node matching+filterStatements TopNode nodename stmts =+ -- this operation should probably get cached+ let (!spurious, !directnodes, !regexpmatches, !defaultnode) = V.foldl' triage (V.empty, HM.empty, V.empty, Nothing) stmts+ triage curstuff n@(Node (NodeName !nm) _ _ _) = curstuff & _2 . at nm ?~ n+ triage curstuff n@(Node (NodeMatch _ !rg) _ _ _) = curstuff & _3 %~ (|> (rg :!: n))+ triage curstuff n@(Node NodeDefault _ _ _) = curstuff & _4 ?~ n+ triage curstuff x = curstuff & _1 %~ (|> x)+ bsnodename = T.encodeUtf8 nodename+ checkRegexp :: [Pair Regex Statement] -> ErrorT Doc IO (Maybe Statement)+ checkRegexp [] = return Nothing+ checkRegexp ((regexp :!: s):xs) = do+ liftIO (execute regexp bsnodename) >>= \case+ Left rr -> throwError ("Regexp match error:" <+> text (show rr))+ Right Nothing -> checkRegexp xs+ Right (Just _) -> return (Just s)+ strictEither (Left x) = S.Left x+ strictEither (Right x) = S.Right x+ in case directnodes ^. at nodename of -- check if there is a node specifically called after my name+ Just r -> return (S.Right (TopContainer spurious r))+ Nothing -> fmap strictEither $ runErrorT $ do+ regexpMatchM <- checkRegexp (V.toList regexpmatches) -- match regexps+ case regexpMatchM <|> defaultnode of -- check for regexp matches or use the default node+ Just r -> return (TopContainer spurious r)+ Nothing -> throwError ("Couldn't find node" <+> ttext nodename)+filterStatements x nodename stmts =+ let (!spurious, !defines, !classes) = V.foldl' triage (V.empty, HM.empty, HM.empty) stmts+ triage curstuff n@(ClassDeclaration cname _ _ _ _) = curstuff & _3 . at cname ?~ n+ triage curstuff n@(DefineDeclaration cname _ _ _) = curstuff & _2 . at cname ?~ n+ triage curstuff n = curstuff & _1 %~ (|> n)+ tc n = if V.null spurious+ then n+ else TopContainer spurious n+ in case x of+ TopNode -> return (S.Left "Case already covered, shoudln't happen in Puppet.Manifests")+ TopSpurious -> return (S.Left "Should not ask for a TopSpurious!!!")+ TopDefine -> case defines ^. at nodename of+ Just n -> return (S.Right (tc n))+ Nothing -> return (S.Left ("Couldn't find define " <+> ttext nodename))+ TopClass -> case classes ^. at nodename of+ Just n -> return (S.Right (tc n))+ Nothing -> return (S.Left ("Couldn't find class " <+> ttext nodename))
Puppet/NativeTypes.hs view
@@ -1,5 +1,5 @@ {-| This module holds the /native/ Puppet resource types. -}-module Puppet.NativeTypes (baseNativeTypes) where+module Puppet.NativeTypes (baseNativeTypes,validateNativeType) where import Puppet.NativeTypes.Helpers import Puppet.NativeTypes.File@@ -13,15 +13,18 @@ import Puppet.NativeTypes.ZoneRecord import Puppet.NativeTypes.SshSecure import Puppet.Interpreter.Types-import qualified Data.Map as Map+import qualified Data.HashMap.Strict as HM+import Control.Lens +fakeTypes :: [(PuppetTypeName, PuppetTypeMethods)] fakeTypes = map faketype ["class"] +defaultTypes :: [(PuppetTypeName, PuppetTypeMethods)] 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-baseNativeTypes = Map.fromList+baseNativeTypes :: Container PuppetTypeMethods+baseNativeTypes = HM.fromList ( nativeHost : nativeMount : nativeGroup@@ -33,3 +36,15 @@ : nativeUser : nativeSshSecure : fakeTypes ++ defaultTypes)++-- | Contrary to the previous iteration, this will let non native types+-- pass+validateNativeType :: Resource -> InterpreterMonad Resource+validateNativeType r = do+ tps <- view nativeTypes+ case tps ^. at (r ^. rid . itype) of+ Just x -> case (x ^. puppetValidate) r of+ Right nr -> return nr+ Left err -> throwPosError ("Invalid resource" <+> pretty r </> err)+ Nothing -> return r+
Puppet/NativeTypes/Cron.hs view
@@ -1,18 +1,23 @@ module Puppet.NativeTypes.Cron (nativeCron) where +import qualified Text.PrettyPrint.ANSI.Leijen as P import Puppet.NativeTypes.Helpers import Control.Monad.Error import Puppet.Interpreter.Types-import qualified Data.Set as Set-import qualified Data.Map as Map-import Data.Char+import Puppet.Utils+import qualified Data.HashSet as HS import qualified Data.Text as T+import Control.Lens+import qualified Data.Vector as V 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.-parameterset = Set.fromList $ map fst parameterfunctions+parameterset :: HS.HashSet T.Text+parameterset = HS.fromList $ map fst parameterfunctions++parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] parameterfunctions = [("command" , [string, mandatory]) ,("ensure" , [defaultvalue "present", string, values ["present","absent"]])@@ -26,41 +31,39 @@ ,("special" , [string]) ,("target" , [string]) ,("user" , [defaultvalue "root", string])- ,("weekday" , [vrange 0 7 ["Monday","Tuesday","Wednesday","Thursday","Friday","Saturday"]])+ ,("weekday" , [vrange 0 7 ["Monday","Tuesday","Wednesday","Thursday","Friday","Saturday","Sunday"]]) ] validateCron :: PuppetTypeValidate validateCron = defaultValidate parameterset >=> parameterFunctions parameterfunctions 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 mi ma valuelist param res = case res ^. rattributes . at param of+ Just (PArray xs) -> V.foldM (vrange' mi ma valuelist param) res xs+ Just x -> vrange' mi ma valuelist param res x+ Nothing -> defaultvalue "*" param res -vrange' :: Integer -> Integer -> [T.Text] -> T.Text -> RResource -> ResolvedValue -> Either String RResource+vrange' :: Integer -> Integer -> [T.Text] -> T.Text -> Resource -> PValue -> Either Doc Resource vrange' mi ma valuelist param res y = case y of- ResolvedString "*" -> Right res- ResolvedString "absent" -> Right res- ResolvedString x -> if elem x valuelist+ PString "*" -> Right res+ PString "absent" -> Right res+ PString x -> if x `elem` valuelist then Right res else parseval x mi ma param res- ResolvedInt i -> checkint' i mi ma param res- x -> Left $ "Parameter " ++ T.unpack param ++ " value should be a valid cron declaration and not " ++ show x+ x -> Left $ "Parameter" <+> paramname param <+> "value should be a valid cron declaration and not" <+> pretty x 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+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 :: T.Text -> Integer -> Integer -> T.Text -> PuppetTypeValidate-checkint st mi ma pname res = if T.all isDigit st- then- let v = read (T.unpack st) :: Integer- in checkint' v mi ma pname res- else Left $ "Invalid value type for parameter " ++ T.unpack pname+checkint st mi ma pname res =+ case readDecimal st of+ Right v -> checkint' v mi ma pname res+ Left rr -> Left $ "Invalid value type for parameter" <+> paramname pname <+> ": " <+> red (text rr) checkint' :: Integer -> Integer -> Integer -> T.Text -> PuppetTypeValidate checkint' i mi ma param res = if (i>=mi) && (i<=ma) then Right res- else Left $ "Parameter " ++ T.unpack param ++ " value is out of bound, should statisfy " ++ show mi ++ "<=" ++ show i ++ "<=" ++ show ma+ else Left $ "Parameter" <+> paramname param <+> "value is out of bound, should statisfy" <+> P.integer mi <+> "<=" <+> P.integer i <+> "<=" <+> P.integer ma
Puppet/NativeTypes/Exec.hs view
@@ -3,15 +3,18 @@ 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.HashSet as HS import qualified Data.Text as T+import Control.Lens 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.-parameterset = Set.fromList $ map fst parameterfunctions+parameterset :: HS.HashSet T.Text+parameterset = HS.fromList $ map fst parameterfunctions++parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] parameterfunctions = [("command" , [nameval]) ,("creates" , [rarray, strings, fullyQualifieds])@@ -36,8 +39,8 @@ 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 == '/'+fullyQualifiedOrPath res = case (res ^. rattributes . at "path", res ^. rattributes . at "command") of+ (Nothing, Just (PString 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
@@ -3,16 +3,20 @@ import Puppet.NativeTypes.Helpers import Control.Monad.Error import Puppet.Interpreter.Types-import qualified Data.Map as Map-import qualified Data.Set as Set+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS import Data.Char (isDigit) import qualified Data.Text as T+import Control.Lens 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.-parameterset = Set.fromList $ map fst parameterfunctions+parameterset :: HS.HashSet T.Text+parameterset = HS.fromList $ map fst parameterfunctions++parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] parameterfunctions = [("backup" , [string]) ,("checksum" , [values ["md5", "md5lite", "mtime", "ctime", "none"]])@@ -41,21 +45,21 @@ validateMode :: PuppetTypeValidate validateMode res = let- modestr = case ((rrparams res) Map.! "mode") of- ResolvedString s -> s+ modestr = case res ^. rattributes . at "mode" of+ Just (PString s) -> s _ -> "0644" in do 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")+ unless (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))+ then return $ res & rattributes . at "mode" ?~ PString (T.cons '0' modestr) else return res validateSourceOrContent :: PuppetTypeValidate validateSourceOrContent res = let- parammap = rrparams res- source = Map.member "source" parammap- content = Map.member "content" parammap+ parammap = res ^. rattributes+ source = HM.member "source" parammap+ content = HM.member "content" parammap in if source && content then Left "Source and content can't be specified at the same time" else Right res
Puppet/NativeTypes/Group.hs view
@@ -3,14 +3,18 @@ import Puppet.NativeTypes.Helpers import Puppet.Interpreter.Types import Control.Monad.Error-import qualified Data.Set as Set+import qualified Data.HashSet as HS+import qualified Data.Text as T 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.-parameterset = Set.fromList $ map fst parameterfunctions-parameterfunctions = +parameterset :: HS.HashSet T.Text+parameterset = HS.fromList $ map fst parameterfunctions++parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])]+parameterfunctions = [("allowdupe" , [string, defaultvalue "false", values ["true","false"]]) ,("attribute_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) ,("attributes" , [strings])
Puppet/NativeTypes/Helpers.hs view
@@ -1,176 +1,200 @@ {-| These are the function and data types that are used to define the Puppet native types. -}-module Puppet.NativeTypes.Helpers where+module Puppet.NativeTypes.Helpers + ( module Puppet.PP+ , ipaddr+ , paramname+ , rarray+ , string+ , strings+ , noTrailingSlash+ , fullyQualified+ , fullyQualifieds+ , values+ , defaultvalue+ , nameval+ , defaultValidate+ , PuppetTypeName+ , parameterFunctions+ , integer+ , integers+ , mandatory+ , inrange+ , faketype+ , defaulttype+ ) where +import Puppet.PP hiding (string,integer)+import qualified Text.PrettyPrint.ANSI.Leijen as P import Puppet.Interpreter.Types-import qualified Data.Map as Map-import qualified Data.Set as Set+import Puppet.Interpreter.PrettyPrinter()+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS import Data.Char (isDigit) import Control.Monad import qualified Data.Text as T import Puppet.Utils+import Control.Lens+import qualified Data.Vector as V +type PuppetTypeName = T.Text++paramname :: T.Text -> Doc+paramname = red . ttext+ faketype :: PuppetTypeName -> (PuppetTypeName, PuppetTypeMethods)-faketype tname = (tname, PuppetTypeMethods Right Set.empty)+faketype tname = (tname, PuppetTypeMethods Right HS.empty) defaulttype :: PuppetTypeName -> (PuppetTypeName, PuppetTypeMethods)-defaulttype tname = (tname, PuppetTypeMethods (defaultValidate Set.empty) Set.empty)+defaulttype tname = (tname, PuppetTypeMethods (defaultValidate HS.empty) HS.empty) {-| This helper will validate resources given a list of fields. It will run 'checkParameterList' and then 'addDefaults'. -}-defaultValidate :: Set.Set T.Text -> PuppetTypeValidate+defaultValidate :: HS.HashSet T.Text -> PuppetTypeValidate defaultValidate validparameters = checkParameterList validparameters >=> addDefaults -- | This validator checks that no unknown parameters have been set (except metaparameters)-checkParameterList :: Set.Set T.Text -> PuppetTypeValidate-checkParameterList validparameters res | Set.null validparameters = Right res- | otherwise = if Set.null setdiff+checkParameterList :: HS.HashSet T.Text -> PuppetTypeValidate+checkParameterList validparameters res | HS.null validparameters = Right res+ | otherwise = if HS.null setdiff then Right res- else Left $ "Unknown parameters " ++ show (Set.toList setdiff)+ else Left $ "Unknown parameters: " <+> list (map paramname $ HS.toList setdiff) where- keyset = Map.keysSet (rrparams res)- setdiff = Set.difference keyset (Set.union metaparameters validparameters)+ keyset = HS.fromList $ HM.keys (res ^. rattributes)+ setdiff = HS.difference keyset (metaparameters `HS.union` validparameters) -- | This validator always accept the resources, but add the default parameters -- (such as title). addDefaults :: PuppetTypeValidate-addDefaults res = Right (res { rrparams = newparams } )+addDefaults res = Right (res & rattributes %~ newparams) where- newparams = Map.filter (/= ResolvedUndefined) $ Map.union (rrparams res) defaults- defaults = Map.fromList [("title", nm)]- nm = ResolvedString $ rrname res+ def PUndef = False+ def _ = True+ newparams p = HM.filter def $ HM.union p defaults+ defaults = HM.fromList [("title", PString (res ^. rid ^. iname))] --- | Helper function that runs a validor on a ResolvedArray-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 " ++ T.unpack param ++ " should be an array, not " ++ show x- Nothing -> Right res+-- | Helper function that runs a validor on a PArray+runarray :: T.Text -> (T.Text -> PValue -> PuppetTypeValidate) -> PuppetTypeValidate+runarray param func res = case res ^. rattributes . at param of+ Just (PArray x) -> V.foldM (flip (func param)) res x+ Just x -> Left $ "Parameter" <+> paramname param <+> "should be an array, not" <+> pretty 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 :: T.Text -> PuppetTypeValidate-string param res = case Map.lookup param (rrparams res) of+string param res = case res ^. rattributes . at param of Just x -> string' param x res Nothing -> Right res strings :: T.Text -> PuppetTypeValidate strings param = runarray param string' -string' :: T.Text -> ResolvedValue -> PuppetTypeValidate-string' param re res = case re of- ResolvedString _ -> Right res- 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 " ++ T.unpack param ++ " should be a string, and not " ++ show x+string' :: T.Text -> PValue -> PuppetTypeValidate+string' param rev res = case rev of+ PString _ -> Right res+ PBoolean True -> Right (res & rattributes . at param ?~ PString "true")+ PBoolean False -> Right (res & rattributes . at param ?~ PString "false")+ x -> Left $ "Parameter" <+> paramname param <+> "should be a string, and not" <+> pretty x -- | Makes sure that the parameter, if defined, has a value among this list. values :: [T.Text] -> T.Text -> PuppetTypeValidate-values valuelist param res = case (Map.lookup param (rrparams res)) of- Just (ResolvedString x) -> if elem x valuelist+values valuelist param res = case res ^. rattributes . at param of+ Just (PString x) -> if x `elem` valuelist then Right res- 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+ else Left $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ttext valuelist) <+> "and not" <+> ttext x+ Just x -> Left $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ttext valuelist) <+> "and not" <+> pretty x Nothing -> Right res -- | This fills the default values of unset parameters. defaultvalue :: T.Text -> T.Text -> PuppetTypeValidate-defaultvalue value param res = case (Map.lookup param (rrparams res)) of+defaultvalue value param res = case res ^. rattributes . at param of Just _ -> Right res- Nothing -> Right $ insertparam res param (ResolvedString value)+ Nothing -> Right $ res & rattributes . at param ?~ PString value -- | Checks that a given parameter, if set, is a 'ResolvedInt'. If it is a--- 'ResolvedString' it will attempt to parse it.+-- 'PString' it will attempt to parse it. integer :: T.Text -> PuppetTypeValidate integer prm res = string prm res >>= integer' prm where- integer' pr rs = case (Map.lookup pr (rrparams rs)) of+ integer' pr rs = case rs ^. rattributes . at pr of Just x -> integer'' prm x res Nothing -> Right rs integers :: T.Text -> PuppetTypeValidate integers param = runarray param integer'' -integer'' :: T.Text -> ResolvedValue -> PuppetTypeValidate+integer'' :: T.Text -> PValue -> PuppetTypeValidate integer'' param val res = case val of- 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 " ++ T.unpack param ++ " must be an integer"+ PString x -> if T.all isDigit x+ then Right res+ else Left $ "Parameter" <+> paramname param <+> "should be an integer"+ _ -> Left $ "Parameter" <+> paramname param <+> "must be an integer" -- | Copies the "name" value into the parameter if this is not set. It implies -- the `string` validator. nameval :: T.Text -> PuppetTypeValidate-nameval prm res = do- 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+nameval prm res = string prm res+ >>= \r -> case r ^. rattributes . at prm of+ Just (PString al) -> Right (res & rid . iname .~ al)+ Just x -> Left ("The alias must be a string, not" <+> pretty x)+ Nothing -> Right (r & rattributes . at prm ?~ PString (r ^. rid . iname)) -- | Checks that a given parameter is set. mandatory :: T.Text -> PuppetTypeValidate-mandatory param res = case Map.lookup param (rrparams res) of+mandatory param res = case res ^. rattributes . at param of Just _ -> Right res- Nothing -> Left $ "Parameter " ++ T.unpack param ++ " should be set."+ Nothing -> Left $ "Parameter" <+> paramname param <+> "should be set." -- | Helper that takes a list of stuff and will generate a validator. parameterFunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] -> PuppetTypeValidate parameterFunctions argrules rs = foldM parameterFunctions' rs argrules where- parameterFunctions' :: RResource -> (T.Text, [T.Text -> PuppetTypeValidate]) -> Either String RResource+ parameterFunctions' :: Resource -> (T.Text, [T.Text -> PuppetTypeValidate]) -> Either Doc Resource parameterFunctions' r (param, validationfunctions) = foldM (parameterFunctions'' param) r validationfunctions- parameterFunctions'' :: T.Text -> RResource -> (T.Text -> PuppetTypeValidate) -> Either String RResource+ parameterFunctions'' :: T.Text -> Resource -> (T.Text -> PuppetTypeValidate) -> Either Doc Resource parameterFunctions'' param r validationfunction = validationfunction param r -- checks that a parameter is fully qualified fullyQualified :: T.Text -> PuppetTypeValidate-fullyQualified param res = case Map.lookup param (rrparams res) of+fullyQualified param res = case res ^. rattributes . at param of Just path -> fullyQualified' param path res Nothing -> Right res 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")+noTrailingSlash param res = case res ^. rattributes . at param of+ Just (PString x) -> if T.last x == '/'+ then Left ("Parameter" <+> paramname param <+> "should not have a trailing slash") else Right res _ -> Right res fullyQualifieds :: T.Text -> PuppetTypeValidate fullyQualifieds param = runarray param fullyQualified' -fullyQualified' :: T.Text -> ResolvedValue -> PuppetTypeValidate+fullyQualified' :: T.Text -> PValue -> PuppetTypeValidate fullyQualified' param path res = case path of- ResolvedString ("") -> Left $ "Empty path for parameter " ++ T.unpack param- ResolvedString p -> if T.head p == '/'+ PString ("") -> Left $ "Empty path for parameter" <+> paramname param+ PString 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+ else Left $ "Path must be absolute, not" <+> ttext p <+> "for parameter" <+> paramname param+ x -> Left $ "SHOULD NOT HAPPEN: path is not a resolved string, but" <+> pretty x <+> "for parameter" <+> paramname param 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+rarray param res = case res ^. rattributes . at param of+ Just (PArray _) -> Right res+ Just x -> Right $ res & rattributes . at param ?~ PArray (V.singleton x)+ Nothing -> Right res ipaddr :: T.Text -> PuppetTypeValidate-ipaddr param res = case Map.lookup param (rrparams res) of+ipaddr param res = case res ^. rattributes . at param of Nothing -> Right res- Just (ResolvedString ip) ->+ Just (PString ip) -> if checkipv4 ip 0 then Right res- 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+ else Left $ "Invalid IP address for parameter" <+> paramname param+ Just x -> Left $ "Parameter" <+> paramname param <+> "should be an IP address string, not" <+> pretty x checkipv4 :: T.Text -> Int -> Bool checkipv4 _ 4 = False -- means that there are more than 4 groups@@ -184,10 +208,16 @@ in goodcur && nextfunc 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 " ++ 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+inrange mi ma param res =+ let va = res ^. rattributes . at param+ na = va >>= puppet2number+ in case (va,na) of+ (Nothing, _) -> Right res+ (_,Just (Left v)) -> if (v >= fromIntegral mi) && (v <= fromIntegral ma)+ then Right res+ else Left $ "Parameter" <+> paramname param P.<> "'s value should be between" <+> P.integer mi <+> "and" <+> P.integer ma+ (_,Just (Right v)) -> if (v>=mi) && (v<=ma)+ then Right res+ else Left $ "Parameter" <+> paramname param P.<> "'s value should be between" <+> P.integer mi <+> "and" <+> P.integer ma+ (Just x,_) -> Left $ "Parameter" <+> paramname param <+> "should be an integer, and not" <+> pretty x
Puppet/NativeTypes/Host.hs view
@@ -3,16 +3,20 @@ import Puppet.NativeTypes.Helpers import Control.Monad.Error import Puppet.Interpreter.Types-import qualified Data.Map as Map-import qualified Data.Set as Set+import qualified Data.HashSet as HS import Data.Char (isAlphaNum) import qualified Data.Text as T+import Control.Lens+import qualified Data.Vector as V 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.-parameterset = Set.fromList $ map fst parameterfunctions+parameterset :: HS.HashSet T.Text+parameterset = HS.fromList $ map fst parameterfunctions++parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] parameterfunctions = [("comment" , [string, values ["true","false"]]) ,("ensure" , [defaultvalue "present", string, values ["present","absent"]])@@ -27,25 +31,25 @@ validateHost = defaultValidate parameterset >=> parameterFunctions parameterfunctions checkhostname :: T.Text -> PuppetTypeValidate-checkhostname param res = case Map.lookup param (rrparams res) of+checkhostname param res = case res ^. rattributes . at param of Nothing -> Right res- Just (ResolvedArray xs) -> foldM (checkhostname' param) res xs- Just x@(ResolvedString _) -> checkhostname' param res x- Just x -> Left $ T.unpack param ++ " should be an array or a single string, not " ++ show x+ Just (PArray xs) -> V.foldM (checkhostname' param) res xs+ Just x@(PString _) -> checkhostname' param res x+ Just x -> Left $ paramname param <+> "should be an array or a single string, not" <+> pretty x -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 " ++ T.unpack prm ++ "should be an string or an array of strings, but this was found : " ++ show x+checkhostname' :: T.Text -> Resource -> PValue -> Either Doc Resource+checkhostname' prm _ (PString "") = Left $ "Empty hostname for parameter" <+> paramname prm+checkhostname' prm res (PString x ) = checkhostname'' prm res x+checkhostname' prm _ x = Left $ "Parameter " <+> paramname prm <+> "should be an string or an array of strings, but this was found :" <+> pretty x -checkhostname'' :: T.Text -> RResource -> T.Text -> Either String RResource-checkhostname'' prm _ "" = Left $ "Empty hostname part in parameter " ++ T.unpack prm+checkhostname'' :: T.Text -> Resource -> T.Text -> Either Doc Resource+checkhostname'' prm _ "" = Left $ "Empty hostname part in parameter" <+> paramname prm checkhostname'' prm res prt = let (cur,nxt) = T.break (=='.') prt nextfunc = if T.null nxt then Right res 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+ then Left $ "Invalid hostname part for parameter" <+> paramname prm else nextfunc
Puppet/NativeTypes/Mount.hs view
@@ -3,12 +3,16 @@ import Puppet.NativeTypes.Helpers import Puppet.Interpreter.Types import Control.Monad.Error-import qualified Data.Set as Set+import qualified Data.HashSet as HS+import qualified Data.Text as T nativeMount :: (PuppetTypeName, PuppetTypeMethods) nativeMount = ("mount", PuppetTypeMethods validateMount parameterset) -parameterset = Set.fromList $ map fst parameterfunctions+parameterset :: HS.HashSet T.Text+parameterset = HS.fromList $ map fst parameterfunctions++parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] parameterfunctions = [("atboot" , [string, values ["true","false"]]) ,("blockdevice" , [string])
Puppet/NativeTypes/Package.hs view
@@ -1,55 +1,62 @@+{-# LANGUAGE DeriveGeneric #-} 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.HashSet as HS+import qualified Data.HashMap.Strict as HM import qualified Data.Text as T+import Control.Lens+import GHC.Generics+import Data.Hashable nativePackage :: (PuppetTypeName, PuppetTypeMethods) nativePackage = ("package", PuppetTypeMethods validatePackage parameterset) -data PackagingFeatures = Holdable | InstallOptions | Installable | Purgeable | UninstallOptions | Uninstallable | Upgradeable | Versionable deriving (Show, Ord, Eq)+data PackagingFeatures = Holdable | InstallOptions | Installable | Purgeable | UninstallOptions | Uninstallable | Upgradeable | Versionable deriving (Show, Eq, Generic) -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])- ]+instance Hashable PackagingFeatures -parameterset = Set.fromList $ map fst parameterfunctions+isFeatureSupported :: HM.HashMap T.Text (HS.HashSet PackagingFeatures)+isFeatureSupported = HM.fromList [ ("aix", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("appdmg", HS.fromList [Installable])+ , ("apple", HS.fromList [Installable])+ , ("apt", HS.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable])+ , ("aptitude", HS.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable])+ , ("aptrpm", HS.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable])+ , ("blastwave", HS.fromList [Installable, Uninstallable, Upgradeable])+ , ("dpkg", HS.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable])+ , ("fink", HS.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable])+ , ("freebsd", HS.fromList [Installable, Uninstallable])+ , ("gem", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("hpux", HS.fromList [Installable, Uninstallable])+ , ("macports", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("msi", HS.fromList [InstallOptions, Installable, UninstallOptions, Uninstallable])+ , ("nim", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("openbsd", HS.fromList [Installable, Uninstallable, Versionable])+ , ("pacman", HS.fromList [Installable, Uninstallable, Upgradeable])+ , ("pip", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("pkg", HS.fromList [Holdable, Installable, Uninstallable, Upgradeable, Versionable])+ , ("pkgdmg", HS.fromList [Installable])+ , ("pkgin", HS.fromList [Installable, Uninstallable])+ , ("pkgutil", HS.fromList [Installable, Uninstallable, Upgradeable])+ , ("portage", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("ports", HS.fromList [Installable, Uninstallable, Upgradeable])+ , ("portupgrade", HS.fromList [Installable, Uninstallable, Upgradeable])+ , ("rpm", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("rug", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("sun", HS.fromList [InstallOptions, Installable, Uninstallable, Upgradeable])+ , ("sunfreeware", HS.fromList [Installable, Uninstallable, Upgradeable])+ , ("up2date", HS.fromList [Installable, Uninstallable, Upgradeable])+ , ("urpmi", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("windows", HS.fromList [InstallOptions, Installable, UninstallOptions, Uninstallable])+ , ("yum", HS.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable])+ , ("zypper", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ ]+parameterset :: HS.HashSet T.Text+parameterset = HS.fromList $ map fst parameterfunctions+parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] parameterfunctions = [("adminfile" , [string, fullyQualified]) ,("allowcdrom" , [string, values ["true","false"]])@@ -64,14 +71,14 @@ ,("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+getFeature :: Resource -> Either Doc (HS.HashSet PackagingFeatures, Resource)+getFeature res = case res ^. rattributes . at "provider" of+ Just (PString x) -> case HM.lookup x isFeatureSupported of Just s -> Right (s,res)- Nothing -> Left ("Do not know provider " ++ T.unpack x)+ Nothing -> Left ("Do not know provider" <+> ttext x) _ -> Left "Can't happen at Puppet.NativeTypes.Package" -checkFeatures :: (Set.Set PackagingFeatures, RResource) -> Either String RResource+checkFeatures :: (HS.HashSet PackagingFeatures, Resource) -> Either Doc Resource checkFeatures = checkAdminFile >=> checkEnsure@@ -79,26 +86,26 @@ >=> 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+ checkFeature :: HS.HashSet PackagingFeatures -> Resource -> PackagingFeatures -> Either Doc (HS.HashSet PackagingFeatures, Resource)+ checkFeature s r f = if HS.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)+ else Left ("Feature" <+> text (show f) <+> "is required for the current configuration")+ checkParam :: T.Text -> PackagingFeatures -> (HS.HashSet PackagingFeatures, Resource) -> Either Doc (HS.HashSet PackagingFeatures, Resource)+ checkParam pn f (s,r) = if r ^. rattributes . containsAt pn then checkFeature s r f else Right (s,r)- checkAdminFile :: (Set.Set PackagingFeatures, RResource) -> Either String (Set.Set PackagingFeatures, RResource)+ checkAdminFile :: (HS.HashSet PackagingFeatures, Resource) -> Either Doc (HS.HashSet PackagingFeatures, Resource) 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+ checkEnsure :: (HS.HashSet PackagingFeatures, Resource) -> Either Doc (HS.HashSet PackagingFeatures, Resource)+ checkEnsure (s, res) = case res ^. rattributes . at "ensure" of+ Just (PString "latest") -> checkFeature s res Installable >> checkFeature s res Versionable+ Just (PString "purged") -> checkFeature s res Purgeable+ Just (PString "absent") -> checkFeature s res Uninstallable+ Just (PString "installed") -> checkFeature s res Installable+ Just (PString "present") -> checkFeature s res Installable+ Just (PString "held") -> checkFeature s res Installable >> checkFeature s res Holdable _ -> Right (s, res)- decap :: (Set.Set PackagingFeatures, RResource) -> Either String RResource+ decap :: (HS.HashSet PackagingFeatures, Resource) -> Either Doc Resource decap = Right . snd validatePackage :: PuppetTypeValidate
Puppet/NativeTypes/SshSecure.hs view
@@ -3,14 +3,18 @@ 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.HashSet as HS+import qualified Data.Text as T+import Control.Lens 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+parameterset :: HS.HashSet T.Text+parameterset = HS.fromList $ map fst parameterfunctions++parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] parameterfunctions = [("type" , [string, defaultvalue "ssh-rsa", values ["rsa","dsa","ssh-rsa","ssh-dss"]]) ,("key" , [string])@@ -21,15 +25,15 @@ ] 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+userOrTarget res = case (res ^. rattributes . containsAt "user", res ^. rattributes . containsAt "target") of+ (False, False) -> 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+keyIfPresent res = case (res ^. rattributes . at "key", res ^. rattributes . at "ensure") of (Just _, Just "present") -> Right res- (_, Just "absent") -> Right res+ (_, Just "absent") -> Right res _ -> Left "Parameter key is mandatory when the resource is present" validateSshSecure :: PuppetTypeValidate
Puppet/NativeTypes/User.hs view
@@ -3,13 +3,16 @@ import Puppet.NativeTypes.Helpers import Puppet.Interpreter.Types import Control.Monad.Error-import qualified Data.Set as Set+import qualified Data.HashSet as HS+import qualified Data.Text as T 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+parameterset :: HS.HashSet T.Text+parameterset = HS.fromList $ map fst parameterfunctions+parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] parameterfunctions = [("allowdupe" , [string, defaultvalue "false", values ["true","false"]]) ,("attribute_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]])
Puppet/NativeTypes/ZoneRecord.hs view
@@ -3,14 +3,18 @@ import Puppet.NativeTypes.Helpers import Puppet.Interpreter.Types import Control.Monad.Error-import qualified Data.Map as Map-import qualified Data.Set as Set+import qualified Data.HashSet as HS+import qualified Data.Text as T+import Control.Lens 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+parameterset :: HS.HashSet T.Text+parameterset = HS.fromList $ map fst parameterfunctions++parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] parameterfunctions = [("name" , [nameval]) ,("owner" , [string])@@ -33,9 +37,9 @@ validateZoneRecord = defaultValidate parameterset >=> parameterFunctions parameterfunctions >=> validateMandatories validateMandatories :: PuppetTypeValidate-validateMandatories res = case (Map.lookup "rtype" (rrparams res)) of+validateMandatories res = case res ^. rattributes . at "rtype" of Nothing -> Left "The rtype parameter is mandatory."- Just (ResolvedString "SOA") -> foldM (\r n -> mandatory n r) res ["nsname", "email", "serial", "slave_refresh", "slave_retry", "slave_expiration", "min_ttl"]- Just (ResolvedString "NS") -> foldM (\r n -> mandatory n r) res ["owner", "rclass", "rtype", "dest"]- Just (ResolvedString _) -> foldM (\r n -> mandatory n r) res ["owner", "rclass", "rtype", "dest", "ttl"]- Just x -> Left $ "Can't use this for the rtype parameter " ++ show x+ Just (PString "SOA") -> foldM (flip mandatory) res ["nsname", "email", "serial", "slave_refresh", "slave_retry", "slave_expiration", "min_ttl"]+ Just (PString "NS") -> foldM (flip mandatory) res ["owner", "rclass", "rtype", "dest"]+ Just (PString _) -> foldM (flip mandatory) res ["owner", "rclass", "rtype", "dest", "ttl"]+ Just x -> Left $ "Can't use this for the rtype parameter" <+> pretty x
+ Puppet/PP.hs view
@@ -0,0 +1,23 @@+module Puppet.PP+ ( module Text.PrettyPrint.ANSI.Leijen+ , ttext+ , tshow+ , dq+ , pshow+ ) where++import Text.PrettyPrint.ANSI.Leijen hiding ((<>))+import qualified Data.Text as T++ttext :: T.Text -> Doc+ttext = text . T.unpack++tshow :: Show a => a -> T.Text+tshow = T.pack . show++dq :: T.Text -> T.Text+dq x = T.cons '"' (T.snoc x '"')++pshow :: Doc -> String+pshow d = displayS (renderPretty 0.4 120 d) ""+
+ Puppet/Parser.hs view
@@ -0,0 +1,589 @@+{-# LANGUAGE LambdaCase #-}+module Puppet.Parser (puppetParser,expression) where++import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Data.HashSet as HS+import qualified Data.Maybe.Strict as S+import Data.Tuple.Strict hiding (fst,zip)+import Text.Regex.PCRE.String++import Data.Char+import Control.Monad+import Control.Monad.IO.Class+import Control.Applicative+import Control.Lens++import Puppet.Parser.Types++import Text.Parsec.Expr+import Text.Parser.Token hiding (stringLiteral')+import Text.Parser.Combinators+import Text.Parser.Char+import Text.Parser.LookAhead+import Text.Parser.Parsec ()+import Text.Parser.Token.Highlight+import Text.Parsec.Prim (getPosition, ParsecT)+import Text.Parsec.Text ()++type Parser = ParsecT T.Text () IO++stringLiteral' :: Parser T.Text+stringLiteral' = char '\'' *> interior <* symbolic '\''+ where+ interior = fmap (T.pack . concat) $ many (some (noneOf "'\\") <|> (char '\\' *> fmap escape anyChar))+ escape '\'' = "'"+ escape x = ['\\',x]++identifierStyle :: IdentifierStyle Parser+identifierStyle = IdentifierStyle "Identifier" (satisfy acceptable) (satisfy acceptable) HS.empty Identifier ReservedIdentifier+ where+ acceptable x = isAsciiLower x || isAsciiUpper x || isDigit x || (x == '_')++identl :: Parser Char -> Parser Char -> Parser T.Text+identl fstl nxtl = do+ f <- fstl+ nxt <- token $ many nxtl+ return $ T.pack $ f : nxt++operator :: String -> Parser ()+operator = void . highlight Operator . try . symbol++reserved :: String -> Parser ()+reserved = reserve identifierStyle++variableName :: Parser T.Text+variableName = do+ let acceptablePart = fmap T.pack (ident identifierStyle)+ out <- qualif acceptablePart+ when (out == "string") (fail "The special variable $string should never be used")+ return out++qualif :: Parser T.Text -> Parser T.Text+qualif p = token $ do+ header <- option "" (try (string "::"))+ rest <- fmap (T.intercalate "::") (p `sepBy1` try (string "::"))+ return (T.append (T.pack header) rest)++qualif1 :: Parser T.Text -> Parser T.Text+qualif1 p = try $ do+ r <- qualif p+ if "::" `T.isInfixOf` r+ then return r+ else fail "This parser is not qualified"++className :: Parser T.Text+className = qualif moduleName++-- yay with reserved words+typeName :: Parser T.Text+typeName = className++moduleName :: Parser T.Text+moduleName = genericModuleName False++resourceNameRef :: Parser T.Text+resourceNameRef = qualif (genericModuleName True)++genericModuleName :: Bool -> Parser T.Text+genericModuleName isReference = do+ let acceptable x = isAsciiLower x || isDigit x || (x == '_')+ firstletter = if isReference+ then fmap toLower (satisfy isAsciiUpper)+ else satisfy isAsciiLower+ identl firstletter (satisfy acceptable)++parameterName :: Parser T.Text+parameterName = moduleName++-- this is not a token !+inBraces :: Parser T.Text+inBraces = between (char '{') (char '}') (fmap T.pack (some (satisfy (/= '}'))))++variableReference :: Parser T.Text+variableReference = do+ void (char '$')+ v <- lookAhead anyChar >>= \case+ '{' -> inBraces+ _ -> variableName+ when (v == "string") (fail "The special variable $string must not be used")+ return v++interpolableString :: Parser (V.Vector UValue)+interpolableString = fmap V.fromList $ between (char '"') (symbolic '"') $+ many (fmap UVariableReference interpolableVariableReference <|> doubleQuotedStringContent <|> fmap (UString . T.singleton) (char '$'))+ where+ doubleQuotedStringContent = fmap (UString . T.pack . concat) $+ some ((char '\\' *> anyChar >>= stringEscape) <|> some (noneOf "\"\\$"))+ stringEscape :: Char -> Parser String+ stringEscape 'n' = return "\n"+ stringEscape 't' = return "\t"+ stringEscape 'r' = return "\r"+ stringEscape '"' = return "\""+ stringEscape '\\' = return "\\"+ stringEscape '$' = return "$"+ stringEscape x = fail $ "unknown escape pattern \\" ++ [x]+ -- this is specialized because we can't be "tokenized" here+ variableAccept x = isAsciiLower x || isAsciiUpper x || isDigit x || x == '_'+ interpolableVariableReference = do+ void (char '$')+ v <- lookAhead anyChar >>= \case+ '{' -> inBraces+ -- This is not as robust as the "qualif"+ -- implementation, but considerably shorter.+ --+ -- This needs refactoring.+ _ -> fmap (T.pack . concat) (some (string "::" <|> some (satisfy variableAccept)))+ when (v == "string") (fail "The special variable $string must not be used")+ return v++regexp :: Parser T.Text+regexp = do+ void (char '/')+ v <- many ( do { void (char '\\') ; x <- anyChar; return ['\\', x] } <|> some (noneOf "/\\") )+ void $ symbolic '/'+ return $! T.pack $! concat v++variableOrHash :: Parser Expression+variableOrHash = do+ varname <- variableReference <?> "Variable reference"+ -- chained lookups are resolved here+ hr <- many (brackets expression)+ return $! foldl Lookup (PValue (UVariableReference varname)) hr++puppetArray :: Parser UValue+puppetArray = fmap (UArray . V.fromList) (brackets (expression `sepEndBy` comma)) <?> "Array"++puppetHash :: Parser UValue+puppetHash = fmap (UHash . V.fromList) (braces (hashPart `sepEndBy` comma)) <?> "Hash"+ where+ hashPart = do+ -- a special case for "default" because of the ? selector ...+ a <- expression+ void $ operator "=>"+ b <- expression+ return (a :!: b)++puppetBool :: Parser Bool+puppetBool = (reserved "true" >> return True) <|> (reserved "false" >> return False) <?> "Boolean"++resourceReferenceRaw :: Parser (T.Text, [Expression])+resourceReferenceRaw = do+ restype <- resourceNameRef <?> "Resource reference type"+ resnames <- brackets (expression `sepBy1` comma) <?> "Resource reference values"+ return (restype, resnames)++resourceReference :: Parser UValue+resourceReference = do+ (restype, resnames) <- resourceReferenceRaw+ return $ case resnames of+ [x] -> UResourceReference restype x+ _ -> UResourceReference restype (PValue (array resnames))++bareword :: Parser T.Text+bareword = identl (satisfy isAsciiLower) (satisfy acceptable) <?> "Bare word"+ where+ acceptable x = isAsciiLower x || isAsciiUpper x || isDigit x || (x == '_') || (x == '-')++genFunctionCall :: Parser (T.Text, V.Vector Expression)+genFunctionCall = do+ fname <- moduleName <?> "Function name"+ -- this is a hack. Contrary to what the documentation says,+ -- a "bareword" can perfectly be a qualified name :+ -- include foo::bar+ let argsc sep e = (fmap (PValue . UString) (qualif1 className) <|> e <?> "Function argument") `sep` comma+ terminalF = terminalG (fail "function hack")+ expressionF = buildExpressionParser expressionTable (token terminalF) <?> "function expression"+ args <- parens (argsc sepEndBy expression) <|> argsc sepEndBy1 expressionF <?> "Function arguments"+ return (fname, V.fromList args)++functionCall :: Parser UValue+functionCall = do+ (fname, args) <- genFunctionCall+ return $ UFunctionCall fname args++literalValue :: Parser T.Text+literalValue = token (stringLiteral' <|> bareword <|> numericalvalue <?> "Literal Value")+ where+ numericalvalue = integerOrDouble >>= \case+ Left x -> return (T.pack $ show x)+ Right y -> return (T.pack $ show y)++-- this is a hack for functions :(+terminalG :: Parser Expression -> Parser Expression+terminalG g = parens expression+ <|> fmap (PValue . UInterpolable) interpolableString+ <|> (reserved "undef" *> return (PValue UUndef))+ <|> fmap PValue termRegexp+ <|> variableOrHash+ <|> fmap PValue puppetArray+ <|> fmap PValue puppetHash+ <|> fmap (PValue . UBoolean) puppetBool+ <|> fmap PValue resourceReference+ <|> g+ <|> fmap (PValue . UString) literalValue++compileRegexp :: T.Text -> Parser Regex+compileRegexp p = (liftIO . compile compBlank execBlank . T.unpack) p >>= \case+ Right r -> return r+ Left ms -> fail ("Can't parse regexp /" ++ T.unpack p ++ "/ : " ++ show ms)++termRegexp :: Parser UValue+termRegexp = do+ r <- regexp+ URegexp <$> pure r <*> compileRegexp r++terminal :: Parser Expression+terminal = terminalG (fmap PValue (fmap UHFunctionCall (try hfunctionCall) <|> try functionCall))++expression :: Parser Expression+expression = condExpression+ <|> buildExpressionParser expressionTable (token terminal)+ <?> "expression"+ where+ condExpression = do+ selectedExpression <- try (token terminal <* symbolic '?')+ let cas = do+ c <- (symbol "default" *> return SelectorDefault) -- default case+ <|> fmap SelectorValue (fmap UVariableReference variableReference+ <|> fmap UBoolean puppetBool+ <|> fmap UString literalValue+ <|> fmap UInterpolable interpolableString+ <|> termRegexp)+ void $ symbol "=>"+ e <- expression+ return (c :!: e)+ cases <- braces (cas `sepEndBy1` comma)+ return (ConditionalValue selectedExpression (V.fromList cases))++expressionTable :: [[Operator T.Text () IO Expression]]+expressionTable = [ -- [ Infix ( operator "?" >> return ConditionalValue ) AssocLeft ]+ [ Prefix ( operator "-" >> return Negate ) ]+ , [ Prefix ( operator "!" >> return Not ) ]+ , [ Infix ( operator "." >> return FunctionApplication ) AssocLeft ]+ , [ Infix ( reserved "in" >> return Contains ) AssocLeft ]+ , [ Infix ( operator "/" >> return Division ) AssocLeft+ , Infix ( operator "*" >> return Multiplication ) AssocLeft+ ]+ , [ Infix ( operator "+" >> return Addition ) AssocLeft+ , Infix ( operator "-" >> return Substraction ) AssocLeft+ ]+ , [ Infix ( operator "<<" >> return LeftShift ) AssocLeft+ , Infix ( operator ">>" >> return RightShift ) AssocLeft+ ]+ , [ Infix ( operator "==" >> return Equal ) AssocLeft+ , Infix ( operator "!=" >> return Different ) AssocLeft+ ]+ , [ Infix ( operator ">" >> return MoreThan ) AssocLeft+ , Infix ( operator ">=" >> return MoreEqualThan ) AssocLeft+ , Infix ( operator "<=" >> return LessEqualThan ) AssocLeft+ , Infix ( operator "<" >> return LessThan ) AssocLeft+ ]+ , [ Infix ( reserved "and" >> return And ) AssocLeft+ , Infix ( reserved "or" >> return Or ) AssocLeft+ ]+ , [ Infix ( operator "=~" >> return RegexMatch ) AssocLeft+ , Infix ( operator "!~" >> return NotRegexMatch ) AssocLeft+ ]+ ]++stringExpression :: Parser Expression+stringExpression = fmap (PValue . UInterpolable) interpolableString <|> (reserved "undef" *> return (PValue UUndef)) <|> fmap (PValue . UBoolean) puppetBool <|> variableOrHash <|> fmap (PValue . UString) literalValue++variableAssignment :: Parser [Statement]+variableAssignment = do+ p <- getPosition+ v <- variableReference+ void $ symbolic '='+ e <- expression+ when (T.all isDigit v) (fail "Can't assign fully numeric variables")+ pe <- getPosition+ return [VariableAssignment v e (p :!: pe)]++nodeStmt :: Parser [Statement]+nodeStmt = do+ p <- getPosition+ reserved "node"+ let nm (URegexp nn nr) = return (NodeMatch nn nr)+ nm _ = fail "? can't happen, termRegexp didn't return a URegexp ?"+ let nodename = (reserved "default" >> return NodeDefault) <|> fmap NodeName literalValue+ ns <- ((termRegexp >>= nm) <|> nodename) `sepBy1` comma+ inheritance <- option S.Nothing (fmap S.Just (reserved "inherits" *> nodename))+ st <- braces statementList+ pe <- getPosition+ return [Node n st inheritance (p :!: pe) | n <- ns]++puppetClassParameters :: Parser (V.Vector (Pair T.Text (S.Maybe Expression)))+puppetClassParameters = fmap V.fromList $ parens (var `sepBy` comma)+ where+ toStrictMaybe (Just x) = S.Just x+ toStrictMaybe Nothing = S.Nothing+ var :: Parser (Pair T.Text (S.Maybe Expression))+ var = do+ vname <- variableReference+ value <- fmap toStrictMaybe $ optional (symbolic '=' *> expression)+ return $ vname :!: value++defineStmt :: Parser [Statement]+defineStmt = do+ p <- getPosition+ reserved "define"+ name <- typeName+ -- TODO check native type+ params <- option V.empty puppetClassParameters+ st <- braces statementList+ pe <- getPosition+ return [DefineDeclaration name params st (p :!: pe)]++puppetIfStyleCondition :: Parser (Pair Expression (V.Vector Statement))+puppetIfStyleCondition = (:!:) <$> expression <*> braces statementList++unlessCondition :: Parser [Statement]+unlessCondition = do+ p <- getPosition+ reserved "unless"+ (cond :!: stmts) <- puppetIfStyleCondition+ pe <- getPosition+ return [ConditionalStatement (V.singleton (Not cond :!: stmts)) (p :!: pe)]++ifCondition :: Parser [Statement]+ifCondition = do+ p <- getPosition+ reserved "if"+ maincond <- puppetIfStyleCondition+ others <- many (reserved "elsif" *> puppetIfStyleCondition)+ elsecond <- option V.empty (reserved "else" *> braces statementList)+ let ec = if V.null elsecond+ then []+ else [PValue (UBoolean True) :!: elsecond]+ pe <- getPosition+ return [ ConditionalStatement (V.fromList (maincond : others ++ ec)) (p :!: pe) ]++caseCondition :: Parser [Statement]+caseCondition = do+ let puppetRegexpCase = do+ reg <- termRegexp+ void $ symbolic ':'+ stmts <- braces statementList+ return [ (PValue reg, stmts) ]+ defaultCase = do+ try (reserved "default")+ void $ symbolic ':'+ stmts <- braces statementList+ return [ (PValue (UBoolean True), stmts) ]+ puppetCase = do+ compares <- expression `sepBy1` comma+ void $ symbolic ':'+ stmts <- braces statementList+ return [ (cmp, stmts) | cmp <- compares ]+ condsToExpression e (x, stmts) = f x :!: stmts+ where f = case x of+ (PValue (UBoolean _)) -> id+ (PValue (URegexp _ _)) -> RegexMatch e+ _ -> Equal e+ p <- getPosition+ reserved "case"+ expr1 <- expression+ condlist <- braces (some (puppetRegexpCase <|> defaultCase <|> puppetCase))+ pe <- getPosition+ return [ ConditionalStatement (V.fromList (map (condsToExpression expr1) (concat condlist))) (p :!: pe) ]++resourceGroup :: Parser [Statement]+resourceGroup = do+ groups <- resourceGroup' `sepBy1` operator "->"+ let relations = do+ (g1, g2) <- zip groups (tail groups)+ ResourceDeclaration rt1 rn1 _ _ (_ :!: pe1) <- g1+ ResourceDeclaration rt2 rn2 _ _ (ps2 :!: _) <- g2+ return (Dependency (rt1 :!: rn1) (rt2 :!: rn2) (pe1 :!: ps2))+ return $ concat groups ++ relations++resourceGroup' :: Parser [Statement]+resourceGroup' = do+ let resourceName = token stringExpression+ resourceDeclaration = do+ p <- getPosition+ names <- brackets (resourceName `sepEndBy1` comma) <|> fmap return resourceName+ void $ symbolic ':'+ vals <- fmap V.fromList (assignment `sepEndBy` comma)+ pe <- getPosition+ return [(n, vals, p :!: pe) | n <- names ]+ groupDeclaration = (,) <$> many (char '@') <*> typeName <* symbolic '{'+ (virts, rtype) <- try groupDeclaration -- for matching reasons, this gets a try until the opening brace+ x <- resourceDeclaration `sepEndBy` (symbolic ';' <|> comma)+ void $ symbolic '}'+ virtuality <- case virts of+ "" -> return Normal+ "@" -> return Virtual+ "@@" -> return Exported+ _ -> fail "Invalid virtuality"+ return [ ResourceDeclaration rtype rname conts virtuality pos | (rname, conts, pos) <- concat x ]++assignment :: Parser (Pair T.Text Expression)+assignment = (:!:) <$> bw <*> (symbol "=>" *> expression)+ where+ bw = identl (satisfy isAsciiLower) (satisfy acceptable) <?> "Assignment key"+ acceptable x = isAsciiLower x || isAsciiUpper x || isDigit x || (x == '_') || (x == '-')++resourceDefaults :: Position -> T.Text -> Parser [Statement]+resourceDefaults p rnd = do+ let assignmentList = V.fromList <$> assignment `sepEndBy1` comma+ asl <- braces assignmentList+ pe <- getPosition+ return [DefaultDeclaration rnd asl (p :!: pe)]++resourceOverride :: Position -> T.Text -> [Expression] -> Parser [Statement]+resourceOverride p restype names = do+ assignments <- fmap V.fromList $ braces (assignment `sepEndBy` comma)+ pe <- getPosition+ return [ ResourceOverride restype n assignments (p :!: pe) | n <- names ]++-- TODO+searchExpression :: Parser SearchExpression+searchExpression = parens searchExpression <|> check <|> combine+ where+ combine = do+ e1 <- parens searchExpression <|> check+ opr <- (operator "and" *> return AndSearch) <|> (operator "or" *> return OrSearch)+ e2 <- searchExpression+ return (opr e1 e2)+ check = do+ attrib <- parameterName+ opr <- (operator "==" *> return EqualitySearch) <|> (operator "!=" *> return NonEqualitySearch)+ term <- stringExpression+ return (opr attrib term)++resourceCollection :: Position -> T.Text -> Parser [Statement]+resourceCollection p restype = do+ openchev <- some (char '<')+ when (length openchev > 2) (fail "Too many brackets")+ void $ symbolic '|'+ e <- option AlwaysTrue searchExpression+ void (char '|')+ void (count (length openchev) (char '>'))+ someSpace+ overrides <- option [] $ braces (assignment `sepEndBy` comma)+ let collectortype = if length openchev == 1+ then Collector+ else ExportedCollector+ pe <- getPosition+ return [ ResourceCollection collectortype restype e (V.fromList overrides) (p :!: pe) ]++classDefinition :: Parser [Statement]+classDefinition = do+ p <- getPosition+ reserved "class"+ classname <- className+ params <- option V.empty puppetClassParameters+ inheritance <- option S.Nothing (fmap S.Just (reserved "inherits" *> className))+ st <- braces statementList+ pe <- getPosition+ return [ ClassDeclaration classname params inheritance st (p :!: pe) ]++mainFunctionCall :: Parser [Statement]+mainFunctionCall = do+ p <- getPosition+ (fname, args) <- genFunctionCall+ pe <- getPosition+ return [ MainFunctionCall fname args (p :!: pe) ]++startDepChains :: Position -> T.Text -> [Expression] -> Parser [Statement]+startDepChains p restype resnames = do+ operator "->"+ -- FIXME positions+ nxts <- resourceReferenceRaw `sepBy` operator "->"+ pe <- getPosition+ let refs = (restype, resnames) : nxts+ return [ Dependency (rt :!: rn) (dt :!: dn) (p :!: pe) | ((rt, rns), (dt,dns)) <- zip refs (tail refs), rn <- rns, dn <- dns ]++rrGroupRef :: Position -> T.Text -> Parser [Statement]+rrGroupRef p restype = do+ resnames <- brackets (expression `sepBy1` comma) <?> "Resource reference values"+ startDepChains p restype resnames <|> resourceOverride p restype resnames++rrGroup :: Parser [Statement]+rrGroup = do+ p <- getPosition+ restype <- resourceNameRef+ lookAhead anyChar >>= \case+ '[' -> rrGroupRef p restype <?> "What comes after a resource reference"+ _ -> resourceDefaults p restype <|> resourceCollection p restype <?> "What comes after a resource type"++mainHFunctionCall :: Parser [Statement]+mainHFunctionCall = do+ p <- getPosition+ fc <- try hfunctionCall+ pe <- getPosition+ return [SHFunctionCall fc (p :!: pe)]++dotCall :: Parser [Statement]+dotCall = do+ p <- getPosition+ ex <- expression+ pe <- getPosition+ hf <- case ex of+ FunctionApplication e (PValue (UHFunctionCall hf)) -> do+ unless (S.isNothing (hf ^. hfexpr)) (fail "Can't call a function with . and ()")+ return (hf & hfexpr .~ S.Just e)+ PValue (UHFunctionCall hf) -> do+ when (S.isNothing (hf ^. hfexpr)) (fail "This function needs data to operate on")+ return hf+ _ -> fail "A method chained by dots."+ unless (hf ^. hftype == HFEach) (fail "Expected 'each', the other types of method calls are not supported by language-puppet at the statement level.")+ return [SHFunctionCall hf (p :!: pe)]++statement :: Parser [Statement]+statement =+ try dotCall+ <|> variableAssignment+ <|> nodeStmt+ <|> defineStmt+ <|> unlessCondition+ <|> ifCondition+ <|> caseCondition+ <|> resourceGroup+ <|> rrGroup+ <|> classDefinition+ <|> mainHFunctionCall+ <|> mainFunctionCall+ <?> "Statement"+++statementList :: Parser (V.Vector Statement)+statementList = fmap (V.fromList . concat) (many statement)++puppetParser :: Parser (V.Vector Statement)+puppetParser = someSpace >> statementList++{-+- Stuff related to the new functions with "lambdas"+-}++parseHFunction :: Parser HigherFuncType+parseHFunction = (reserved "each" *> pure HFEach)+ <|> (reserved "map" *> pure HFMap )+ <|> (reserved "reduce" *> pure HFReduce)+ <|> (reserved "filter" *> pure HFFilter)+ <|> (reserved "slice" *> pure HFSlice)++parseHParams :: Parser BlockParameters+parseHParams = between (symbolic '|') (symbolic '|') hp+ where+ acceptablePart = fmap T.pack (ident identifierStyle)+ hp = do+ vars <- (char '$' *> acceptablePart) `sepBy1` comma+ case vars of+ [a] -> return (BPSingle a)+ [a,b] -> return (BPPair a b)+ _ -> fail "Invalid number of variables between the pipes"++hfunctionCall :: Parser HFunctionCall+hfunctionCall = do+ let toStrict (Just x) = S.Just x+ toStrict Nothing = S.Nothing+ HFunctionCall <$> parseHFunction+ <*> fmap (toStrict . join) (optional (parens (optional expression)))+ <*> parseHParams+ <*> (symbolic '{' *> fmap (V.fromList . concat) (many (try statement)))+ <*> fmap toStrict (optional expression) <* symbolic '}'+
+ Puppet/Parser/PrettyPrinter.hs view
@@ -0,0 +1,184 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Puppet.Parser.PrettyPrinter where++import Puppet.PP+import Data.Monoid+import Puppet.Parser.Types+import qualified Data.Vector as V+import qualified Data.Text as T+import Data.Tuple.Strict (Pair ( (:!:) ))+import qualified Data.Tuple.Strict as S+import qualified Data.Maybe.Strict as S++capitalize :: T.Text -> Doc+capitalize = dullyellow . text . T.unpack . capitalizeRT++parensList :: Pretty a => V.Vector a -> Doc+parensList = tupled . map pretty . V.toList++hashComma :: (Pretty a, Pretty b) => V.Vector (Pair a b) -> Doc+hashComma = encloseSep lbrace rbrace comma . map showC . V.toList+ where+ showC (a :!: b) = pretty a <+> text "=>" <+> pretty b++instance Pretty Expression where+ pretty (Equal a b) = parens (pretty a <+> text "==" <+> pretty b)+ pretty (Different a b) = parens (pretty a <+> text "!=" <+> pretty b)+ pretty (And a b) = parens (pretty a <+> text "and" <+> pretty b)+ pretty (Or a b) = parens (pretty a <+> text "or" <+> pretty b)+ pretty (LessThan a b) = parens (pretty a <+> text "<" <+> pretty b)+ pretty (MoreThan a b) = parens (pretty a <+> text ">" <+> pretty b)+ pretty (LessEqualThan a b) = parens (pretty a <+> text "<=" <+> pretty b)+ pretty (MoreEqualThan a b) = parens (pretty a <+> text ">=" <+> pretty b)+ pretty (RegexMatch a b) = parens (pretty a <+> text "=~" <+> pretty b)+ pretty (NotRegexMatch a b) = parens (pretty a <+> text "!~" <+> pretty b)+ pretty (Contains a b) = parens (pretty a <+> text "in" <+> pretty b)+ pretty (Addition a b) = parens (pretty a <+> text "+" <+> pretty b)+ pretty (Substraction a b) = parens (pretty a <+> text "-" <+> pretty b)+ pretty (Division a b) = parens (pretty a <+> text "/" <+> pretty b)+ pretty (Multiplication a b) = parens (pretty a <+> text "*" <+> pretty b)+ pretty (Modulo a b) = parens (pretty a <+> text "%" <+> pretty b)+ pretty (RightShift a b) = parens (pretty a <+> text ">>" <+> pretty b)+ pretty (LeftShift a b) = parens (pretty a <+> text "<<" <+> pretty b)+ pretty (Lookup a b) = pretty a <> brackets (pretty b)+ pretty (ConditionalValue a b) = parens (pretty a <+> text "?" <+> hashComma b)+ pretty (Negate a) = text "-" <+> parens (pretty a)+ pretty (Not a) = text "!" <+> parens (pretty a)+ pretty (PValue a) = pretty a+ pretty (FunctionApplication e1 e2) = parens (pretty e1) <> text "." <> pretty e2++instance Pretty HigherFuncType where+ pretty HFEach = bold $ red $ text "each"+ pretty HFMap = bold $ red $ text "map"+ pretty HFReduce = bold $ red $ text "reduce"+ pretty HFFilter = bold $ red $ text "filter"+ pretty HFSlice = bold $ red $ text "slice"++instance Pretty BlockParameters where+ pretty b = magenta (char '|') <+> vars <+> magenta (char '|')+ where+ vars = case b of+ BPSingle v -> pretty (UVariableReference v)+ BPPair v1 v2 -> pretty (UVariableReference v1) <> comma <+> pretty (UVariableReference v2)++instance Pretty SearchExpression where+ pretty (EqualitySearch t e) = text (T.unpack t) <+> text "==" <+> pretty e+ pretty (NonEqualitySearch t e) = text (T.unpack t) <+> text "!=" <+> pretty e+ pretty AlwaysTrue = empty+ pretty (AndSearch s1 s2) = parens (pretty s1) <+> text "and" <+> parens (pretty s2)+ pretty (OrSearch s1 s2) = parens (pretty s1) <+> text "and" <+> parens (pretty s2)++instance Pretty UValue where+ pretty (UBoolean True) = dullmagenta $ text "true"+ pretty (UBoolean False) = dullmagenta $ text "false"+ pretty (UString s) = dullcyan (text (show s))+ pretty (UInterpolable v) = char '"' <> hcat (map specific (V.toList v)) <> char '"'+ where+ specific (UString s) = dullcyan (text (tail (init (show s))))+ specific (UVariableReference vr) = dullblue (text "${" <> text (T.unpack vr) <> char '}')+ specific x = bold (red (pretty x))+ pretty UUndef = dullmagenta (text "undef")+ pretty (UResourceReference t n) = capitalize t <> brackets (pretty n)+ pretty (UArray v) = list (map pretty (V.toList v))+ pretty (UHash g) = hashComma g+ pretty (URegexp r _) = char '/' <> text (T.unpack r) <> char '/'+ pretty (UVariableReference v) = dullblue (char '$' <> text (T.unpack v))+ pretty (UFunctionCall f args) = showFunc f args+ pretty (UHFunctionCall c) = pretty c++instance Pretty HFunctionCall where+ pretty (HFunctionCall hf me bp stts mee) = pretty hf <> mme <+> pretty bp <+> nest 2 (char '{' <$> ppStatements stts <> mmee) <$> char '}'+ where+ mme = case me of+ S.Just x -> mempty <+> pretty x+ S.Nothing -> mempty+ mmee = case mee of+ S.Just x -> mempty </> pretty x+ S.Nothing -> mempty+instance Pretty SelectorCase where+ pretty SelectorDefault = dullmagenta (text "default")+ pretty (SelectorValue v) = pretty v++showPos :: Position -> Doc+showPos p = green (char '#' <+> string (show p))++showPPos :: PPosition -> Doc+showPPos p = green (char '#' <+> string (show (S.fst p)))++showAss :: V.Vector (Pair T.Text Expression) -> Doc+showAss v = folddoc (\a b -> a <> char ',' <$> b) rh lst+ where+ folddoc _ _ [] = empty+ folddoc docAppend docGen (x:xs) = foldl docAppend (docGen x) (map docGen xs)+ lst = V.toList v+ maxlen = maximum (map (T.length . S.fst) lst)+ rh (k :!: val) = dullblue (fill maxlen (text (T.unpack k))) <+> text "=>" <+> pretty val++showArgs :: V.Vector (Pair T.Text (S.Maybe Expression)) -> Doc+showArgs vec = tupled (map ra lst)+ where+ lst = V.toList vec+ maxlen = maximum (map (T.length . S.fst) lst)+ ra (argname :!: rval) = dullblue (char '$' <> fill maxlen (text (T.unpack argname)))+ <> case rval of+ S.Nothing -> empty+ S.Just v -> empty <+> char '=' <+> pretty v++showFunc :: T.Text -> V.Vector Expression -> Doc+showFunc funcname args = bold (red (text (T.unpack funcname))) <> parensList args+braceStatements :: V.Vector Statement -> Doc+braceStatements stts = nest 2 (char '{' <$> ppStatements stts) <$> char '}'++instance Pretty NodeDesc where+ pretty NodeDefault = dullmagenta (text "default")+ pretty (NodeName n) = pretty (UString n)+ pretty (NodeMatch m r) = pretty (URegexp m r)++instance Pretty Statement where+ pretty (SHFunctionCall c p) = pretty c <+> showPPos p+ pretty (ConditionalStatement conds p)+ | V.null conds = empty+ | otherwise = text "if" <+> pretty firstcond <+> showPPos p <+> braceStatements firststts <$> vcat (map rendernexts xs)+ where+ ( (firstcond :!: firststts) : xs ) = V.toList conds+ rendernexts (PValue (UBoolean True) :!: st) = text "else" <+> braceStatements st+ rendernexts (c :!: st) | V.null st = empty+ | otherwise = text "elsif" <+> pretty c <+> braceStatements st+ pretty (MainFunctionCall funcname args p) = showFunc funcname args <+> showPPos p+ pretty (DefaultDeclaration rtype defaults p) = capitalize rtype <+> nest 2 (char '{' <+> showPPos p <$> showAss defaults) <$> char '}'+ pretty (ResourceOverride rtype rnames overs p) = pretty (UResourceReference rtype rnames) <+> nest 2 (char '{' <+> showPPos p <$> showAss overs) <$> char '}'+ pretty (ResourceDeclaration rtype rname args virt p) = nest 2 (red vrt <> dullgreen (text (T.unpack rtype)) <+> char '{' <+> showPPos p+ <$> nest 2 (pretty rname <> char ':' <$> showAss args))+ <$> char '}'+ where+ vrt = case virt of+ Normal -> empty+ Virtual -> char '@'+ Exported -> text "@@"+ ExportedRealized -> text "!!"+ pretty (DefineDeclaration cname args stts p) = dullyellow (text "define") <+> dullgreen (ttext cname) <> showArgs args <+> showPPos p <$> braceStatements stts+ pretty (ClassDeclaration cname args inherit stts p) = dullyellow (text "class") <+> dullgreen (text (T.unpack cname)) <> showArgs args <> inheritance <+> showPPos p+ <$> braceStatements stts+ where+ inheritance = case inherit of+ S.Nothing -> empty+ S.Just x -> empty <+> text "inherits" <+> text (T.unpack x)+ pretty (VariableAssignment a b p) = dullblue (char '$' <> text (T.unpack a)) <+> char '=' <+> pretty b <+> showPPos p+ pretty (Node nodename stmts i p) = dullyellow (text "node") <+> pretty nodename <> inheritance <+> showPPos p <$> braceStatements stmts+ where+ inheritance = case i of+ S.Nothing -> empty+ S.Just n -> empty <+> text "inherits" <+> pretty n+ pretty (Dependency (st :!: sn) (dt :!: dn) p) = pretty (UResourceReference st sn) <+> text "->" <+> pretty (UResourceReference dt dn) <+> showPPos p+ pretty (TopContainer a b) = text "TopContainer:" <+> braces ( nest 2 (string "TOP" <$> braceStatements a <$> string "STATEMENT" <$> pretty b))+ pretty (ResourceCollection coltype restype search overrides p) = capitalize restype <> enc (pretty search) <+> overs+ where+ overs | V.null overrides = showPPos p+ | otherwise = nest 2 (char '{' <+> showPPos p <$> showAss overrides) <$> char '}'+ enc = case coltype of+ Collector -> enclose (text "<|") (text "|>")+ ExportedCollector -> enclose (text "<<|") (text "|>>")++ppStatements :: V.Vector Statement -> Doc+ppStatements = vcat . map pretty . V.toList+
+ Puppet/Parser/Types.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE DeriveGeneric, TemplateHaskell #-}+module Puppet.Parser.Types where++import qualified Data.Text as T+import qualified Data.Vector as V+import Data.Tuple.Strict+import qualified Data.Maybe.Strict as S+import GHC.Generics+import Data.Char (toUpper)+import Text.Regex.PCRE.String+import Control.Lens++import Text.Parsec.Pos++-- | Properly capitalizes resource types+capitalizeRT :: T.Text -> T.Text+capitalizeRT = T.intercalate "::" . map capitalize' . T.splitOn "::"++capitalize' :: T.Text -> T.Text+capitalize' t | T.null t = T.empty+ | otherwise = T.cons (toUpper (T.head t)) (T.tail t)++type PPosition = Pair Position Position++type Position = SourcePos++initialPPos :: T.Text -> PPosition+initialPPos x =+ let i = initialPos (T.unpack x)+ in (i :!: i)++toPPos :: T.Text -> Int -> PPosition+toPPos fl ln =+ let p = newPos (T.unpack fl) ln (-1)+ in (p :!: p)++data HigherFuncType = HFEach+ | HFMap+ | HFReduce+ | HFFilter+ | HFSlice+ deriving Eq++data BlockParameters = BPSingle !T.Text+ | BPPair !T.Text !T.Text+ deriving Eq++-- used for the each/filter/etc. "higher level functions"+data HFunctionCall = HFunctionCall { _hftype :: !HigherFuncType+ , _hfexpr :: !(S.Maybe Expression)+ , _hfparams :: !BlockParameters+ , _hfstatements :: !(V.Vector Statement)+ , _hfexpression :: !(S.Maybe Expression)+ }+ deriving Eq++data UValue+ = UBoolean !Bool+ | UString !T.Text+ | UInterpolable !(V.Vector UValue)+ | UUndef+ | UResourceReference !T.Text !Expression+ | UArray !(V.Vector Expression)+ | UHash !(V.Vector (Pair Expression Expression))+ | URegexp !T.Text !Regex+ | UVariableReference !T.Text+ | UFunctionCall !T.Text !(V.Vector Expression)+ | UHFunctionCall !HFunctionCall++-- manual instance because of the Regex problem+instance Eq UValue where+ (==) (UBoolean a) (UBoolean b) = a == b+ (==) (UString a) (UString b) = a == b+ (==) (UInterpolable a) (UInterpolable b) = a == b+ (==) UUndef UUndef = True+ (==) (UResourceReference a1 a2) (UResourceReference b1 b2) = (a1 == b1) && (a2 == b2)+ (==) (UArray a) (UArray b) = a == b+ (==) (UHash a) (UHash b) = a == b+ (==) (URegexp a _) (URegexp b _) = a == b+ (==) (UVariableReference a) (UVariableReference b) = a == b+ (==) (UFunctionCall a1 a2) (UFunctionCall b1 b2) = (a1 == b1) && (a2 == b2)+ (==) _ _ = False++array :: [Expression] -> UValue+array = UArray . V.fromList++data SelectorCase = SelectorValue UValue+ | SelectorDefault+ deriving (Eq)++data Expression+ = Equal !Expression !Expression+ | Different !Expression !Expression+ | Not !Expression+ | And !Expression !Expression+ | Or !Expression !Expression+ | LessThan !Expression !Expression+ | MoreThan !Expression !Expression+ | LessEqualThan !Expression !Expression+ | MoreEqualThan !Expression !Expression+ | RegexMatch !Expression !Expression+ | NotRegexMatch !Expression !Expression+ | Contains !Expression !Expression+ | Addition !Expression !Expression+ | Substraction !Expression !Expression+ | Division !Expression !Expression+ | Multiplication !Expression !Expression+ | Modulo !Expression !Expression+ | RightShift !Expression !Expression+ | LeftShift !Expression !Expression+ | Lookup !Expression !Expression+ | Negate !Expression+ | ConditionalValue !Expression !(V.Vector (Pair SelectorCase Expression))+ | FunctionApplication !Expression !Expression+ | PValue !UValue+ deriving (Eq)++data SearchExpression+ = EqualitySearch !T.Text !Expression+ | NonEqualitySearch !T.Text !Expression+ | AndSearch !SearchExpression !SearchExpression+ | OrSearch !SearchExpression !SearchExpression+ | AlwaysTrue+ deriving Eq++data CollectorType = Collector | ExportedCollector+ deriving (Eq)++toBool :: UValue -> Bool+toBool (UString "") = False+toBool (UInterpolable v) = not (V.null v)+toBool UUndef = False+toBool (UBoolean x) = x+toBool _ = True++data Virtuality = Normal | Virtual | Exported | ExportedRealized+ deriving (Generic, Eq)++data NodeDesc = NodeName !T.Text+ | NodeMatch !T.Text !Regex+ | NodeDefault++instance Eq NodeDesc where+ (==) (NodeName a) (NodeName b) = a == b+ (==) NodeDefault NodeDefault = True+ (==) (NodeMatch a _) (NodeMatch b _) = a == b+ (==) _ _ = False++data Statement+ = ResourceDeclaration !T.Text !Expression !(V.Vector (Pair T.Text Expression)) !Virtuality !PPosition+ | DefaultDeclaration !T.Text !(V.Vector (Pair T.Text Expression)) !PPosition+ | ResourceOverride !T.Text !Expression !(V.Vector (Pair T.Text Expression)) !PPosition+ | ConditionalStatement !(V.Vector (Pair Expression (V.Vector Statement))) !PPosition+ | ClassDeclaration !T.Text !(V.Vector (Pair T.Text (S.Maybe Expression))) !(S.Maybe T.Text) !(V.Vector Statement) !PPosition+ | DefineDeclaration !T.Text !(V.Vector (Pair T.Text (S.Maybe Expression))) !(V.Vector Statement) !PPosition+ | Node !NodeDesc !(V.Vector Statement) !(S.Maybe NodeDesc) !PPosition+ | VariableAssignment !T.Text !Expression !PPosition+ | MainFunctionCall !T.Text !(V.Vector Expression) !PPosition+ | SHFunctionCall !HFunctionCall !PPosition+ | ResourceCollection !CollectorType !T.Text !SearchExpression !(V.Vector (Pair T.Text Expression)) !PPosition+ | Dependency !(Pair T.Text Expression) !(Pair T.Text Expression) !PPosition+ | TopContainer !(V.Vector Statement) !Statement+ deriving Eq++makeClassy ''HFunctionCall+
Puppet/Plugins.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+ {-| This module is used for user plugins. It exports three functions that should be easy to use: 'initLua', 'puppetFunc' and 'closeLua'. Right now it is used by the "Puppet.Daemon" by initializing and destroying the Lua context for each@@ -15,58 +18,46 @@ * All Lua associative arrays that are returned must have a "simple" type for all the keys, as it will be converted to a string. Numbers will be directly-converted and other types will produce strange results.+converted and other types will produce strange results. (currently this doesn't work at all, all associative arrays will be turned into lists, ignoring the keys) * 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) where -import Prelude hiding (catch)+import Puppet.PP import qualified Scripting.Lua as Lua import Scripting.LuaUtils() import Control.Exception-import qualified Data.Map as Map-import Control.Monad.IO.Class+import qualified Data.HashMap.Strict as HM+import qualified Data.Map.Strict as Map import System.IO import qualified Data.Text as T import qualified Data.Text.IO as T+import qualified Data.Vector as V+import Control.Monad.IO.Class import Puppet.Interpreter.Types-import Puppet.Printers import Puppet.Utils -instance Lua.StackValue ResolvedValue+instance Lua.StackValue PValue where- push l (ResolvedString s) = Lua.push l s- push l (ResolvedRegexp s) = Lua.push l s- push l (ResolvedInt i) = Lua.push l (fromIntegral i :: Int)- push l (ResolvedDouble d) = Lua.push l d- push l (ResolvedBool b) = Lua.push l b- 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" :: T.Text)+ push l (PString s) = Lua.push l s+ push l (PBoolean b) = Lua.push l b+ push l (PResourceReference rr _) = Lua.push l rr+ push l (PArray arr) = Lua.push l (V.toList arr)+ push l (PHash m) = Lua.push l (Map.fromList $ HM.toList m)+ push l (PUndef) = Lua.push l ("undefined" :: T.Text) peek l n = do- t <- Lua.ltype l n- case t of- Lua.TBOOLEAN -> fmap (fmap ResolvedBool) (Lua.peek l n)- Lua.TSTRING -> fmap (fmap ResolvedString) (Lua.peek l n)- Lua.TNUMBER -> fmap (fmap ResolvedDouble) (Lua.peek l n)- Lua.TNIL -> return (Just ResolvedUndefined)- Lua.TNONE -> return (Just ResolvedUndefined)- Lua.TTABLE -> do- p <- Lua.peek l n :: IO (Maybe (Map.Map ResolvedValue ResolvedValue))- case p of- Just kp -> let ks = Map.keys kp- cp = map (\(a,b) -> (showValue a, b)) $ Map.toList kp- in if (all (\(a,b) -> a == ResolvedDouble b) (zip ks [1.0..]))- -- horrible trick to check whether we are being returned a list or a hash- -- this will probably fail somehow- then return $ Just (ResolvedArray (map snd cp))- else return $ Just (ResolvedHash cp)- _ -> return Nothing+ Lua.ltype l n >>= \case+ Lua.TBOOLEAN -> fmap (fmap PBoolean) (Lua.peek l n)+ Lua.TSTRING -> fmap (fmap PString) (Lua.peek l n)+ Lua.TNUMBER -> fmap (fmap (PString . tshow)) (Lua.peek l n :: IO (Maybe Double))+ Lua.TNIL -> return (Just PUndef)+ Lua.TNONE -> return (Just PUndef)+ Lua.TTABLE -> fmap (fmap (PArray . V.fromList)) (Lua.peek l n) _ -> return Nothing valuetype _ = Lua.TUSERDATA@@ -76,28 +67,24 @@ -- find files in subdirectories 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 (T.isSuffixOf extension)) o )+checkForSubFiles extension dir =+ catch (fmap Right (getDirContents dir)) (\e -> return $ Left (e :: IOException)) >>= \case+ Right 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 :: T.Text -> T.Text -> T.Text -> IO [T.Text]-getFiles moduledir subdir extension =+getFiles moduledir subdir extension = fmap concat $ getDirContents moduledir- >>= mapM ( (checkForSubFiles extension) . (\x -> moduledir <> "/" <> x <> "/" <> subdir))- >>= return . concat+ >>= mapM ( checkForSubFiles extension . (\x -> moduledir <> "/" <> x <> "/" <> subdir)) getLuaFiles :: T.Text -> IO [T.Text] getLuaFiles moduledir = getFiles moduledir "lib/puppet/parser/luafunctions" ".lua" loadLuaFile :: Lua.LuaState -> T.Text -> IO [T.Text]-loadLuaFile l file = do- r <- Lua.loadfile l (T.unpack file)- case r of+loadLuaFile l file =+ Lua.loadfile l (T.unpack file) >>= \case 0 -> Lua.call l 0 0 >> return [takeBaseName file] _ -> do T.hPutStrLn stderr ("Could not load file " <> file)@@ -105,12 +92,11 @@ {-| 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 -> T.Text -> [ResolvedValue] -> CatalogMonad ResolvedValue-puppetFunc l fn args = do- content <- liftIO $ catch (fmap Right (Lua.callfunc l (T.unpack fn) args)) (\e -> return $ Left $ tshow (e :: SomeException))- case content of+puppetFunc :: Lua.LuaState -> T.Text -> [PValue] -> InterpreterMonad PValue+puppetFunc l fn args =+ liftIO ( catch (fmap Right (Lua.callfunc l (T.unpack fn) args)) (\e -> return $ Left $ show (e :: SomeException)) ) >>= \case Right x -> return x- Left y -> throwPosError y+ Left y -> throwPosError (string y) -- | Initializes the Lua state. The argument is the modules directory. Each -- subdirectory will be traversed for functions.
+ Puppet/Preferences.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE TemplateHaskell #-}+module Puppet.Preferences where++import Puppet.Utils+import Puppet.Interpreter.Types+import Puppet.Plugins+import Puppet.NativeTypes+import Puppet.NativeTypes.Helpers+import Puppet.Stdlib+import PuppetDB.Dummy++import qualified Data.Text as T+import qualified Data.HashMap.Strict as HM+import Control.Lens++data Preferences = Preferences+ { _manifestPath :: FilePath -- ^ The path to the manifests.+ , _modulesPath :: FilePath -- ^ The path to the modules.+ , _templatesPath :: FilePath -- ^ The path to the template.+ , _compilePoolSize :: Int -- ^ Size of the compiler pool.+ , _parsePoolSize :: Int -- ^ Size of the parser pool.+ , _prefPDB :: PuppetDBAPI+ , _natTypes :: Container PuppetTypeMethods -- ^ The list of native types.+ , _prefExtFuncs :: Container ( [PValue] -> InterpreterMonad PValue )+ }++makeClassy ''Preferences++genPreferences :: FilePath+ -> IO Preferences+genPreferences basedir = do+ let manifestdir = basedir <> "/manifests"+ modulesdir = basedir <> "/modules"+ templatedir = basedir <> "/templates"+ typenames <- fmap (map takeBaseName) (getFiles (T.pack modulesdir) "lib/puppet/type" ".rb")+ let loadedTypes = HM.fromList (map defaulttype typenames)+ return $ Preferences manifestdir modulesdir templatedir 4 4 dummyPuppetDB (baseNativeTypes `HM.union` loadedTypes) (stdlibFunctions)
− Puppet/Printers.hs
@@ -1,70 +0,0 @@-module Puppet.Printers (- showRes- , showRRes- , showFCatalog- , showValue- , showRRef- , capitalizeResType- , showScope-) where--import Puppet.Interpreter.Types-import Puppet.DSL.Types-import qualified Data.Map as Map-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 _ _) = 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 -> T.Text-showFCatalog rmap = let- rawlist = groupBy (\((rtype1,_), _) ((rtype2,_), _) -> rtype1 == rtype2) (sort $ Map.toList rmap)- rlist = map (map snd) rawlist- out = T.concat$ map showuniqueres rlist- in out---- helpers--commasep :: [T.Text] -> T.Text-commasep = T.intercalate ", "-commaretsep :: [T.Text] -> T.Text-commaretsep = T.intercalate ",\n"--showRRef :: ResIdentifier -> T.Text-showRRef (rt, rn) = capitalizeResType rt <> "[" <> rn <> "]"---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 (ResolvedUndefined) = "undef"--showuniqueres :: [RResource] -> T.Text-showuniqueres res = mrtype <> " {\n" <> T.concat (map showrres res) <> "}\n"- where- showrres (RResource _ rname _ params rels scopes mpos) =- let relslist = map asparams rels- 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) :: [(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,17 +1,18 @@ {-| A quickly done module that exports utility functions used to collect various-statistics. All statistics are stored in a MVar holding a Map.+statistics. All statistics are stored in a MVar holding a HashMap. -} module Puppet.Stats where import Data.Time.Clock.POSIX (getPOSIXTime) import Control.Monad-import Control.Concurrent.MVar-import qualified Data.Map as Map+import Control.Concurrent+import qualified Data.HashMap.Strict as HM import qualified Data.Text as T+import Control.Lens data StatsPoint = StatsPoint !Int !Double !Double !Double deriving(Show)-type StatsTable = Map.Map T.Text StatsPoint+type StatsTable = HM.HashMap T.Text StatsPoint type MStats = MVar StatsTable @@ -19,36 +20,36 @@ getStats = readMVar newStats :: IO MStats-newStats = newMVar Map.empty+newStats = newMVar HM.empty measure :: MStats -> T.Text -> IO a -> IO a measure mtable statsname action = do- (tm, out) <- time action- !stats <- takeMVar mtable :: IO StatsTable+ (!tm, !out) <- time action+ !stats <- takeMVar mtable let nstats :: StatsTable- !nstats = case Map.lookup statsname stats of- Nothing -> Map.insert statsname (StatsPoint 1 tm tm tm) stats- Just (StatsPoint sc st smi sma) ->- let !nmax = if tm > sma- then tm- else sma- !nmin = if tm < smi- then tm- else smi- in Map.insert statsname (StatsPoint (sc+1) (st+tm) nmin nmax) stats+ !nstats = case stats ^. at statsname of+ Nothing -> stats & at statsname ?~ StatsPoint 1 tm tm tm+ Just (StatsPoint sc st smi sma) ->+ let !nmax = if tm > sma+ then tm+ else sma+ !nmin = if tm < smi+ then tm+ else smi+ in stats & at statsname ?~ StatsPoint (sc+1) (st+tm) nmin nmax putMVar mtable nstats return out measure_ :: MStats -> T.Text -> IO a -> IO ()-measure_ mtable statsname act = void ( measure mtable statsname act )+measure_ mtable statsname action = void ( measure mtable statsname action ) getTime :: IO Double getTime = realToFrac `fmap` getPOSIXTime time :: IO a -> IO (Double, a)-time act = do+time action = do start <- getTime- !result <- act+ !result <- action end <- getTime let !delta = end - start return (delta, result)
+ Puppet/Stdlib.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE LambdaCase #-}+module Puppet.Stdlib (stdlibFunctions) where++import Puppet.PP+import Puppet.Parser.Types+import Puppet.Interpreter.Resolve+import Puppet.Interpreter.Types++import Control.Lens+import Data.Char+import Data.Monoid+import Control.Monad+import Control.Monad.IO.Class+import Text.Regex.PCRE.ByteString+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Attoparsec.Number+import qualified Data.ByteString.Base16 as B16++stdlibFunctions :: Container ( [PValue] -> InterpreterMonad PValue )+stdlibFunctions = HM.fromList [ ("abs", puppetAbs)+ , ("any2array", any2array)+ , ("base64", base64)+ , ("bool2num", bool2num)+ , ("capitalize", stringArrayFunction (safeEmptyString (\t -> T.cons (toUpper (T.head t)) (T.tail t))))+ , ("chomp", stringArrayFunction (T.dropWhileEnd (\c -> c == '\n' || c == '\r')))+ , ("chop", stringArrayFunction (safeEmptyString T.init))+ , ("concat", puppetConcat)+ , ("count", puppetCount)+ , ("defined_with_params", const (throwPosError "defined_with_params can't be implemented with language-puppet"))+ , ("delete", delete)+ , ("delete_at", deleteAt)+ , ("delete_undef_values", deleteUndefValues)+ , ("downcase", stringArrayFunction T.toLower)+ , ("getvar", getvar)+ , ("is_domain_name", isDomainName)+ , ("is_integer", isInteger)+ , ("keys", keys)+ , ("lstrip", stringArrayFunction T.stripStart)+ , ("merge", merge)+ , ("rstrip", stringArrayFunction T.stripEnd)+ , ("strip", stringArrayFunction T.strip)+ , ("upcase", stringArrayFunction T.toUpper)+ , ("validate_array", validateArray)+ , ("validate_bool", validateBool)+ , ("validate_hash", validateHash)+ , ("validate_re", validateRe)+ , ("validate_string", validateString)+ ]++safeEmptyString :: (T.Text -> T.Text) -> T.Text -> T.Text+safeEmptyString _ "" = ""+safeEmptyString f x = f x++stringArrayFunction :: (T.Text -> T.Text) -> [PValue] -> InterpreterMonad PValue+stringArrayFunction f [PString s] = return (PString (f s))+stringArrayFunction f [PArray xs] = fmap PArray (V.mapM (fmap (PString . f) . resolvePValueString) xs)+stringArrayFunction _ [a] = throwPosError ("function expects a string or an array of strings, not" <+> pretty a)+stringArrayFunction _ _ = throwPosError "function expects a single argument"+++compileRE :: T.Text -> InterpreterMonad Regex+compileRE p =+ (liftIO . compile compBlank execBlank . T.encodeUtf8) p >>= \case+ Right r -> return r+ Left ms -> throwPosError ("Can't parse regexp" <+> pretty (URegexp p undefined) <+> ":" <+> text (show ms))++puppetAbs :: [PValue] -> InterpreterMonad PValue+puppetAbs [y] = case y ^? pvnum of+ Just (I x) -> return $ pvnum # I (abs x)+ Just (D x) -> return $ pvnum # D (abs x)+ Nothing -> throwPosError ("abs(): Expects a number, not" <+> pretty y)+puppetAbs _ = throwPosError "abs(): Takes a single argument"++any2array :: [PValue] -> InterpreterMonad PValue+any2array [PArray v] = return (PArray v)+any2array [PHash h] = return (PArray lst)+ where lst = V.fromList $ concatMap arraypair $ HM.toList h+ arraypair (a,b) = [PString a, b]+any2array [x] = return (PArray (V.singleton x))+any2array x = return (PArray (V.fromList x))++base64 :: [PValue] -> InterpreterMonad PValue+base64 [pa,pb] = do+ b <- fmap T.encodeUtf8 (resolvePValueString pb)+ r <- resolvePValueString pa >>= \case+ "encode" -> return (B16.encode b)+ "decode" -> case B16.decode b of+ (x, "") -> return x+ _ -> throwPosError ("base64(): could not decode" <+> pretty pb)+ a -> throwPosError ("base64(): the first argument must be either 'encode' or 'decode', not" <+> ttext a)+ fmap PString (safeDecodeUtf8 r)++base64 _ = throwPosError "base64(): Expects 2 arguments"++bool2num :: [PValue] -> InterpreterMonad PValue+bool2num [PString ""] = return (PBoolean False)+bool2num [PString "1"] = return (PBoolean True)+bool2num [PString "t"] = return (PBoolean True)+bool2num [PString "y"] = return (PBoolean True)+bool2num [PString "true"] = return (PBoolean True)+bool2num [PString "yes"] = return (PBoolean True)+bool2num [PString "0"] = return (PBoolean False)+bool2num [PString "f"] = return (PBoolean False)+bool2num [PString "n"] = return (PBoolean False)+bool2num [PString "false"] = return (PBoolean False)+bool2num [PString "no"] = return (PBoolean False)+bool2num [PString "undef"] = return (PBoolean False)+bool2num [PString "undefined"] = return (PBoolean False)+bool2num [x@(PBoolean _)] = return x+bool2num [x] = throwPosError ("bool2num(): Can't convert" <+> pretty x <+> "to boolean")+bool2num _ = throwPosError "bool2num() expects a single argument"++puppetConcat :: [PValue] -> InterpreterMonad PValue+puppetConcat [PArray a, PArray b] = return (PArray (a <> b))+puppetConcat [a,b] = throwPosError ("concat(): both arguments must be arrays, not" <+> pretty a <+> "or" <+> pretty b)+puppetConcat _ = throwPosError "concat(): expects 2 arguments"++puppetCount :: [PValue] -> InterpreterMonad PValue+puppetCount [PArray x] = return (pvnum # I (V.foldl' cnt 0 x))+ where+ cnt cur (PString "") = cur+ cnt cur PUndef = cur+ cnt cur _ = cur + 1+puppetCount [PArray x, y] = return (pvnum # I (V.foldl' cnt 0 x))+ where+ cnt cur z | y == z = cur + 1+ | otherwise = cur+puppetCount _ = throwPosError "count(): expects 1 or 2 arguments"++delete :: [PValue] -> InterpreterMonad PValue+delete [PString x, y] = do+ ty <- resolvePValueString y+ return $ PString $ T.concat $ T.splitOn ty x+delete [PArray r, z] = return $ PArray $ V.filter (/= z) r+delete [PHash h, z] = do+ tz <- resolvePValueString z+ return $ PHash (h & at tz .~ Nothing)+delete [a,_] = throwPosError ("delete(): First argument must be an Array, String, or Hash. Given:" <+> pretty a)+delete _ = throwPosError "delete(): expects 2 arguments"++deleteAt :: [PValue] -> InterpreterMonad PValue+deleteAt [PArray r, z] = case z ^? pvnum of+ Just (I gn) ->+ let n = fromInteger gn+ lr = V.length r+ s1 = V.slice 0 n r+ s2 = V.slice (n+1) (lr - n - 1) r+ in if V.length r >= n+ then throwPosError ("delete_at(): Out of bounds access detected, tried to remove index" <+> pretty z <+> "wheras the array only has" <+> string (show lr) <+> "elements")+ else return (PArray (s1 <> s2))+ _ -> throwPosError ("delete_at(): The second argument must be an integer, not" <+> pretty z)+deleteAt [x,_] = throwPosError ("delete_at(): expects its first argument to be an array, not" <+> pretty x)+deleteAt _ = throwPosError "delete_at(): expects 2 arguments"++deleteUndefValues :: [PValue] -> InterpreterMonad PValue+deleteUndefValues [PArray r] = return $ PArray $ V.filter (/= PUndef) r+deleteUndefValues [PHash h] = return $ PHash $ HM.filter (/= PUndef) h+deleteUndefValues [x] = throwPosError ("delete_undef_values(): Expects an Array or a Hash, not" <+> pretty x)+deleteUndefValues _ = throwPosError "delete_undef_values(): Expects a single argument"++getvar :: [PValue] -> InterpreterMonad PValue+getvar [x] = resolvePValueString x >>= resolveVariable+getvar _ = throwPosError "getvar() expects a single argument"+++isDomainName :: [PValue] -> InterpreterMonad PValue+isDomainName [s] = do+ rs <- resolvePValueString s+ let ndrs = if T.last rs == '.'+ then T.init rs+ else rs+ prts = T.splitOn "." ndrs+ checkPart x = not (T.null x)+ && (T.length x <= 63)+ && (T.head x /= '-')+ && (T.last x /= '-')+ && T.all (\y -> isAlphaNum y || y == '-') x+ return $ PBoolean $ not (T.null rs) && T.length rs <= 255 && all checkPart prts+isDomainName _ = throwPosError "is_domain_name(): Should only take a single argument"++isInteger :: [PValue] -> InterpreterMonad PValue+isInteger [i] = return (PBoolean (not (isn't pvnum i)))+isInteger _ = throwPosError "is_integer(): Should only take a single argument"++keys :: [PValue] -> InterpreterMonad PValue+keys [PHash h] = return (PArray $ V.fromList $ map PString $ HM.keys h)+keys [x] = throwPosError ("keys(): Expects a Hash, not" <+> pretty x)+keys _ = throwPosError "keys(): expects a single argument"++merge :: [PValue] -> InterpreterMonad PValue+merge [PHash a, PHash b] = return (PHash (b `HM.union` a))+merge [a,b] = throwPosError ("merge(): Expects two hashes, not" <+> pretty a <+> pretty b)+merge _ = throwPosError "merge(): Expects two hashes"++validateArray :: [PValue] -> InterpreterMonad PValue+validateArray [] = throwPosError "validate_array(): wrong number of arguments, must be > 0"+validateArray x = mapM_ vb x >> return PUndef+ where+ vb (PArray _) = return ()+ vb y = throwPosError (pretty y <+> "is not an array.")++validateBool :: [PValue] -> InterpreterMonad PValue+validateBool [] = throwPosError "validate_bool(): wrong number of arguments, must be > 0"+validateBool x = mapM_ vb x >> return PUndef+ where+ vb (PBoolean _) = return ()+ vb y = throwPosError (pretty y <+> "is not a boolean.")++validateHash :: [PValue] -> InterpreterMonad PValue+validateHash [] = throwPosError "validate_hash(): wrong number of arguments, must be > 0"+validateHash x = mapM_ vb x >> return PUndef+ where+ vb (PHash _) = return ()+ vb y = throwPosError (pretty y <+> "is not a hash.")++validateRe :: [PValue] -> InterpreterMonad PValue+validateRe [str, reg] = validateRe [str, reg, PString "Match failed"]+validateRe [str, PString reg, msg] = validateRe [str, PArray (V.singleton (PString reg)), msg]+validateRe [str, PArray v, msg] = do+ rstr <- fmap T.encodeUtf8 (resolvePValueString str)+ let matchRE :: Regex -> InterpreterMonad Bool+ matchRE r = liftIO (execute r rstr) >>= \case+ Left rr -> throwPosError ("Regexp matching critical failure" <+> text (show rr))+ Right Nothing -> return False+ _ -> return True+ rest <- mapM (resolvePValueString >=> compileRE >=> matchRE) (V.toList v)+ if or rest+ then return PUndef+ else throwPosError (pretty msg <$> "Source string:" <+> pretty str <> comma <+> "regexps:" <+> pretty (V.toList v))+validateRe [_, r, _] = throwPosError ("validate_re(): expected a regexp or an array of regexps, but not" <+> pretty r)+validateRe _ = throwPosError "validate_re(): wrong number of arguments (#{args.length}; must be 2 or 3)"++validateString :: [PValue] -> InterpreterMonad PValue+validateString [] = throwPosError "validate_string(): wrong number of arguments, must be > 0"+validateString x = mapM_ resolvePValueString x >> return PUndef
Puppet/Testing.hs view
@@ -1,291 +1,107 @@+{-# LANGUAGE TemplateHaskell #-} module Puppet.Testing- ( testCatalog- , Test(..)- , TestsState(..)- , testFileSources- , TestResult- , TestMonad- , testingDaemon+ ( module Control.Lens+ , module Data.Monoid+ , module Puppet.PP , module Puppet.Interpreter.Types- , getFileContent- , getResource- , fileContent- , isEnsure- , isPresent- , isAbsent- , checkResource- , checkResources- , egrep- , sha1sum- , runTests- , sequenceCheck- , sequenceCheck_- , getParameter- , getParameterM- , equalOrAbsentParameter- , equalParameter- , equalParameters- , (.>)- , toByteString- , runFullTests+ , basicTest+ , testingDaemon+ , testCatalog+ , describeCatalog+ , it+ , shouldBe ) where -import qualified Data.Map as Map+import Prelude hiding (notElem,all)+import Control.Monad.RWS.Strict hiding ((<>))+import Control.Lens+import Data.Foldable hiding (forM_) import Data.Maybe-import Data.Either+import Data.Monoid import Control.Monad.Error-import Control.Monad.State.Strict+import Control.Monad.Reader+import Control.Applicative hiding ((<$>)) import System.Posix.Files-import qualified System.Log.Logger as LOG+import qualified Data.Either.Strict as S 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+import qualified System.Log.Logger as LOG+import qualified Test.Hspec as H+import qualified Test.Hspec.Formatters as H+import qualified Test.Hspec.Runner as H+import qualified Test.Hspec.Core as HC -import Puppet.Interpreter.Types-import Puppet.Interpreter.Functions-import Puppet.Init+import Puppet.Preferences+import Puppet.PP 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 T.Text [TestR]- | SingleTestR T.Text (Either String ())- deriving (Show)--data Test- = TestGroup T.Text [Test]- | TestFirstOk T.Text [Test]- | SingleTest T.Text (FinalCatalog -> TestResult)+import Puppet.Interpreter.Types+import Puppet.Interpreter.PrettyPrinter () -failedTests :: TestR -> Maybe TestR-failedTests (TestGroupR d tests) = case mapMaybe failedTests tests of- [] -> Nothing- x -> Just (TestGroupR d x)-failedTests t@(SingleTestR _ (Left _)) = Just t-failedTests _ = Nothing+data TestEnv = TestEnv { _catalog :: FinalCatalog+ , _moduledir :: FilePath+ , _puppetdir :: FilePath+ }+makeClassy ''TestEnv -showResT :: TestR -> T.Text-showResT = showRes' 0- where- 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+type PSpecM = ReaderT TestEnv HC.SpecM+type PSpec = PSpecM () --- 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)+testCatalog :: Nodename -> FilePath -> FinalCatalog -> PSpec -> IO H.Summary+testCatalog nd pdir catlg test = H.hspecWith (H.defaultConfig { H.configFormatter = H.failed_examples }) (describeCatalog nd pdir catlg test) -testFileSources :: T.Text -> FinalCatalog -> Test-testFileSources puppetdir cat =- let fileresources = Map.elems $ Map.filterWithKey (\k _ -> fst k == "file") cat- filesources = mapMaybe (Map.lookup "source" . rrparams) fileresources- checkSrcExists :: T.Text -> FinalCatalog -> TestResult- checkSrcExists src _ = runErrorT $ do- place <- sourceToPath (T.unpack puppetdir) src- case place of- Just p -> liftIO (fileExist p) >>= (`unless` (throwError $ "Searched in " ++ p))- Nothing -> return ()- genFileTest :: ResolvedValue -> Test- 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)+describeCatalog :: Nodename -> FilePath -> FinalCatalog -> PSpec -> H.Spec+describeCatalog nd pdir catlg test = H.describe (T.unpack nd) $ runReaderT test (TestEnv catlg (pdir <> "/modules") pdir) -unsingle :: TestR -> Either String ()-unsingle (SingleTestR desc (Left err)) = Left (T.unpack desc ++ " failed: " ++ err)-unsingle (SingleTestR _ _ ) = Right ()-unsingle x = Left ("Bad type for unsingle " ++ show x)+basicTest :: PSpec+basicTest = hTestFileSources -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- case lefts allRes of- [] -> return $ SingleTestR desc (Right ())- x -> return $ SingleTestR desc (Left (show x))+it :: HC.Example a => String -> PSpecM a -> PSpec+it n tst = tst >>= lift . H.it n -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 $ T.unpack $ showResT fl+shouldBe :: (Show a, Eq a) => a -> a -> PSpecM H.Expectation+shouldBe a b = return (a `H.shouldBe` b) -testCatalog :: T.Text -> FinalCatalog -> [Test] -> IO (Either String (), TestsState)-testCatalog puppetdir catalog stests = runStateT (runTests (TestGroup "All Tests" ( testFileSources puppetdir catalog : stests )) catalog) newState+hTestFileSources :: PSpec+hTestFileSources = do+ let getFiles = filter presentFile . toList+ presentFile r | r ^. rid . itype /= "file" = False+ | (r ^. rattributes . at "ensure") `notElem` [Nothing, Just "present"] = False+ | r ^. rattributes . at "source" == Just PUndef = False+ | otherwise = True+ getSource = mapMaybe (\r -> (,) `fmap` pure r <*> r ^. rattributes . at "source")+ files <- fmap (getSource . getFiles) $ view catalog+ pdir <- view puppetdir+ forM_ files $ \(r,filesource) -> it ("should have a source for " ++ r ^. rid . iname . to T.unpack) $ do+ let+ testFile :: FilePath -> ErrorT Doc IO ()+ testFile fp = liftIO (fileExist fp) >>= (`unless` (throwError $ "Searched in" <+> string fp))+ checkFile :: PValue -> ErrorT Doc IO ()+ checkFile res@(PArray ar) = asum [checkFile x | x <- toList ar] <|> throwError ("Could not find the file in" <+> pretty res)+ checkFile (PString f) = do+ stringdir <- case T.stripPrefix "puppet:///" f of+ Just o -> return o+ Nothing -> throwError ("The source does not start with puppet:///, but is" <+> ttext f)+ case T.splitOn "/" stringdir of+ ("modules":modulename:rest) -> testFile (pdir <> "/modules/" <> T.unpack modulename <> "/files/" <> T.unpack (T.intercalate "/" rest))+ ("files":rest) -> testFile (pdir <> "/files/" <> T.unpack (T.intercalate "/" rest))+ ("private":_) -> return ()+ _ -> throwError ("Invalid file source:" <+> ttext f)+ checkFile x = throwError ("Source was not a string, but" <+> pretty x)+ return $ do+ rs <- runErrorT (checkFile filesource)+ case rs of+ Right () -> return ()+ Left rr -> fail (show rr) -- | 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+ -> FilePath -- ^ Path to the manifests+ -> (T.Text -> IO (Container T.Text)) -- ^ The facter function+ -> IO (T.Text -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog)))+testingDaemon purl pdir 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- )+ prefs <- genPreferences pdir+ q <- initDaemon (prefs { _compilePoolSize = 8, _parsePoolSize = 2 })+ return (\nodname -> allFacts nodname >>= _dGetCatalog q nodname) --- | 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
@@ -1,79 +1,50 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}- module Puppet.Utils- ( mGetExecutablePath- , readFile'- , readSymbolicLink- , tshow- , dq- , readDecimal+ ( readDecimal+ , readRational+ , puppet2number , textElem , module Data.Monoid , getDirectoryContents , takeBaseName , takeDirectory- , regexpSplit- , regexpMatched- , regexpUnmatched- , regexpAll- , RegexpSplit(..)+ , strictifyEither ) 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+import qualified Data.Either.Strict as S -tshow :: Show a => a -> T.Text-tshow = T.pack . show+import Puppet.Interpreter.Types -dq :: T.Text -> T.Text-dq x = T.cons '"' (T.snoc x '"')+strictifyEither :: Either a b -> S.Either a b+strictifyEither (Left x) = S.Left x+strictifyEither (Right x) = S.Right x readDecimal :: (Integral a) => T.Text -> Either String a-readDecimal t = case T.decimal t of+readDecimal t = case T.signed T.decimal t of Right (x, "") -> Right x Right _ -> Left "Trailing characters when reading an integer" Left r -> Left r +readRational :: Fractional a => T.Text -> Either String a+readRational t = case T.signed T.rational t of+ Right (x, "") -> Right x+ Right _ -> Left "Trailing characters when reading an integer"+ Left r -> Left r++puppet2number :: PValue -> Maybe (Either Double Integer)+puppet2number (PString s) = case (readDecimal s, readRational s) of+ (Right i,_) -> Just (Right i)+ (_,Right d) -> Just (Left d)+ _ -> Nothing+puppet2number _ = Nothing+ textElem :: Char -> T.Text -> Bool-textElem c t = T.any (==c) t+textElem c = T.any (==c) getDirectoryContents :: T.Text -> IO [T.Text] getDirectoryContents fpath = do@@ -82,7 +53,7 @@ fp <- readDirStream h if BS.null fp then return []- else fmap (\e -> T.decodeUtf8 fp : e) readHandle+ else fmap (T.decodeUtf8 fp :) readHandle out <- readHandle closeDirStream h return out@@ -101,7 +72,7 @@ takeDirectory x = let res = T.dropWhileEnd (== '/') file file = dropFileName x- in if T.null res && (not (T.null file))+ in if T.null res && not (T.null file) then file else res @@ -133,47 +104,3 @@ 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/Common.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE LambdaCase #-}+module PuppetDB.Common where++import Puppet.PP+import Puppet.Interpreter.Types+import PuppetDB.Remote+import PuppetDB.Dummy+import PuppetDB.TestDB++import Data.Maybe+import Data.List (stripPrefix)+import Control.Lens+import System.Environment+import qualified Data.Either.Strict as S+import Data.Vector.Lens++data PDBType = PDBRemote | PDBDummy | PDBTest++instance Read PDBType where+ readsPrec _ r | isJust reml = [(PDBRemote, fromJust reml)]+ | isJust rems = [(PDBRemote, fromJust rems)]+ | isJust duml = [(PDBDummy, fromJust duml)]+ | isJust dums = [(PDBDummy, fromJust dums)]+ | isJust tstl = [(PDBTest, fromJust tstl)]+ | isJust tsts = [(PDBTest, fromJust tsts)]+ | otherwise = []+ where+ reml = stripPrefix "PDBRemote" r+ rems = stripPrefix "remote" r+ duml = stripPrefix "PDBDummy" r+ dums = stripPrefix "dummy" r+ tstl = stripPrefix "PDBTest" r+ tsts = stripPrefix "test" r++getDefaultDB :: PDBType -> IO (S.Either Doc PuppetDBAPI)+getDefaultDB PDBDummy = return (S.Right dummyPuppetDB)+getDefaultDB PDBRemote = pdbConnect "http://localhost:8080"+getDefaultDB PDBTest = lookupEnv "HOME" >>= \case+ Just h -> loadTestDB (h ++ "/.testdb")+ Nothing -> fmap S.Right initTestDB++generateWireCatalog :: Nodename -> FinalCatalog -> EdgeMap -> WireCatalog+generateWireCatalog ndename finalcat edgemap = WireCatalog ndename "version" edges resources "uiid"+ where+ edges = toVectorOf (folded . to (\li -> PuppetEdge (li ^. linksrc) (li ^. linkdst) (li ^. linkType))) (concatOf folded edgemap)+ resources = toVectorOf folded finalcat
+ PuppetDB/Dummy.hs view
@@ -0,0 +1,17 @@+module PuppetDB.Dummy where++import Puppet.Interpreter.Types+import qualified Data.Either.Strict as S++dummyPuppetDB :: PuppetDBAPI+dummyPuppetDB = PuppetDBAPI+ (return "dummy")+ (const (return (S.Right () )))+ (const (return (S.Right () )))+ (const (return (S.Right () )))+ (const (return (S.Left "not implemented")))+ (const (return (S.Right [] )))+ (const (return (S.Right [] )))+ (return (S.Left "not implemented"))+ (\_ _ -> return (S.Right [] ))+
− PuppetDB/Query.hs
@@ -1,70 +0,0 @@-module PuppetDB.Query where--import Puppet.DSL.Types-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 T.Text | Terms [T.Text]- deriving (Show, Ord, Eq)---- | Query used for realizing a resources, when its type and title is known.-queryRealize :: T.Text -> T.Text -> Query-queryRealize rtype rtitle = Query OAnd- [ Query OEqual [ Term "type", Term (capitalizeResType rtype) ]- , Query OEqual [ Term "title", Term rtitle ]- , Query OEqual [ Term "exported", Term "true" ]- ]---- | Collects all resources of a given type-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 :: T.Text -> T.Text -> Query-collectTag rtype tagval = Query OAnd- [ Query OEqual [ Term "type", Term (capitalizeResType rtype) ]- , Query OEqual [ Term "tag" , Term tagval ]- , Query OEqual [ Term "exported", Term "true" ]- ]---- | Used to emulate collections such as `Type<|| prmname == "prmval" ||>`-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" ]- ]--showOperator :: Operator -> T.Text-showOperator OEqual = dq "="-showOperator OOver = dq ">"-showOperator OUnder = dq "<"-showOperator OOverE = dq ">="-showOperator OUnderE = dq "<="-showOperator OAnd = dq "and"-showOperator OOr = dq "or"-showOperator ONot = dq "not"--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/Remote.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE LambdaCase #-}+module PuppetDB.Remote where++import Puppet.Utils+import Puppet.PP++import Puppet.Interpreter.Types++import Network.HTTP.Conduit+import qualified Network.HTTP.Types as W+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Char8 as BC+import Data.Aeson+import qualified Codec.Text.IConv as IConv+import qualified Control.Exception as X+import Control.Monad.Error+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Either.Strict as S++runRequest req = do+ let doRequest = withManager (fmap responseBody . httpLbs req) :: IO L.ByteString+ eHandler :: X.SomeException -> IO (Either Doc L.ByteString)+ eHandler e = return $ Left $ string (show e) <> ", with queryString " <+> string (BC.unpack (queryString req))+ liftIO (fmap Right doRequest `X.catch` eHandler) >>= \case+ Right o -> do+ let utf8 = IConv.convert "LATIN1" "UTF-8" o+ case decode' utf8 of+ Just x -> return x+ Nothing -> throwError ("Json decoding has failed " <> string (show utf8))+ Left err -> throwError err++pdbRequest :: (FromJSON a, ToJSON b) => T.Text -> T.Text -> b -> IO (S.Either Doc a)+pdbRequest url querytype query = fmap strictifyEither $ runErrorT $ do+ let jsonquery = L.toStrict (encode query)+ q = case toJSON query of+ Null -> ""+ _ -> T.decodeUtf8 $ "?" <> W.renderSimpleQuery False [("query", jsonquery)]+ let fullurl = url <> "/v3/" <> querytype <> q+ initReq <- case (parseUrl (T.unpack fullurl) :: Maybe (Request a)) of+ Just x -> return x+ Nothing -> throwError "Something failed when parsing the PuppetDB URL"+ let req = initReq { requestHeaders = [("Accept", "application/json")] }+ runRequest req++pdbConnect :: T.Text -> IO (S.Either Doc PuppetDBAPI)+pdbConnect url = return $ S.Right $ PuppetDBAPI+ (return (ttext url))+ (const (return (S.Left "operation not supported")))+ (const (return (S.Left "operation not supported")))+ (const (return (S.Left "operation not supported")))+ (pdbRequest url "facts")+ (pdbRequest url "resources")+ (pdbRequest url "nodes")+ (return (S.Left "operation not supported"))+ (\nodename -> pdbRequest url ("nodes/" <> nodename <> "/resources"))+
− PuppetDB/Rest.hs
@@ -1,44 +0,0 @@-module PuppetDB.Rest where--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 Data.Aeson-import qualified Codec.Text.IConv as IConv-import qualified Control.Exception as X-import Control.Monad.Error-import Puppet.Utils-import qualified Data.Text as T-import qualified Data.Text.Encoding as T--runRequest req = do- 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)- case mo of- Right o -> do- let utf8 = IConv.convert "LATIN1" "UTF-8" o- case decode' utf8 of- Just x -> return x- Nothing -> throwError "Json decoding has failed"- Left err -> throwError err--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) => 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 " ++ T.unpack querytype)- let q = case querytype of- "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"- let req = initReq { requestHeaders = [("Accept", "application/json")] }- runRequest req
PuppetDB/TestDB.hs view
@@ -1,76 +1,171 @@-module PuppetDB.TestDB (initTestDBFunctions) where+{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}+module PuppetDB.TestDB (loadTestDB,initTestDB) where -import PuppetDB.Query+-- import Data.Aeson+import Data.Yaml+import qualified Data.Text as T+import qualified Data.Either.Strict as S+import qualified Data.Vector as V+import Control.Lens+import Control.Exception+import Control.Concurrent.STM+import Data.Monoid+import Control.Applicative+import Data.List (foldl')+import Text.Parsec.Pos+import Data.CaseInsensitive+import Debug.Trace+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS++import Puppet.Parser.Types import Puppet.Interpreter.Types-import Puppet.DSL.Types hiding (Value)+import Puppet.Interpreter.Resolve+import Puppet.PP hiding ((<$>)) -import Data.Aeson-import qualified Data.Map as Map-import Control.Concurrent.MVar-import qualified Data.Text as T+data DBContent = DBContent { _dbcontentResources :: Container WireCatalog+ , _dbcontentFacts :: Container Facts+ , _dbcontentBackingFile :: Maybe FilePath+ }+makeFields ''DBContent -type ExportedResources = Map.Map T.Text (FinalCatalog, EdgeMap, FinalCatalog)+type DB = TVar DBContent -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)+instance FromJSON DBContent where+ parseJSON (Object v) = DBContent <$> v .: "resources" <*> v .: "facts" <*> pure Nothing+ parseJSON _ = mempty -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'+instance ToJSON DBContent where+ toJSON (DBContent r f _) = object [("resources", toJSON r), ("facts", toJSON f)] -toBool :: T.Text -> Either String Bool-toBool "true" = Right True-toBool "false" = Right False-toBool x = Left ("Is not a boolean " ++ T.unpack x) +-- | Initializes the test DB using a file to back its content+loadTestDB :: FilePath -> IO (S.Either Doc PuppetDBAPI)+loadTestDB fp =+ decodeFileEither fp >>= \case+ Left (OtherParseException rr) -> return (S.Left (string (show rr)))+ Left rr -> trace ("Warning: could not decode " ++ fp ++ " :" ++ show rr) (S.Right <$> initTestDB)+ Right x -> fmap S.Right (genDBAPI (x & backingFile ?~ fp )) -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)+initTestDB :: IO PuppetDBAPI+initTestDB = genDBAPI newDB -queryPDB _ _ querytype query = error (show (querytype, query))+newDB :: DBContent+newDB = DBContent mempty mempty Nothing++genDBAPI :: DBContent -> IO PuppetDBAPI+genDBAPI db = do+ d <- newTVarIO db+ return (PuppetDBAPI (dbapiInfo d)+ (replCat d)+ (replFacts d)+ (deactivate d)+ (getFcts d)+ (getRes d)+ (getNds d)+ (commit d)+ (getResNode d)+ )++data Extracted = EText T.Text+ | ESet (HS.HashSet T.Text)+ | ENil++resolveQuery :: (a -> b -> Extracted) -> Query a -> (b -> Bool)+resolveQuery _ QEmpty = const True+resolveQuery f (QEqual a t) = \v -> case f a v of+ EText tt -> mk tt == mk t+ ESet ss -> ss ^. contains t+ _ -> False+resolveQuery f (QNot q) = not . resolveQuery f q+resolveQuery f (QG a i) = ncompare (>) f a i+resolveQuery f (QL a i) = ncompare (<) f a i+resolveQuery f (QGE a i) = ncompare (>=) f a i+resolveQuery f (QLE a i) = ncompare (<=) f a i+resolveQuery _ (QMatch _ _) = const False+resolveQuery f (QAnd qs) = \v -> all (\q -> resolveQuery f q v) qs+resolveQuery f (QOr qs) = \v -> any (\q -> resolveQuery f q v) qs++dbapiInfo :: DB -> IO Doc+dbapiInfo db = do+ c <- readTVarIO db+ case c ^. backingFile of+ Nothing -> return "TestDB"+ Just v -> return ("TestDB" <+> string v)++ncompare :: (Integer -> Integer -> Bool) -> (a -> b -> Extracted) -> a -> Integer -> (b -> Bool)+ncompare operation f a i v = case f a v of+ EText tt -> case PString tt ^? _PInteger of+ Just ii -> operation i ii+ _ -> False+ _ -> False++mustWork :: IO () -> IO (S.Either Doc ())+mustWork a = a >> return (S.Right ())++replCat :: DB -> WireCatalog -> IO (S.Either Doc ())+replCat db wc = mustWork $ atomically $ modifyTVar db (resources . at (wc ^. nodename) ?~ wc)++replFacts :: DB -> [(Nodename, Facts)] -> IO (S.Either Doc ())+replFacts db lst = mustWork $ atomically $ modifyTVar db $+ facts %~ (\r -> foldl' (\curr (n,f) -> curr & at n ?~ f) r lst)++deactivate :: DB -> Nodename -> IO (S.Either Doc ())+deactivate db n = mustWork $ atomically $ modifyTVar db $+ (resources . at n .~ Nothing) . (facts . at n .~ Nothing)++getFcts :: DB -> Query FactField -> IO (S.Either Doc [PFactInfo])+getFcts db f = fmap (S.Right . filter (resolveQuery factQuery f) . toFactInfo) (readTVarIO db)+ where+ toFactInfo :: DBContent -> [PFactInfo]+ toFactInfo = concatMap gf . HM.toList . _dbcontentFacts+ where+ gf (k,n) = do+ (fn,fv) <- HM.toList n+ return $ PFactInfo k fn fv+ factQuery :: FactField -> PFactInfo -> Extracted+ factQuery t = EText . view l+ where+ l = case t of+ FName -> factname+ FValue -> factval+ FCertname -> nodename++resourceQuery :: ResourceField -> Resource -> Extracted+resourceQuery RTag r = r ^. rtags . to ESet+resourceQuery RCertname r = case r ^. rnode of+ Just t -> EText t+ Nothing -> ENil+resourceQuery (RParameter p) r = case r ^? rattributes . ix p . _PString of+ Just s -> EText s+ Nothing -> ENil+resourceQuery RType r = r ^. rid . itype . to EText+resourceQuery RTitle r = r ^. rid . iname . to EText+resourceQuery RExported r = if r ^. rvirtuality == Exported+ then EText "true"+ else EText "false"+resourceQuery RFile r = r ^. rpos . _1 . to sourceName . to T.pack . to EText+resourceQuery RLine r = r ^. rpos . _1 . to sourceLine . to show . to T.pack . to EText++getRes :: DB -> Query ResourceField -> IO (S.Either Doc [Resource])+getRes db f = fmap (S.Right . filter (resolveQuery resourceQuery f) . toResources) (readTVarIO db)+ where+ toResources :: DBContent -> [Resource]+ toResources = concatMap (V.toList . view wResources) . HM.elems . view resources++getResNode :: DB -> Nodename -> Query ResourceField -> IO (S.Either Doc [Resource])+getResNode db nn f = do+ c <- readTVarIO db+ return $ case c ^. resources . at nn of+ Just cnt -> S.Right $ filter (resolveQuery resourceQuery f) $ V.toList $ cnt ^. wResources+ Nothing -> S.Left "Unknown node"++commit :: DB -> IO (S.Either Doc ())+commit db = do+ dbc <- atomically $ readTVar db+ case dbc ^. backingFile of+ Nothing -> return (S.Left "No backing file defined")+ Just bf -> fmap S.Right (encodeFile bf dbc) `catches` [ ]++getNds :: DB -> Query NodeField -> IO (S.Either Doc [PNodeInfo])+getNds _ _ = return (S.Left "getNds not implemented")
SafeProcess.hs view
@@ -1,5 +1,5 @@+{-# LANGUAGE LambdaCase #-} -- from http://stackoverflow.com/questions/8820903/haskell-how-to-timeout-a-function-that-runs-an-external-command- module SafeProcess where import Control.Concurrent@@ -52,12 +52,11 @@ -- fork a thread to consume output output <- T.hGetContents outh outMVar <- newEmptyMVar- forkIO $ evaluate (T.length output) >> putMVar outMVar ()+ _ <- forkIO $ evaluate (T.length output) >> putMVar outMVar () -- wait on output takeMVar outMVar hClose outh- ex <- waitForProcess ph- case ex of+ waitForProcess ph >>= \case ExitSuccess -> return $ Right output ExitFailure r -> return $ Left $ prog ++ " " ++ show args ++ " failed, errorcode = " ++ show r )@@ -65,8 +64,7 @@ terminateProcessGroup :: ProcessHandle -> IO () terminateProcessGroup ph = do let (ProcessHandle pmvar) = ph- ph_ <- readMVar pmvar- case ph_ of+ readMVar pmvar >>= \case OpenHandle pid -> do -- pid is a POSIX pid signalProcessGroup 15 pid _ -> return ()
+ Text/Parser/Parsec.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module : Text.Parser.Parsec+-- Copyright : (C) 2012-2013 Edward Kmett,+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : MPTCs, undecidable instances+--+-- This module provides instances that permit @parsec@ parsers to use+-- the combinators from the @parsers@ library.+----------------------------------------------------------------------------+module Text.Parser.Parsec () where++import Text.Parsec.Char+import Text.Parsec.Combinator+import Text.Parsec.Prim+import qualified Text.Parser.Char as P+import qualified Text.Parser.Combinators as P+import qualified Text.Parser.LookAhead as P+import qualified Text.Parser.Token as P+import Data.Char+import Control.Monad++instance (Stream s m t, Show t) => P.Parsing (ParsecT s u m) where+ try = try+ (<?>) = (<?>)+ skipMany = skipMany+ skipSome = skipMany1+ unexpected = unexpected+ eof = eof+ notFollowedBy = notFollowedBy++instance (Stream s m t, Show t) => P.LookAheadParsing (ParsecT s u m) where+ lookAhead = lookAhead++instance Stream s m Char => P.CharParsing (ParsecT s u m) where+ satisfy = satisfy+ char = char+ notChar c = satisfy (/= c)+ anyChar = anyChar+ string = string++instance Stream s m Char => P.TokenParsing (ParsecT s u m) where+ someSpace = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment)+ where+ simpleSpace = P.skipSome (satisfy isSpace)+ oneLineComment = char '#' >> void (manyTill anyChar newline)+ multiLineComment = try (string "/*") >> inComment+ inComment = void (try (string "*/"))+ <|> (P.skipSome (noneOf "*/") >> inComment)+ <|> (oneOf "*/" >> inComment)+
− bench/lexer.hs
@@ -1,4 +0,0 @@-module Main where--main :: IO ()-main = do print "cool"
language-puppet.cabal view
@@ -1,118 +1,145 @@--- language-puppet.cabal auto-generated by cabal init. For additional--- options, see--- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.--- The name of the package.-Name: language-puppet---- 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.4.2---- A short (one-line) description of the package.-Synopsis: Tools to parse and evaluate the Puppet DSL.---- A longer description of the package.-Description: This is a set of libraries designed to work with the Puppet DSL. It can be used to parse .pp files, compile and interpret them, evaluate the templates. It is still very experimental but is already pretty useful when working with the manifests.---- The license under which the package is released.-License: BSD3---- The file containing the license text.-License-file: LICENSE---- The package author(s).-Author: Simon Marechal---- An email address to which users can send suggestions, bug reports,--- and patches.-Maintainer: bartavelle@gmail.com--Homepage: http://lpuppet.banquise.net---- A copyright notice.--- Copyright: --Category: Language--Build-type: Simple---- Extra files to be distributed with the package, such as examples or--- a README.--- Extra-source-files: +-- Initial language-puppet.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ --- Constraint on the version of Cabal needed to build this package.-Cabal-version: >=1.8+name: language-puppet+version: 0.10.0+synopsis: Tools to parse and evaluate the Puppet DSL.+description: This is a set of tools that is supposed to fill all your Puppet needs : syntax checks, catalog compilation, PuppetDB queries, simulationg of complex interactions between nodes, Puppet master replacement, and more !+homepage: http://lpuppet.banquise.net/+license: BSD3+license-file: LICENSE+author: Simon Marechal+maintainer: bartavelle@gmail.com+-- copyright: +category: System+build-type: Simple+cabal-version: >=1.8 Data-Files: ruby/calcerb.rb ruby/hrubyerb.rb -Flag Hruby- Description: Using the hruby library to speed things up (if it is installed)- source-repository head type: git 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- -- 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, PuppetDB.TestDB - -- Packages needed in order to build this package.- 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, lens- -- 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.User- Puppet.NativeTypes.Mount, Puppet.Utils, Puppet.NativeTypes.Package, Puppet.NativeTypes.SshSecure, Puppet.Interpreter.RubyRandom+Flag Hruby+ Description: Using the hruby library to speed things up (if it is installed) +library+ exposed-modules: Puppet.Parser.Types+ , Puppet.Parser+ , Puppet.Interpreter.Types+ , Puppet.Parser.PrettyPrinter+ , Puppet.Interpreter.PrettyPrinter+ , Puppet.Preferences+ , Puppet.Daemon+ , Facter+ , Puppet.PP+ , Puppet.Stats+ , Puppet.NativeTypes+ , Puppet.NativeTypes.Helpers+ , Puppet.Interpreter+ , SafeProcess+ , Puppet.Stdlib+ , Puppet.Testing+ , PuppetDB.Remote+ , PuppetDB.TestDB+ , PuppetDB.Dummy+ , PuppetDB.Common+ other-modules: Text.Parser.Parsec+ , Puppet.Utils+ , Puppet.NativeTypes.File+ , Paths_language_puppet+ , Erb.Parser+ , Erb.Ruby+ , Erb.Evaluate+ , Erb.Compute+ , Puppet.Interpreter.Resolve+ , Puppet.Manifests+ , 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.Plugins+ , Puppet.Interpreter.RubyRandom+ extensions: OverloadedStrings, BangPatterns if flag(hruby) Build-depends: hruby CPP-Options: -DHRUBY - -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.- -- Build-tools: - Extensions: OverloadedStrings, BangPatterns- GHC-Prof-Options: -auto-all -caf-all- + ghc-options: -Wall -funbox-strict-fields+ ghc-prof-options: -auto-all -caf-all+ -- other-modules: + build-depends: base ==4.6.*+ , strict-base-types >= 0.2+ , hashable+ , unordered-containers+ , text+ , bytestring+ , vector+ , parsec+ , mtl+ , lens+ , parsers+ , ansi-wl-pprint+ , unix+ , aeson+ , luautils >= 0.1.1.0+ , hslua+ , transformers+ , hslogger+ , time+ , filecache+ , regex-pcre-builtin+ , pcre-utils+ , process+ , iconv+ , http-types+ , http-conduit+ , attoparsec+ , case-insensitive+ , cryptohash+ , base16-bytestring+ , containers+ , stm+ , hspec >=1.7.0 && <1.8.0+ , yaml >=0.8.0 && <0.9 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+ hs-source-dirs: tests+ type: exitcode-stdio-1.0+ ghc-options: -Wall -rtsopts -threaded+ extensions: OverloadedStrings+ build-depends: language-puppet,base,Glob,text,parsec,vector,ansi-wl-pprint,unix+ 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- extensions: OverloadedStrings- build-depends: language-puppet,base,Glob,mtl,containers,parsec,text- main-is: interpreter.hs----benchmark bench-lexer- hs-source-dirs: bench- type: exitcode-stdio-1.0- ghc-options: -Wall- build-depends: language-puppet,base- main-is: lexer.hs+ hs-source-dirs: tests+ type: exitcode-stdio-1.0+ ghc-options: -Wall -rtsopts -threaded+ extensions: OverloadedStrings+ build-depends: language-puppet,base,text,parsec,vector,ansi-wl-pprint+ main-is: expr.hs -source-repository head- type: git- location: git://github.com/bartavelle/language-puppet.git+executable puppetresources+ hs-source-dirs: progs+ extensions: BangPatterns, OverloadedStrings+ ghc-options: -Wall -rtsopts -threaded+ ghc-prof-options: -auto-all -caf-all -fprof-auto+ build-depends: language-puppet,base,text,parsec,vector,ansi-wl-pprint,bytestring,mtl,hslogger,Diff,unordered-containers,strict-base-types,optparse-applicative,regex-pcre-builtin,lens,aeson+ main-is: PuppetResources.hs +executable pdbquery+ hs-source-dirs: progs+ extensions: BangPatterns, OverloadedStrings+ ghc-options: -Wall -rtsopts -threaded+ ghc-prof-options: -auto-all -caf-all -fprof-auto+ build-depends: language-puppet,base,optparse-applicative,text,yaml,bytestring,strict-base-types,lens,unordered-containers,vector+ main-is: pdbQuery.hs
+ progs/PuppetResources.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE LambdaCase #-}+{-|++Horrible and hackish ... but damn useful. This can be used as a standalone+executable or a ghci script for interactive usage. It comes with a sample Puppet+site (that I hope will gets more realistic later).++When given a single argument, it will try to parse the given file, and will+print the parsed values :++> $ puppetresources samplesite/manifests/site.pp+> node test.nod {+> apt::builddep { Interpolable [Literal "glusterfs-server"]:+> ;+> }+> ...++With two arguments, it will try to compute the catalog for a given node. The+first argument must be the path to the Puppet directory and the second the+name of the node. Note that regexp node names do not work yet.++> $ puppetresources samplesite test.nod+> The defined() function is not implemented for resource references. Returning true at "samplesite/modules/apt/manifests/ppa.pp" (line 20, column 3)+> The defined() function is not implemented for resource references. Returning true at "samplesite/modules/apt/manifests/key.pp" (line 38, column 7)+> The defined() function is not implemented for resource references. Returning true at "samplesite/modules/apt/manifests/key.pp" (line 42, column 7)+> anchor {+> "apt::builddep::glusterfs-server": #"samplesite/modules/apt/manifests/builddep.pp" (line 12, column 12)+> name => "apt::builddep::glusterfs-server";+> "apt::key/Add key: 55BE302B from Apt::Source debian_unstable": #"samplesite/modules/apt/manifests/key.pp" (line 32, column 16)+> name => "apt::key/Add key: 55BE302B from Apt::Source debian_unstable";+> ...++When adding a file name as the third argument to the previous invocation, it+will display the value of the /content/ attribute of the named /file/ resource.++> $ puppetresources samplesite test.nod karmic.pref+> The defined() function is not implemented for resource references. Returning true at "samplesite/modules/apt/manifests/ppa.pp" (line 20, column 3)+> The defined() function is not implemented for resource references. Returning true at "samplesite/modules/apt/manifests/key.pp" (line 38, column 7)+> The defined() function is not implemented for resource references. Returning true at "samplesite/modules/apt/manifests/key.pp" (line 42, column 7)+> # karmic+> Package: *+> Pin: release a=karmic+> Pin-Priority: 700++You can also just use a resource name :++> $ puppetresources samplesite test.nod 'exec[apt_update]'+> exec {+> "apt_update": #"samplesite/modules/apt/manifests/update.pp" (line 4, column 10)+> command => "/usr/bin/apt-get update",+> logoutput => "false",+> refreshonly => "true",+> returns => 0,+> timeout => 300,+> tries => 1,+> try_sleep => 0;+> }++With GHCI there are tons of things you can do. First initialize it++>>> queryfunc <- initializedaemon "./samplesite/"++You can now compute catalogs for various nodes.++>>> c1 <- queryfunc "test.nod"+The defined() function is not implemented for resource references. Returning true at "./samplesite//modules/apt/manifests/ppa.pp" (line 20, column 3)+The defined() function is not implemented for resource references. Returning true at "./samplesite//modules/apt/manifests/key.pp" (line 38, column 7)+The defined() function is not implemented for resource references. Returning true at "./samplesite//modules/apt/manifests/key.pp" (line 42, column 7)+>>> c2 <- queryfunc "test2.nod"+The defined() function is not implemented for resource references. Returning true at "./samplesite//modules/apt/manifests/ppa.pp" (line 20, column 3)+The defined() function is not implemented for resource references. Returning true at "./samplesite//modules/apt/manifests/key.pp" (line 38, column 7)+The defined() function is not implemented for resource references. Returning true at "./samplesite//modules/apt/manifests/key.pp" (line 42, column 7)++And you can check what the difference is between catalogs.++>>> diff c1 c2+file[karmic-updates.pref] {+# content+ + Pin-Priority: 750+ - Pin-Priority: 700+}++You also can manipulate catalogs.++>>> Map.size c1+25+>>> mapM_ print $ Map.toList $ Map.map (length . lines . (\x -> case x of (PString n) -> n) .fromJust . Map.lookup "content" . rrattributes) $ Map.filter (Map.member "content" . rrattributes) c1+(("file","debian_unstable.list"),3)+(("file","debian_unstable.pref"),4)+(("file","karmic-security.pref"),4)+(("file","karmic-updates.pref"),4)+(("file","karmic.pref"),4)++A typical usage of this tool is to compute a reference catalog, and then check the differences as you alter it. This can be done this way :++>>> reference <- queryfunc "test.nod"++And then run the following command every time you need to verify your changes are correct :++>>> queryfunc "test.nod" >>= diff reference++-}+module Main where++import System.IO+import qualified Data.HashMap.Strict as HM+import qualified System.Log.Logger as LOG+import qualified Data.ByteString.Lazy.Char8 as BSL+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Monoid hiding (First)+import qualified Text.Parsec as P+import qualified Data.Vector as V+import qualified Data.Either.Strict as S+import Options.Applicative as O+import Control.Monad+import Text.Regex.PCRE.String+import Data.Text.Strict.Lens+-- import Data.Aeson++import Facter++import Puppet.PP hiding ((<$>))+import Puppet.Preferences+import Puppet.Daemon+import Puppet.Interpreter.Types+import Puppet.Parser.Types+import Puppet.Parser+import Puppet.Parser.PrettyPrinter()+import Puppet.Interpreter.PrettyPrinter()+import PuppetDB.Remote+import PuppetDB.Dummy+import PuppetDB.TestDB+import PuppetDB.Common+import Puppet.Testing hiding ((<$>))++tshow :: Show a => a -> T.Text+tshow = T.pack . show++{-| Does all the work of initializing a daemon for querying.+Returns the final catalog when given a node name. Note that this is pretty+hackish as it will generate facts from the local computer !+-}++initializedaemonWithPuppet :: LOG.Priority -> PuppetDBAPI -> FilePath -> IO (T.Text -> IO (FinalCatalog, EdgeMap, FinalCatalog))+initializedaemonWithPuppet prio pdbapi puppetdir = do+ LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel prio)+ q <- fmap (prefPDB .~ pdbapi) (genPreferences puppetdir) >>= initDaemon+ let f ndename = puppetDBFacts ndename pdbapi+ >>= _dGetCatalog q ndename+ >>= \case+ S.Left rr -> putDoc rr >> putStrLn "" >> error "error!"+ S.Right x -> return x+ return f++parseFile :: FilePath -> IO (Either P.ParseError (V.Vector Statement))+parseFile fp = T.readFile fp >>= P.runParserT puppetParser () fp++printContent :: T.Text -> FinalCatalog -> IO ()+printContent filename catalog =+ case HM.lookup (RIdentifier "file" filename) catalog of+ Nothing -> error "File not found"+ Just r -> case HM.lookup "content" (_rattributes r) of+ Nothing -> error "This file has no content"+ Just (PString c) -> T.putStrLn c+ Just x -> print x++data CommandLine = CommandLine { _pdb :: Maybe String+ , _showjson :: Bool+ , _showContent :: Bool+ , _resourceType :: Maybe T.Text+ , _resourceName :: Maybe T.Text+ , _puppetdir :: FilePath+ , _nodename :: Maybe String+ , _pdbfile :: Maybe FilePath+ , _loglevel :: LOG.Priority+ } deriving Show++cmdlineParser :: Parser CommandLine+cmdlineParser = CommandLine <$> optional remotepdb <*> sj <*> sc <*> optional (T.pack <$> rt) <*> optional (T.pack <$> rn) <*> pdir <*> optional nn <*> optional pdbfile <*> priority+ where+ sc = switch ( long "showcontent"+ <> short 'c'+ <> help "When specifying a file resource, only output its content (useful for testing templates)")+ sj = switch ( long "JSON"+ <> short 'j'+ <> help "Shows the output as a JSON document (useful for full catalog views)")+ remotepdb = strOption ( long "pdburl"+ <> help "URL of the puppetdb (ie. http://localhost:8080/).")+ rt = strOption ( long "type"+ <> short 't'+ <> help "Filter the output by resource type (accepts a regular expression, ie '^file$')")+ rn = strOption ( long "name"+ <> short 'n'+ <> help "Filter the output by resource name (accepts a regular expression)")+ pdir = strOption ( long "puppetdir"+ <> short 'p'+ <> help "Puppet directory")+ nn = strOption ( long "node"+ <> short 'o'+ <> help "Node name")+ pdbfile = strOption ( long "pdbfile"+ <> help "Path to the testing PuppetDB file.")+ priority = option ( long "loglevel"+ <> short 'v'+ <> help "Values are : DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY"+ <> value LOG.WARNING+ )+run :: CommandLine -> IO ()+run (CommandLine _ _ _ _ _ f Nothing _ _) = parseFile f >>= \case+ Left rr -> error ("parse error:" ++ show rr)+ Right s -> putDoc (vcat (map pretty (V.toList s)))+run (CommandLine puppeturl showjson showcontent mrt mrn puppetdir (Just ndename) mpdbf prio) = do+ let checkError r (S.Left rr) = error (show (red r <> ":" <+> rr))+ checkError _ (S.Right x) = return x+ tnodename = T.pack ndename+ pdbapi <- case (puppeturl, mpdbf) of+ (Nothing, Nothing) -> return dummyPuppetDB+ (Just _, Just _) -> error "You must choose between a testing PuppetDB and a remote one"+ (Just url, _) -> pdbConnect (T.pack url) >>= checkError "Error when connecting to the remote PuppetDB"+ (_, Just file) -> loadTestDB file >>= checkError "Error when initializing the PuppetDB API"+ queryfunc <- initializedaemonWithPuppet prio pdbapi puppetdir+ printFunc <- hIsTerminalDevice stdout >>= \isterm -> return $ \x ->+ if isterm+ then putDoc x >> putStrLn ""+ else displayIO stdout (renderCompact x) >> putStrLn ""+ (rawcatalog,m,rawexported) <- queryfunc tnodename+ void $ replaceCatalog pdbapi (generateWireCatalog tnodename (rawcatalog <> rawexported) m)+ void $ commitDB pdbapi+ let cmpMatch Nothing _ curcat = return curcat+ cmpMatch (Just rg) lns curcat = compile compBlank execBlank (T.unpack rg) >>= \case+ Left rr -> error ("Error compiling regexp 're': " ++ show rr)+ Right rec -> fmap HM.fromList $ filterM (filterResource lns rec) (HM.toList curcat)+ filterResource lns rec v = execute rec (v ^. lns) >>= \case+ Left rr -> error ("Error when applying regexp: " ++ show rr)+ Right Nothing -> return False+ _ -> return True+ filterCatalog = cmpMatch mrt (_1 . itype . unpacked) >=> cmpMatch mrn (_1 . iname . unpacked)+ catalog <- filterCatalog rawcatalog+ exported <- filterCatalog rawexported+ case (showcontent, showjson) of+ (_, True) -> BSL.putStrLn ("TODO JSON MODE")+ (True, _) -> do+ unless (mrt == Just "file" || mrt == Nothing) (error $ "Show content only works for file, not for " ++ show mrt)+ case mrn of+ Just f -> printContent f catalog+ Nothing -> error "You should supply a resource name when using showcontent"+ _ -> do+ void $ testCatalog tnodename puppetdir rawcatalog basicTest+ printFunc (pretty (HM.elems catalog))+ unless (HM.null exported) $ do+ printFunc (mempty <+> dullyellow "Exported:" <+> mempty)+ printFunc (pretty (HM.elems exported))++main :: IO ()+main = execParser pinfo >>= run+ where+ pinfo :: ParserInfo CommandLine+ pinfo = ParserInfo (helper <*> cmdlineParser) True "A useful program for parsing puppet files, generating and inspecting catalogs" "puppetresources - a useful utility for dealing with Puppet" "" 3
+ progs/pdbQuery.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE LambdaCase #-}+module Main where++import Puppet.Interpreter.Types+import PuppetDB.Common+import PuppetDB.TestDB+import PuppetDB.Remote++import Options.Applicative as O+import qualified Data.Text as T+import Data.Monoid+import Data.Yaml hiding (Parser)+import qualified Data.ByteString.Char8 as BS+import qualified Data.Either.Strict as S+import Control.Lens+import qualified Data.HashMap.Strict as HM+import Control.Monad (forM_)+import qualified Data.Vector as V++data CommandLine = CommandLine { _pdbloc :: Maybe FilePath+ , _pdbtype :: PDBType+ , _pdbcmd :: Command+ }++data Command = DumpFacts+ | DumpNodes+ | EditFact T.Text T.Text+ | DeactivateNode T.Text+ | DumpResources T.Text+ | CreateTestDB FilePath++factedit :: Parser Command+factedit = EditFact <$> O.argument (Just . T.pack) mempty <*> O.argument (Just . T.pack) mempty++resourcesparser :: Parser Command+resourcesparser = DumpResources <$> O.argument (Just . T.pack) mempty++delnodeparser :: Parser Command+delnodeparser = DeactivateNode <$> O.argument (Just . T.pack) mempty++createtestdb :: Parser Command+createtestdb = CreateTestDB <$> O.argument Just mempty++cmdlineParser :: Parser CommandLine+cmdlineParser = CommandLine <$> optional pl <*> pt <*> cmd+ where+ pl = strOption ( long "location"+ <> short 'l'+ <> help "Location of the PuppetDB, a file for type 'test' or an URL for type 'remote'"+ )+ pt = option ( long "pdbtype"+ <> short 't'+ <> value PDBTest+ <> help "PuppetDB types : test, remote, dummy"+ )+ cmd = subparser ( command "dumpfacts" (ParserInfo (pure DumpFacts) True "Dump all facts" "Dump all facts" "" 4)+ <> command "editfact" (ParserInfo factedit True "Edit a fact corresponding to a node" "" "" 7)+ <> command "dumpres" (ParserInfo resourcesparser True "Dump resources" "Dump resources" "" 5)+ <> command "delnode" (ParserInfo delnodeparser True "Deactivate node" "Deactivate node" "" 6)+ <> command "nodes" (ParserInfo (pure DumpNodes) True "Dump all nodes" "Dump all nodes" "" 8)+ <> command "snapshot" (ParserInfo createtestdb True "Create a test DB from the current DB" "" "" 10)+ )++display :: (Show r, ToJSON a) => String -> S.Either r a -> IO ()+display s (S.Left rr) = error (s <> " " <> show rr)+display _ (S.Right a) = BS.putStrLn (encode a)++run :: CommandLine -> IO ()+run cmdl = do+ epdbapi <- case (_pdbloc cmdl, _pdbtype cmdl) of+ (Just l, PDBRemote) -> pdbConnect (T.pack l)+ (Just l, PDBTest) -> loadTestDB l+ (_, x) -> getDefaultDB x+ pdbapi <- case epdbapi of+ S.Left r -> error (show r)+ S.Right x -> return x+ case _pdbcmd cmdl of+ DumpFacts -> getFacts pdbapi QEmpty >>= display "get facts"+ DumpNodes -> getNodes pdbapi QEmpty >>= display "dump nodes"+ CreateTestDB destfile -> do+ let getOrError s (S.Left rr) = error (s <> " " <> show rr)+ getOrError _ (S.Right x) = return x+ ndb <- loadTestDB destfile >>= getOrError "puppetdb load"+ allnodes <- getNodes pdbapi QEmpty >>= getOrError "get nodes"+ allfacts <- getFacts pdbapi QEmpty >>= getOrError "get facts"+ let factsGrouped = HM.toList $ HM.fromListWith (<>) $ map (\x -> (x ^. nodename, HM.singleton (x ^. factname) (x ^. factval))) allfacts+ replaceFacts ndb factsGrouped >>= getOrError "replace facts"+ forM_ allnodes $ \pnodename -> do+ let ndename = pnodename ^. nodename+ res <- getResourcesOfNode pdbapi ndename QEmpty >>= getOrError ("get resources for " ++ show ndename)+ let wirecatalog = WireCatalog ndename "version" V.empty (V.fromList res) ndename+ replaceCatalog ndb wirecatalog+ commitDB ndb >>= getOrError "commit db"+ _ -> error "Not yet implemented"++main :: IO ()+main = execParser pinfo >>= run+ where+ pinfo :: ParserInfo CommandLine+ pinfo = ParserInfo (helper <*> cmdlineParser) True "A program to work with PuppetDB implementations" "pdbQuery - work with PuppetDB implementations" "" 3
ruby/hrubyerb.rb view
@@ -7,20 +7,24 @@ @variables = variables end - def lookupvar(name)+ def vl(name) if name.start_with?("::") name = name[2..-1] end- x = varlookup(@context,@variables,name)+ varlookup(@context,@variables,name)+ end++ def lookupvar(name)+ x = vl(name) if x == :undef- throw("Unknown variable " + name + " error: " + x.to_s)+ throw("Unknown variable " + name) else x end end def has_variable?(name)- x = varlookup(@context,@variables,name)+ x = vl(name) if x == :undef false else
− test/expr.hs
@@ -1,22 +0,0 @@-module Main where--import Puppet.DSL.Parser-import Puppet.DSL.Types-import Text.Parsec--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) )- ]--main :: IO ()-main = do- let testres = map (\(t,v) -> (runParser exprparser () "test" t, v)) testcases- badstuff = filter (\(Right r,t) -> r /= t) testres- if (null badstuff)- then return ()- else do- print badstuff- error "fail"--
− test/interpreter.hs
@@ -1,58 +0,0 @@-module Main where--import System.FilePath.Glob-import Control.Monad.Error-import Puppet.DSL.Loader-import Puppet.DSL.Types-import Puppet.Interpreter.Catalog-import Puppet.Interpreter.Types-import Puppet.NativeTypes-import qualified Data.Map as Map-import Data.Either-import Data.List-import Text.Parsec.Pos-import qualified Data.Text as T--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 :: 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- filelist <- globDir [compile "*.pp"] "test/interpreter" >>= return . head . fst- testres <- mapM testinterpreter filelist- let testsrs = map fst testres- isgood = and $ map snd testres- outlist = zip [1..(length testres)] testsrs- mapM_ (\(n,t) -> putStrLn $ show n ++ " " ++ t) outlist- if (isgood)- 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"), ("::fqdn", ResolvedString "fqdn")]- toplevels = map convertTopLevel p- oktoplevels = rights toplevels- othertoplevels = lefts toplevels- topclass = ClassDeclaration "::" Nothing [] othertoplevels (initialPos fp)- 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)- (Left x, y) -> error x-
− test/lexer.hs
@@ -1,26 +0,0 @@-module Main where--import System.FilePath.Glob-import Control.Monad.Error-import Puppet.DSL.Loader--main :: IO ()-main = do- filelist <- globDir [compile "*.pp"] "test/lexer" >>= return . head . fst- testres <- mapM testparser filelist- let testsrs = map fst testres- isgood = and $ map snd testres- outlist = zip [1..(length testres)] testsrs- mapM_ (\(n,t) -> putStrLn $ show n ++ " " ++ t) outlist- if (isgood)- then return ()- else error "fail"---- returns errors-testparser :: FilePath -> IO (String, Bool)-testparser fp = do- parsed <- runErrorT (parseFile fp)- case parsed of- Right _ -> return ("PASS", True)- Left err -> return (err, False)-
+ tests/expr.hs view
@@ -0,0 +1,34 @@+module Main where++import Text.PrettyPrint.ANSI.Leijen++import Puppet.Parser+import Puppet.Parser.PrettyPrinter()+import Puppet.Parser.Types+import Text.Parsec+import Control.Monad+import Data.Maybe+import qualified Data.Text as T+import Control.Applicative+import qualified Data.Vector as V++testcases :: [(T.Text, Expression)]+testcases =+ [ ("5 + 3 * 2", Addition (PValue $ UString "5") (Multiplication (PValue $ UString "3") (PValue $ UString "2")) )+ , ("5+2 == 7", Equal ( Addition (PValue $ UString "5") (PValue $ UString "2") ) (PValue $ UString "7") )+ , ("include foo::bar", PValue (UFunctionCall "include" (V.fromList [PValue (UString "foo::bar")])) )+ ]++main :: IO ()+main = do+ testres <- forM testcases $ \(a,b) -> do+ na <- runParserT (expression <* eof ) () "tests" a+ return (na, b)+ let isFailure (Left x, _) = Just (show x)+ isFailure (Right x, e) = if x == e+ then Nothing+ else Just (displayS (renderPretty 0.4 80 (pretty x)) "" ++ "\n" ++ displayS (renderPretty 0.4 80 (pretty e)) "")+ bads = mapMaybe isFailure testres+ unless (null bads) $ do+ mapM_ putStrLn bads+ error "failed"
+ tests/lexer.hs view
@@ -0,0 +1,53 @@+module Main where++import Control.Monad+import System.FilePath.Glob+import Puppet.Parser+import Text.Parsec+import System.Environment+import Puppet.Parser.PrettyPrinter+import Text.PrettyPrint.ANSI.Leijen+import System.Posix.Terminal+import System.Posix.Types+import System.IO+import qualified Data.Text.IO as T++allchecks :: IO ()+allchecks = do+ filelist <- fmap (head . fst) (globDir [compile "*.pp"] "tests/lexer")+ testres <- mapM testparser filelist+ let testsrs = map fst testres+ isgood = all snd testres+ outlist = zip [1..(length testres)] testsrs+ mapM_ (\(n,t) -> putStrLn $ show n ++ " " ++ t) outlist+ unless isgood (error "fail")++-- returns errors+testparser :: FilePath -> IO (String, Bool)+testparser fp = do+ T.readFile fp >>= runParserT puppetParser () fp >>= \case+ Right _ -> return ("PASS", True)+ Left rr -> return (show rr, False)++check :: String -> IO ()+check fname = do+ putStr fname+ putStr ": "+ res <- T.readFile fname >>= runParserT puppetParser () fname+ is <- queryTerminal (Fd 1)+ let rfunc = if is+ then renderPretty 0.2 200+ else renderCompact+ case res of+ Left rr -> print rr+ Right x -> do+ putStrLn ""+ displayIO stdout (rfunc (pretty (ppStatements x)))+ putStrLn ""++main :: IO ()+main = do+ args <- getArgs+ if null args+ then allchecks+ else mapM_ check args