diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -0,0 +1,331 @@ +# v1.0.1 (2014/11/13) +## New features +* Support for the `join` function. +* Support for filtering json puppetresources output (fix issue #64) +* Support for `cmpversion` in the templates. +* The various chaining modes have been implemented. +* Support for the `is_bool` function (Pierre Radermecker) +* Support for `concat` and `concat::fragment` (Pierre Radermecker) + +## Bugs fixed +* Fix array value extrapolation in string (issue #35) +* ${var} without quotes will now be rejected by the parser (issue #78) + +## Various +* `README` moved to asciidoc (Pierre Radermecker) + +# v1.0.0 (2014/08/31) +## IMPORTANT +Building without hruby is now unsupported. +## New features +* Support for Debian distribution detection in facter. +* Support for the "~>" operator. +* Support for mixed-case resource references. +* Added the `grep` function. +## Bugs fixed +* Better support for --ignoremodules. +* Fixed parsing of standalone `$` characters in strings. + +# v0.14.0 (2014/06/12) +## New features +* Overhauled the dependency check system +* Added an option to skip the user and group checks +* Added an option to ignore some modules +## Bugs fixed +* Added `vagrant`, `nagios`, `www-data`, `postgres` and `nginx` to the list of known users. +* Fixed how resource relationships were resolved with notify and before. +* Fixed a problem where inheritance whould be used with `::` prefix. +* The `defined` function now works with classes. +* All numbers are now strings in templates. + +# v0.13.0 (2014/05/21) +## New features +* Hacky support for `scope.get_hash`. +* New stuff from the new parser (adding hashes, arrays, etc.). +* Wrote a pure evaluation function, for unit tests and prisms. +* `Num` and `Fractional` instances for `Expression`. +* Numbers are now internally stored as numbers, just like the new parser does. +* Add support for "structured facts". +* New stdlib functions: `is_hash`, `has_key`, `size`, `values`. +## Bugs fixed +* Puppetresources does not fail tests for file sources starting with `file://`. +* Escaped characters were not properly handled in the parser. +* Properly catch division by 0 (!!!!). +* Got rid of the orphan instances ... code is now a lot uglier. +* Fixed settings of "title" and "name" in classes. The original puppet version + only seems to do this when we declare in define style :( +* Fixed associativity priority between `=~` and `and`. + +# v0.12.3 (2014/03/13) +## New featues +* puppetresources now tests that groups and users are defined before being used + in file, user, cron and exec. + +# v0.12.2 (2014/02/18) +## New featues +* Facts are now dumped in `TestDB` format by `pdbquery`. +* The `puppetresources` command now has switch controlling the PuppetDB commit and "catalog update". + +# v0.12.1 (2014/02/10) +## New featues +* *Dead code* finder in puppetresources. +* CPU related facts. +* `puppetresources` now exits with the proper error code. +* `puppetresources` can now display some statistics about compilation times. +* Bumped the version of the http-conduit dependency. +## Bugs fixed +* Fixed dependencies so that builds with GHC 7.8-rc1 work. + +# v0.12.0 (2014/02/07) +## New featues +* Builds against GHC 7.8-rc1. + +# v0.11.1 (2014/01/31) +## Bugs fixed +* Fixed build issues with strict-base-types version. + +# v0.11.0 (2014/01/30) +## New features +* Removal of the dedicated parsing threads. +* Better default RTS options (for now, just the default allocation size) +* Upgraded dependencies : aeson 0.7, attoparsec 0.11, lens 4, parsers + 0.10, text 1.1, filecache 0.3, hruby 0.2 + +# v0.10.6 (2014/01/25) +## New features +* New all nodes testing for puppetresources. +* Added some uname related facts. +* Added some lenses and prisms. +## Bugs fixed +* Parsing function calls without parens at the expression level is not + allowed now. +* Allow parsing of boolean facts from YAML files. +* Allow resource references with array variables. +* Fix spurious multiple includes error. +* Fixed the implementation of some puppet functions. + +# v0.10.5 (2014/01/06) +## Bugs fixed +* Lambda blocks can now end with a bare function call +* Fix version bounds with hslua and luautils + +# v0.10.4 (2013/12/18) +## New features +* Moved to the latest hruby version. +* Updated the text bound + +# v0.10.3 (2013/12/03) +## New features +* The scope tracking system has been improved. It is now possible to know + the original host of an imported resource, which helps a lot in case of + resource clashes +* is_virtual fact +* new stdlib functions: flatten, str2bool, validate_absolute_path +* Hiera support +* JSON output that is compatible with "puppet apply" +* New addfacts command for the pdbquery utility +* Support for the classes variable in templates +* Support for @instance variables in inline_template +* Support for scope['key'] syntax in templates +* Support for facts overriding with puppetresources +## Bugs fixed +* Deserialization problems with puppetDBs +* Fixed several bugs with imported resources +* Bug with relationships overrides that got stored as parameters +* Importing several exported resources from the same class now works +* Templates with an invalid encoding could crash the process +* Yaml parse errors of the puppetdb file now throw errors + +# v0.10.2 (2013/10/27) +## Bugs fixed +* PVP support +## New features +* Support for properly setting instance variables before computing + templates with native Ruby. + +# v0.10.1 (2013/10/27) +## Bugs fixed +* The TestDB file was never created. + +# v0.10.0 (2013/10/27) +## New features +* Map/each/filter functions with lambdas (not really tested) +* Rewrite of the PuppetDB API +* The whole scope stack is kept with each Resource, for easier debugging +* Inclusion of three PuppetDB backends : dummy (no effect), TestDB (stored + in a YAML file) and Remote (standard PuppetDB API) +## Bugs fixed +* This is a hack : variables declared in a parent (inheritance) can now be + overriden. This is because inheritance is not handled like in Vanilla. As + I do not really use inheritance, I am not sure if this is much of a + breakage. + +# v0.9.0 (2013/08/15) + Huge rewrite ! +* See http://lpuppet.banquise.net/blog/2013/08/15/version-0-dot-9-0-is-out-for-testing/ + +# v0.4.2 (2013/06/01) +## New features +* Functions 'values' and 'keys' from stdlib are now implemented. +* hruby integration +## Bugs fixed + +# v0.4.0 (2013/05/16) +## New features +* Big refactor of the PuppetDB API. +* New "fake" PuppetDB used for testing +* Support of the caller_module_name variable. +* Support for a dumpvariable() function. +* More details stored in the resource types, and in error messages. +* User native type +* Removal of the MissingH, filepath, monad-loop and directory dependency +* Puppet booleans are now handled at parse stage +* inline_template function +## Bugs fixed +* fqdn_rand now puppet perfect (at least for 32 bit max values) +* Now depends on the built-in bytestring library that comes with + GHC-7.6.1. +* Aliases should now work as expected ... I wish! +* regexp_subs now works in a PCRE manner +* Destination dependency can now be a variable resolving in an array. + +# v0.3.3 (2013/01/21) +## New features +* Tries to find calcerb.rb next to the executable. +* Started cleaning imports ... +* It is now possible to write "top level" functions in lua. +* Function getvar (stdlib) +* TENTATIVE support for aliases. +* Checks that file names don't have trailing slashes. +* Checks that exec commands are fully qualified if path is not defined. +* New native type : package. +## Bugs fixed +* Fixed a ton of problems related to exported resources and relations. +* Minor fix about zonerecord. +* Resolving variable names starting with :: in templates +* Fixed the file function. + +# v0.3.2 (2012/12/13) + The license has been changed to BSD3. +## Bugs fixed +* It is now possible to use expressions in include blocks. This is + temporary, as include should be handled just like every other function. + +# v0.3.1 (2012/11/23) +## New features +* Yes, we can generate JSon catalogs now. +## Bugs fixed +* Several bugs about resource relationships. + +# v0.3.0 (2012/11/19) +## New features +* Resource relationships are somehow supported. The API is broken as a + result. +* Exported resources are now returned. + +# v0.2.2 (2012/11/12) +## New features +* A few statistics are exported. + +# v0.2.1 (2012/11/12) +## Bugs fixed +* The defaults system was pretty much broken, it should be better now. +## New features +* Basic testing framework started. +* create_resources now supports the defaults system. +* defined() function works for resource references. +* in operator implemented for hashes. +* Multithreading works. +* The ruby <> daemon communication is now over ByteStrings. +* The toRuby function has been optimized, doubling the overall speed for + rendering complex catalogs. +* Various internal changes. + +# v0.2.0 (2012/10/08) +## New features +* Lua integration for custom functions. +* Automatically creates magic types based on the content of the modules. +## Bugs fixed +* Defaults parameters can now end with a comma. + +# v0.1.8.0 (2012/09/20) +## New features +* Refactoring of the PuppetDB API for interfacing with the facter library. +* Support of exported resource resolution through PuppetDB ! This results + in an API breakage. +* Make binary distribution possible (ruby helper path). +## Bugs fixed +* Defines with spurious parameters, or unset mandatory parameters, should + now be catched. +* Exception handling for the HTTP failures. +* Handles undefined variables in Ruby templates. +* Undefined variables in Erbs now always throw exceptions. This is + stricter than Puppet (which throws exceptions for "native" variables), but + is I believe good practice. + +# v0.1.7.2 (2012/09/17) +## New features +* Preliminary support for PuppetDB + +# v0.1.7.1 (2012/09/14) +## Bugs fixed +* Various details have been modified since the official language + documentation has been published. +* Better handling of collector conditions. +* Solves bug with interpolable strings that are not resolved when first + found. +## New features +* Amending attributes with a collector. +* Stdlib functions : chomp +* Resource pretty printer now aligns =>. +* Case statements with regexps. + +# v0.1.7 (2012/08/24) +## Bugs fixed +* Fix bug with '<' in the Erb parser ! +* Assignments can now be any valid Puppet expression. +* Proper list of metaparameters. +## New features +* Quick resolution of boolean conditions. +* Start of the move to a real PCRE library. +* Function is_domain_name. +* New native types : zone_record, cron, exec, group, host, mount, file. + +# v0.1.6 (2012/08/01) +## New features +* Errors now print a stack trace (only works with profiling builds). +* Nested classes. +* generate() function. +* defines with spurious top level statements now should work. +* validate_* functions from puppetlabs/stdlib. +## Bugs fixed +* Metaparameters now include stages (not handled). +* Resolving non empty arrays as boolean returns true. +* Duplicate parameters are now detected. + +# v0.1.5 (2012/07/06) +## Bugs fixed +* Detection of spurious parameters when declaring parametrized classes now + works. +* Resource overrides with non trivial names should now work. +* Require statements in required files would not be loaded. + +# v0.1.4 (2012/07/02) +## New features +* Basic native template function. +* Added anchor as a native type for now. A better fix will be to just parse + for defined types in the lib directory of modules. +* Tentative defined() implementation. Will not work for resource references. +* Functions md5, sha1, lowcase, upcase, split. +## Bugs fixed +* String comparison is not case insensitive. +* Variable scope for inherited classes should now work. +* Support for the $module_name variable (probably a bit buggy). +* Proper location of a "define not found" error. +* Parsing bug for single quoted strings and slashes. +* Bug where a resource name is a variable that is actually an array. +* Array indexing. +* Top level variables are now supported in Erb. +## Various +* Removed the title parameter from the catalog printing functions. +* Used hslint a bit. diff --git a/Hiera/Server.hs b/Hiera/Server.hs --- a/Hiera/Server.hs +++ b/Hiera/Server.hs @@ -1,44 +1,49 @@ -{-# LANGUAGE LambdaCase, TemplateHaskell, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} +{-# LANGUAGE LambdaCase, TemplateHaskell, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, NamedFieldPuns #-} + {- | This module runs a Hiera server that caches Hiera data. There is a huge caveat : only the data files are watched for changes, not the main configuration file. A minor bug is that interpolation will not work for inputs containing the % character when it isn't used for interpolation. -} -module Hiera.Server (startHiera,dummyHiera,HieraQueryFunc) where +module Hiera.Server ( + startHiera + , dummyHiera + -- re-export from Puppet.Interpreter.Types + , HieraQueryFunc +) where -import qualified Data.FileCache as F -import qualified Data.Yaml as Y +import Control.Applicative +import Control.Exception +import Control.Lens +import Control.Monad.Writer.Strict +import Data.Aeson (FromJSON,Value(..),(.:?),(.!=)) import qualified Data.Aeson as A -import Data.Aeson (FromJSON,Value(..),(.:?),(.!=)) +import Data.Aeson.Lens +import qualified Data.Attoparsec.Text as AT +import qualified Data.ByteString.Lazy as BS import qualified Data.Either.Strict as S +import qualified Data.FileCache as F +import qualified Data.HashMap.Strict as HM +import qualified Data.List as L import qualified Data.Maybe.Strict as S import qualified Data.Text as T -import qualified Data.Attoparsec.Text as AT -import qualified Data.ByteString.Lazy as BS +import Data.Tuple.Strict import qualified Data.Vector as V -import qualified Data.List as L -import qualified Data.HashMap.Strict as HM -import Data.Tuple.Strict -import Control.Monad.Writer.Strict - -import Control.Applicative -import Control.Lens -import Data.Aeson.Lens -import System.FilePath.Lens (directory) -import Control.Exception +import qualified Data.Yaml as Y +import System.FilePath.Lens (directory) -import Puppet.PP hiding ((<$>)) -import Puppet.Interpreter.Types -import Puppet.Utils (strictifyEither) +import Puppet.PP hiding ((<$>)) +import Puppet.Interpreter.Types +import Puppet.Utils (strictifyEither) -data HieraConfig = HieraConfig { _hieraconfigBackends :: [HieraBackend] - , _hieraconfigHierarchy :: [InterpolableHieraString] - , _hieraconfigBasedir :: FilePath - } deriving Show +data ConfigFile = ConfigFile + { _backends :: [Backend] + , _hierarchy :: [InterpolableHieraString] + } deriving (Show) -data HieraBackend = YamlBackend FilePath - | JsonBackend FilePath - deriving Show +data Backend = YamlBackend FilePath + | JsonBackend FilePath + deriving Show newtype InterpolableHieraString = InterpolableHieraString [HieraStringPart] deriving Show @@ -52,9 +57,9 @@ pretty (HVariable v) = dullred (string "%{" <> ttext v <> string "}") prettyList = mconcat . map pretty -type HieraCache = F.FileCacheR String Y.Value +type Cache = F.FileCacheR String Y.Value -makeFields ''HieraConfig +makeClassy ''ConfigFile instance FromJSON InterpolableHieraString where parseJSON (String s) = case parseInterpolableString s of @@ -62,27 +67,25 @@ Left rr -> fail rr parseJSON _ = fail "Invalid value type" -instance FromJSON HieraConfig where +instance FromJSON ConfigFile where parseJSON (Object v) = do - let genBackend :: T.Text -> Y.Parser HieraBackend - genBackend backendname = do - (backendConstructor, skey) <- case backendname of + let genBackend :: T.Text -> Y.Parser Backend + genBackend name = do + (backendConstructor, skey) <- case name of "yaml" -> return (YamlBackend, ":yaml") "json" -> return (JsonBackend, ":json") - _ -> fail ("Unknown backend " ++ T.unpack backendname) + _ -> fail ("Unknown backend " ++ T.unpack name) datadir <- case (Object v) ^? key skey . key ":datadir" of - Just (String dtdir) -> return dtdir + Just (String dir) -> return dir Just _ -> fail ":datadir should be a string" Nothing -> return "/etc/puppet/hieradata" return (backendConstructor (T.unpack datadir)) - HieraConfig + ConfigFile <$> (v .:? ":backends" .!= ["yaml"] >>= mapM genBackend) <*> (v .:? ":hierarchy" .!= [InterpolableHieraString [HString "common"]]) - <*> pure "/etc/puppet/hieradata" parseJSON _ = fail "Not a valid Hiera configuration" --- | An attoparsec parser that turns text into parts that are ready for --- interpolation +-- | An attoparsec parser that turns text into parts that are ready for interpolation interpolableString :: AT.Parser [HieraStringPart] interpolableString = AT.many1 (fmap HString rawPart <|> fmap HVariable interpPart) where @@ -96,16 +99,15 @@ -- a querying function. The 'Nil' output is explicitely given as a Maybe -- type. startHiera :: FilePath -> IO (Either String (HieraQueryFunc IO)) -startHiera hieraconfig = Y.decodeFileEither hieraconfig >>= \case - Left ex -> return (Left (show ex)) +startHiera fp = Y.decodeFileEither fp >>= \case + Left ex -> return (Left (show ex)) Right cfg -> do - let ncfg = cfg & basedir .~ (hieraconfig ^. directory) <> "/" cache <- F.newFileCache - return (Right (query ncfg cache)) + return (Right (query cfg fp cache)) -- | A dummy hiera function that will be used when hiera is not detected dummyHiera :: Monad m => HieraQueryFunc m -dummyHiera _ _ _ = return (S.Right ([] :!: S.Nothing)) +dummyHiera _ _ _ = return $ S.Right ([] :!: S.Nothing) -- | The combinator for "normal" queries queryCombinator :: [LogWriter (S.Maybe PValue)] -> LogWriter (S.Maybe PValue) @@ -151,9 +153,9 @@ type LogWriter = WriterT InterpreterWriter IO -query :: HieraConfig -> HieraCache -> HieraQueryFunc IO -query (HieraConfig b h bd) cache vars hquery qtype = do - fmap (S.Right . prepout) (runWriterT (sequencerFunction (map query' h))) `catch` (\e -> return . S.Left . PrettyError . string . show $ (e :: SomeException)) +query :: ConfigFile -> FilePath -> Cache -> HieraQueryFunc IO +query (ConfigFile {_backends, _hierarchy}) fp cache vars hquery qtype = do + fmap (S.Right . prepout) (runWriterT (sequencerFunction (map query' _hierarchy))) `catch` (\e -> return . S.Left . PrettyError . string . show $ (e :: SomeException)) where prepout (a,s) = s :!: a varlist = hcat (L.intersperse comma (map (dullblue . ttext) (L.sort (HM.keys vars)))) @@ -164,23 +166,23 @@ query' :: InterpolableHieraString -> LogWriter (S.Maybe PValue) query' (InterpolableHieraString strs) = case resolveInterpolable vars strs of - Just s -> sequencerFunction (map (query'' s) b) + Just s -> sequencerFunction (map (query'' s) _backends) Nothing -> warn ("Hiera: could not interpolate " <> pretty strs <> ", known variables are:" <+> varlist) >> return S.Nothing - query'' :: T.Text -> HieraBackend -> LogWriter (S.Maybe PValue) + query'' :: T.Text -> Backend -> LogWriter (S.Maybe PValue) query'' hieraname backend = do let (decodefunction, datadir, extension) = case backend of (JsonBackend d) -> (fmap (strictifyEither . A.eitherDecode') . BS.readFile , d, ".json") (YamlBackend d) -> (fmap (strictifyEither . (_Left %~ show)) . Y.decodeFileEither, d, ".yaml") - filename = mbd <> datadir <> "/" <> T.unpack hieraname <> extension + filename = basedir <> datadir <> "/" <> T.unpack hieraname <> extension where - mbd = case datadir of + basedir = case datadir of '/' : _ -> mempty - _ -> bd + _ -> fp^.directory <> "/" mfromJSON :: Maybe Value -> LogWriter (S.Maybe PValue) mfromJSON Nothing = return S.Nothing mfromJSON (Just v) = case A.fromJSON v of A.Success a -> return (S.Just (interpolatePValue vars a)) - _ -> warn ("Hiera:" <+> dullred "could not convert this Value to a Puppet type" <> ":" <+> string (show v)) >> return S.Nothing + _ -> warn ("Hiera:" <+> dullred "could not convert this Value to a Puppet type" <> ":" <+> string (show v)) >> return S.Nothing v <- liftIO (F.query cache filename (decodefunction filename)) case v of S.Left r -> do diff --git a/Puppet/Daemon.hs b/Puppet/Daemon.hs --- a/Puppet/Daemon.hs +++ b/Puppet/Daemon.hs @@ -1,44 +1,44 @@ {-# LANGUAGE LambdaCase, CPP #-} -module Puppet.Daemon (initDaemon, logDebug, logInfo, logWarning, logError) where - -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.Interpreter.IO -import Puppet.Plugins -import Puppet.PP -import Hiera.Server -import Erb.Compute +module Puppet.Daemon (initDaemon) where -import Data.FileCache -import qualified System.Log.Logger as LOG +import Control.Exception +import Control.Lens +import qualified Data.Either.Strict as S +import Data.FileCache +import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Data.Text.IO as T +import Data.Tuple.Strict import qualified Data.Vector as V -import qualified Data.HashMap.Strict as HM -import Debug.Trace -import Control.Lens -import qualified Data.Either.Strict as S -import Data.Tuple.Strict -import Control.Exception -import Foreign.Ruby.Safe +import Debug.Trace +import Erb.Compute +import Foreign.Ruby.Safe +import Hiera.Server +import qualified System.Log.Logger as LOG +import Puppet.Interpreter +import Puppet.Interpreter.IO +import Puppet.Interpreter.Types +import Puppet.Manifests +import Puppet.PP +import Puppet.Parser +import Puppet.Parser.Types +import Puppet.Plugins +import Puppet.Preferences +import Puppet.Stats +import Puppet.Utils + loggerName :: String loggerName = "Puppet.Daemon" 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 +-- 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 @@ -59,19 +59,13 @@ > ssh -L 8080:localhost:8080 puppet.host -Known bugs : +Canveats : * It might be buggy when top level statements that are not class\/define\/nodes are altered, or when files loaded with require are changed. -* The catalog is not computed exactly the same way Puppet does. Take a look at -"Puppet.Interpreter.Catalog" for a list of differences. - -* Parsing incompatibilities are listed in "Puppet.DSL.Parser". - -* There might be race conditions because file status are checked before they -are opened. This means the program might end with an exception when the file -is nonexistent. This will need fixing. +* The catalog is not computed exactly the same way Puppet does. Some good practices are enforced. +As an example querying a dictionary with a non existent key returns undef in puppet, whereas it throws an error with language-puppet. -} initDaemon :: Preferences IO -> IO DaemonMethods @@ -86,9 +80,7 @@ intr <- startRubyInterpreter getTemplate <- initTemplateDaemon intr prefs templateStats hquery <- case prefs ^. hieraPath of - Just p -> startHiera p >>= \case - Left _ -> return dummyHiera - Right x -> return x + Just p -> fmap (either error id) $ startHiera p Nothing -> return dummyHiera luacontainer <- initLuaMaster (T.pack (prefs ^. modulesPath)) let myprefs = prefs & prefExtFuncs %~ HM.union luacontainer diff --git a/Puppet/Interpreter.hs b/Puppet/Interpreter.hs --- a/Puppet/Interpreter.hs +++ b/Puppet/Interpreter.hs @@ -57,7 +57,7 @@ -> PuppetDBAPI m -> T.Text -- ^ Node name -> Facts -- ^ Facts ... - -> Container PuppetTypeMethods -- ^ List of native types + -> Container NativeTypeMethods -- ^ List of native types -> Container ( [PValue] -> InterpreterMonad PValue ) -> HieraQueryFunc m -- ^ Hiera query function -> ImpureMethods m @@ -146,9 +146,15 @@ Just x -> return ([], x) -- it is known ! Nothing -> singleton (GetStatement topleveltype toplevelname) >>= evalTopLevel +extractPrism :: Prism' a b -> Doc -> a -> InterpreterMonad b +extractPrism p t a = case preview p a of + Just b -> return b + Nothing -> throwPosError ("Could not extract prism in " <> t) + computeCatalog :: T.Text -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource]) computeCatalog ndename = do - (restop, node) <- getstt TopNode ndename + (restop, node') <- getstt TopNode ndename + node <- extractPrism _Node' "computeCatalog" node' let finalStep [] = return [] finalStep allres = do -- collect stuff and apply thingies @@ -281,13 +287,12 @@ resMod .= [] return result -evaluateNode :: Statement -> InterpreterMonad [Resource] -evaluateNode (Node _ stmts inheritance p) = do +evaluateNode :: Nd -> InterpreterMonad [Resource] +evaluateNode (Nd _ stmts inheritance p) = do curPos .= p pushScope ContRoot 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 @@ -303,7 +308,7 @@ Nothing -> return (curmap & at k ?~ v) evaluateStatement :: Statement -> InterpreterMonad [Resource] -evaluateStatement r@(ClassDeclaration cname _ _ _ _) = +evaluateStatement r@(ClassDeclaration (ClassDecl cname _ _ _ _)) = if "::" `T.isInfixOf` cname then nestedDeclarations . at (TopClass, cname) ?= r >> return [] else do @@ -313,7 +318,7 @@ else scp <> "::" <> cname nestedDeclarations . at (TopClass, rcname) ?= r return [] -evaluateStatement r@(DefineDeclaration dname _ _ _) = +evaluateStatement r@(DefineDeclaration (DefineDec dname _ _ _)) = if "::" `T.isInfixOf` dname then nestedDeclarations . at (TopDefine, dname) ?= r >> return [] else do @@ -321,7 +326,7 @@ 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 +evaluateStatement r@(ResourceCollection (RColl 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 @@ -346,26 +351,26 @@ popScope return o else return [] -evaluateStatement (Dependency (t1 :!: n1) (t2 :!: n2) lt p) = do +evaluateStatement (Dependency (Dep (t1 :!: n1) (t2 :!: n2) lt p)) = do curPos .= p rn1 <- map (fixResourceName t1) <$> resolveExpressionStrings n1 rn2 <- map (fixResourceName t2) <$> resolveExpressionStrings n2 extraRelations <>= [ LinkInformation (RIdentifier t1 an1) (RIdentifier t2 an2) lt p | an1 <- rn1, an2 <- rn2 ] return [] -evaluateStatement (ResourceDeclaration rt ern eargs virt p) = do +evaluateStatement (ResourceDeclaration (ResDec rt ern eargs virt p)) = do curPos .= p resnames <- resolveExpressionStrings ern args <- vmapM resolveArgument eargs >>= fromArgumentList concat <$> mapM (\n -> registerResource rt n args virt p) resnames -evaluateStatement (MainFunctionCall funcname funcargs p) = do +evaluateStatement (MainFunctionCall (MFC funcname funcargs p)) = do curPos .= p vmapM resolveExpression funcargs >>= mainFunctionCall funcname -evaluateStatement (VariableAssignment varname varexpr p) = do +evaluateStatement (VariableAssignment (VarAss varname varexpr p)) = do curPos .= p varval <- resolveExpression varexpr loadVariable varname varval return [] -evaluateStatement (ConditionalStatement conds p) = do +evaluateStatement (ConditionalStatement (CondStatement conds p)) = do curPos .= p let checkCond [] = return [] checkCond ((e :!: stmts) : xs) = do @@ -374,7 +379,7 @@ then evaluateStatementsVector stmts else checkCond xs checkCond (toList conds) -evaluateStatement (DefaultDeclaration resType decls p) = do +evaluateStatement (DefaultDeclaration (DefaultDec resType decls p)) = do curPos .= p let resolveDefaultValue (prm :!: v) = (prm :!:) <$> resolveExpression v rdecls <- vmapM resolveDefaultValue decls >>= fromArgumentList @@ -391,7 +396,7 @@ 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 +evaluateStatement (ResourceOverride (ResOver rt urn eargs p)) = do curPos .= p raassignements <- vmapM resolveArgument eargs >>= fromArgumentList rn <- resolveExpressionString urn @@ -407,7 +412,7 @@ Nothing -> return raassignements scopes . ix scp . scopeOverrides . at rident ?= ResRefOverride rident withAssignements p return [] -evaluateStatement (SHFunctionCall c p) = curPos .= p >> evaluateHFC c +evaluateStatement (SHFunctionCall (SFC c p)) = curPos .= p >> evaluateHFC c evaluateStatement r = throwError (PrettyError ("Do not know how to evaluate this statement:" pretty r)) ----------------------------------------------------------- @@ -544,12 +549,13 @@ return (LinkInformation (r ^. rid) dstid link p) extraRelations <>= extr void $ enterScope SENormal curContType modulename p - (spurious, dls) <- getstt TopDefine deftype + (spurious, dls') <- getstt TopDefine deftype + dls <- extractPrism _DefineDeclaration' "expandDefine" dls' let isImported (ContImported _) = True isImported _ = False isImportedDefine <- isImported <$> getScope case dls of - (DefineDeclaration _ defineParams stmts cp) -> do + (DefineDec _ defineParams stmts cp) -> do curPos .= r ^. rpos curscp <- getScope when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp )) @@ -569,7 +575,6 @@ when isImportedDefine popScope popScope return out - _ -> throwPosError ("Internal error: we did not retrieve a DefineDeclaration, but had" <+> pretty dls) loadClass :: T.Text @@ -596,9 +601,10 @@ loadedClasses . at classname ?= (cincludetype :!: p) -- load the actual class, note we are not changing the current position -- right now - (spurious, cls) <- getstt TopClass classname + (spurious, cls') <- getstt TopClass classname + cls <- extractPrism _ClassDeclaration' "loadClass" cls' case cls of - (ClassDeclaration _ classParams inh stmts cp) -> do + (ClassDecl _ 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 @@ -630,7 +636,6 @@ finalize (classresource ++ spurious ++ inhstmts ++ res) popScope return out - _ -> throwPosError ("Internal error: we did not retrieve a ClassDeclaration, but had" <+> pretty cls) ----------------------------------------------------------- -- Resource stuff ----------------------------------------------------------- @@ -769,7 +774,7 @@ mainFunctionCall "hiera_include" _ = throwPosError "hiera_include(): This function takes a single argument" mainFunctionCall fname args = do p <- use curPos - let representation = MainFunctionCall fname mempty p + let representation = MainFunctionCall (MFC fname mempty p) rs <- singleton (ExternalFunction fname args) unless (rs == PUndef) $ throwPosError ("This function call should return" <+> pretty PUndef <+> "and not" <+> pretty rs pretty representation) return [] diff --git a/Puppet/Interpreter/Resolve.hs b/Puppet/Interpreter/Resolve.hs --- a/Puppet/Interpreter/Resolve.hs +++ b/Puppet/Interpreter/Resolve.hs @@ -126,8 +126,7 @@ -> InterpreterMonad PValue binaryOperation a b opr = ((PNumber .) . opr) `fmap` resolveExpressionNumber a <*> resolveExpressionNumber b --- | Just like 'binaryOperation', but for operations that only work on --- integers. +-- Just like 'binaryOperation', but for operations that only work on integers. integerOperation :: Expression -> Expression -> (Integer -> Integer -> Integer) -> InterpreterMonad PValue integerOperation a b opr = do ra <- resolveExpressionNumber a @@ -190,7 +189,7 @@ -- | The main resolution function : turns an 'Expression' into a 'PValue', -- if possible. resolveExpression :: Expression -> InterpreterMonad PValue -resolveExpression (PValue v) = resolveValue v +resolveExpression (Terminal v) = resolveValue v resolveExpression (Not e) = fmap (PBoolean . not . pValue2Bool) (resolveExpression e) resolveExpression (And a b) = do ra <- fmap pValue2Bool (resolveExpression a) @@ -210,7 +209,7 @@ resolveExpression (MoreThan a b) = numberCompare a b (>) resolveExpression (LessEqualThan a b) = numberCompare a b (<=) resolveExpression (MoreEqualThan a b) = numberCompare a b (>=) -resolveExpression (RegexMatch a v@(PValue (URegexp _ rv))) = do +resolveExpression (RegexMatch a v@(Terminal (URegexp (CompRegex _ rv)))) = do ra <- fmap T.encodeUtf8 (resolveExpressionString a) case execute' rv ra of Left (_,rr) -> throwPosError ("Error when evaluating" <+> pretty v <+> ":" <+> string rr) @@ -258,7 +257,7 @@ 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 v@(URegexp _ rg) :!: ce) : xs) = do + checkCond ((SelectorValue v@(URegexp (CompRegex _ rg)) :!: ce) : xs) = do rs <- fmap T.encodeUtf8 (resolvePValueString rese) case execute' rg rs of Left (_,rr) -> throwPosError ("Could not match" <+> pretty v <+> ":" <+> string rr) @@ -295,7 +294,7 @@ case (ra, rb) of (PArray ha, v) -> return (PArray (V.snoc ha v)) _ -> integerOperation a b (\x -> shiftL x . fromIntegral) -resolveExpression a@(FunctionApplication e (PValue (UHFunctionCall hf))) = do +resolveExpression a@(FunctionApplication e (Terminal (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) @@ -305,11 +304,11 @@ -- a 'PValue' resolveValue :: UValue -> InterpreterMonad PValue resolveValue (UNumber n) = return (PNumber n) -resolveValue n@(URegexp _ _) = throwPosError ("Regular expressions are not allowed in this context: " <+> pretty n) +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 (UInterpolable vals) = fmap (PString . mconcat) (mapM resolveExpressionString (V.toList vals)) resolveValue (UResourceReference t e) = do r <- resolveExpressionStrings e case r of @@ -614,8 +613,8 @@ if V.null statements then throwPosError ("The statement block must not be empty" <+> pretty hf) else case V.last statements of - (MainFunctionCall fn args _) -> - let expr = PValue (UFunctionCall fn args) + (MainFunctionCall (MFC fn args _)) -> + let expr = Terminal (UFunctionCall fn args) in return (hf & hfstatements %~ V.init & hfexpression .~ S.Just expr , expr) @@ -647,4 +646,3 @@ 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) - diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -2,45 +2,45 @@ {-# LANGUAGE GADTs #-} module Puppet.Interpreter.Types where -import Puppet.Parser.Types -import Puppet.Stats -import Puppet.Parser.PrettyPrinter -import Text.Parsec.Pos +import Puppet.Parser.Types +import Puppet.Stats +import Puppet.Parser.PrettyPrinter -import Data.Aeson as A -import Text.PrettyPrint.ANSI.Leijen hiding ((<$>),rational) +import Control.Applicative hiding (empty) +import Control.Concurrent.MVar (MVar) +import Control.Exception +import Control.Lens +import Control.Monad.Error +import Control.Monad.Operational +import Control.Monad.State.Strict +import Control.Monad.Writer.Class +import Data.Aeson as A +import Data.Aeson.Lens +import Data.Attoparsec.Text (parseOnly, rational) +import qualified Data.ByteString as BS +import qualified Data.Either.Strict as S +import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS +import Data.Hashable +import Data.Maybe (fromMaybe) +import qualified Data.Maybe.Strict as S +import Data.Monoid hiding ((<>)) +import Data.Scientific +import Data.String (IsString(..)) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.Vector as V -import Data.Tuple.Strict -import Control.Monad.State.Strict -import Control.Monad.Error -import Control.Monad.Writer.Class -import Data.Monoid hiding ((<>)) -import Control.Lens -import Data.Aeson.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 Data.Time.Clock import qualified Data.Traversable as TR -import qualified Data.ByteString as BS -import System.Log.Logger -import Control.Applicative hiding (empty) -import Data.Time.Clock -import GHC.Stack -import Data.Maybe (fromMaybe) -import Data.Attoparsec.Text (parseOnly,rational) -import Data.Scientific -import Control.Monad.Operational -import Control.Exception -import Control.Concurrent.MVar (MVar) +import Data.Tuple.Strict +import qualified Data.Vector as V +import Foreign.Ruby +import GHC.Generics hiding (to) +import GHC.Stack import qualified Scripting.Lua as Lua -import Foreign.Ruby -import qualified Data.Foldable as F +import System.Log.Logger +import Text.Parsec.Pos +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), rational) metaparameters :: HS.HashSet T.Text metaparameters = HS.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"] @@ -77,13 +77,12 @@ -> HieraQueryType -> m (S.Either PrettyError (Pair InterpreterWriter (S.Maybe PValue))) -data RSearchExpression - = REqualitySearch !T.Text !PValue - | RNonEqualitySearch !T.Text !PValue - | RAndSearch !RSearchExpression !RSearchExpression - | ROrSearch !RSearchExpression !RSearchExpression - | RAlwaysTrue - deriving Eq +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 @@ -113,68 +112,73 @@ instance Hashable TopLevelType -data ResDefaults = ResDefaults { _defType :: !T.Text - , _defSrcScope :: !T.Text - , _defValues :: !(Container PValue) - , _defPos :: !PPosition - } +data ResDefaults = ResDefaults + { _defType :: !T.Text + , _defSrcScope :: !T.Text + , _defValues :: !(Container PValue) + , _defPos :: !PPosition + } data CurContainerDesc = ContRoot -- ^ Contained at node or root level | ContClass !T.Text -- ^ Contained in a class | ContDefine !T.Text !T.Text !PPosition -- ^ Contained in a define, along with the position where this define was ... defined | ContImported !CurContainerDesc -- ^ Dummy container for imported resources, so that we know we must update the nodename | ContImport !Nodename !CurContainerDesc -- ^ This one is used when finalizing imported resources, and contains the current node name - deriving (Eq, Generic, Ord) + deriving (Eq, Generic, Ord) -data CurContainer = CurContainer { _cctype :: !CurContainerDesc - , _cctags :: !(HS.HashSet T.Text) - } - 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 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 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 Resource) - , _curScope :: ![CurContainerDesc] - , _curPos :: !PPosition - , _nestedDeclarations :: !(HM.HashMap (TopLevelType, T.Text) Statement) - , _extraRelations :: ![LinkInformation] - , _resMod :: ![ResourceModifier] - } +data InterpreterState = InterpreterState + { _scopes :: !(Container ScopeInformation) + , _loadedClasses :: !(Container (Pair ClassIncludeType PPosition)) + , _definedResources :: !(HM.HashMap RIdentifier Resource) + , _curScope :: ![CurContainerDesc] + , _curPos :: !PPosition + , _nestedDeclarations :: !(HM.HashMap (TopLevelType,T.Text) Statement) + , _extraRelations :: ![LinkInformation] + , _resMod :: ![ResourceModifier] + } -data InterpreterReader m = InterpreterReader { _nativeTypes :: !(Container PuppetTypeMethods) - , _getStatement :: TopLevelType -> T.Text -> m (S.Either PrettyError Statement) - , _computeTemplateFunction :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> m (S.Either PrettyError T.Text) - , _pdbAPI :: PuppetDBAPI m - , _externalFunctions :: Container ( [PValue] -> InterpreterMonad PValue ) - , _thisNodename :: T.Text - , _hieraQuery :: HieraQueryFunc m - , _ioMethods :: ImpureMethods m - , _ignoredModules :: HS.HashSet T.Text -- ^ The set of modules we will not include or whatsoever. - } +data InterpreterReader m = InterpreterReader + { _nativeTypes :: !(Container NativeTypeMethods) + , _getStatement :: TopLevelType -> T.Text -> m (S.Either PrettyError Statement) + , _computeTemplateFunction :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> m (S.Either PrettyError T.Text) + , _pdbAPI :: PuppetDBAPI m + , _externalFunctions :: Container ([PValue] -> InterpreterMonad PValue) + , _thisNodename :: T.Text + , _hieraQuery :: HieraQueryFunc m + , _ioMethods :: ImpureMethods m + , _ignoredModules :: HS.HashSet T.Text -- ^ The set of modules we will not include or whatsoever. + } -data ImpureMethods m = ImpureMethods { _imGetCurrentCallStack :: m [String] - , _imReadFile :: [T.Text] -> m (Either String T.Text) - , _imTraceEvent :: String -> m () - , _imCallLua :: MVar Lua.LuaState -> T.Text -> [PValue] -> m (Either String PValue) - } +data ImpureMethods m = ImpureMethods + { _imGetCurrentCallStack :: m [String] + , _imReadFile :: [T.Text] -> m (Either String T.Text) + , _imTraceEvent :: String -> m () + , _imCallLua :: MVar Lua.LuaState -> T.Text -> [PValue] -> m (Either String PValue) + } data InterpreterInstr a where -- Utility for using what's in "InterpreterReader" - GetNativeTypes :: InterpreterInstr (Container PuppetTypeMethods) + GetNativeTypes :: InterpreterInstr (Container NativeTypeMethods) GetStatement :: TopLevelType -> T.Text -> InterpreterInstr Statement ComputeTemplate :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> InterpreterInstr T.Text ExternalFunction :: T.Text -> [PValue] -> InterpreterInstr PValue @@ -236,9 +240,10 @@ noMsg = PrettyError empty strMsg = PrettyError . text -data RIdentifier = RIdentifier { _itype :: !T.Text - , _iname :: !T.Text - } deriving(Show, Eq, Generic, Ord) +data RIdentifier = RIdentifier + { _itype :: !T.Text + , _iname :: !T.Text + } deriving (Show,Eq,Generic,Ord) instance Hashable RIdentifier @@ -255,20 +260,23 @@ | DontRealize deriving Eq -data ResourceModifier = ResourceModifier { _rmResType :: !T.Text - , _rmModifierType :: !ModifierType - , _rmType :: !ResourceCollectorType - , _rmSearch :: !RSearchExpression - , _rmMutation :: !(Resource -> InterpreterMonad Resource) - , _rmDeclaration :: !PPosition - } -data LinkInformation = LinkInformation { _linksrc :: !RIdentifier - , _linkdst :: !RIdentifier - , _linkType :: !LinkType - , _linkPos :: !PPosition - } +data ResourceModifier = ResourceModifier + { _rmResType :: !T.Text + , _rmModifierType :: !ModifierType + , _rmType :: !ResourceCollectorType + , _rmSearch :: !RSearchExpression + , _rmMutation :: !(Resource -> InterpreterMonad Resource) + , _rmDeclaration :: !PPosition + } +data LinkInformation = LinkInformation + { _linksrc :: !RIdentifier + , _linkdst :: !RIdentifier + , _linkType :: !LinkType + , _linkPos :: !PPosition + } + type EdgeMap = HM.HashMap RIdentifier [LinkInformation] {-| This is a fully resolved resource that will be used in the @@ -287,55 +295,61 @@ } deriving Eq --- |This is a function type than can be bound. It is the type of all --- subsequent validators. -type PuppetTypeValidate = Resource -> Either PrettyError Resource +type NativeTypeValidate = Resource -> Either PrettyError Resource -data PuppetTypeMethods = PuppetTypeMethods - { _puppetValidate :: PuppetTypeValidate +-- | Attributes (and providers) of a puppet resource type bundled with validation rules +data NativeTypeMethods = NativeTypeMethods + { _puppetValidate :: NativeTypeValidate , _puppetFields :: HS.HashSet T.Text } type FinalCatalog = HM.HashMap RIdentifier Resource -data DaemonMethods = DaemonMethods { _dGetCatalog :: T.Text -> Facts -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) -- ^ The most important function, computing catalogs. Given a node name and a list of facts, it returns the result of the catalog compilation : either an error, or a tuple containing all the resources in this catalog, the dependency map, the exported resources, and a list of known resources, that might not be up to date, but are here for code coverage tests. - , _dParserStats :: MStats - , _dCatalogStats :: MStats - , _dTemplateStats :: MStats - } +data DaemonMethods = DaemonMethods + { -- | The most important function, computing catalogs. + -- Given a node name and a list of facts, it returns the result of the catalog compilation : either an error, or a tuple containing all the resources in this catalog, the dependency map, the exported resources, and a list of known resources, that might not be up to date, but are here for code coverage tests. + _dGetCatalog :: T.Text -> Facts -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) + , _dParserStats :: MStats + , _dCatalogStats :: MStats + , _dTemplateStats :: MStats + } data PuppetEdge = PuppetEdge RIdentifier RIdentifier LinkType -- | Wire format, see . -data WireCatalog = WireCatalog { _wirecatalogNodename :: !Nodename - , _wirecatalogWVersion :: !T.Text - , _wirecatalogWEdges :: !(V.Vector PuppetEdge) - , _wirecatalogWResources :: !(V.Vector Resource) - , _wirecatalogTransactionUUID :: !T.Text - } +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 :: !PValue - } +data PFactInfo = PFactInfo + { _pfactinfoNodename :: !T.Text + , _pfactinfoFactname :: !T.Text + , _pfactinfoFactval :: !PValue + } -data PNodeInfo = PNodeInfo { _pnodeinfoNodename :: !Nodename - , _pnodeinfoDeactivated :: !Bool - , _pnodeinfoCatalogT :: !(S.Maybe UTCTime) - , _pnodeinfoFactsT :: !(S.Maybe UTCTime) - , _pnodeinfoReportT :: !(S.Maybe UTCTime) - } +data PNodeInfo = PNodeInfo + { _pnodeinfoNodename :: !Nodename + , _pnodeinfoDeactivated :: !Bool + , _pnodeinfoCatalogT :: !(S.Maybe UTCTime) + , _pnodeinfoFactsT :: !(S.Maybe UTCTime) + , _pnodeinfoReportT :: !(S.Maybe UTCTime) + } -data PuppetDBAPI m = PuppetDBAPI { pdbInformation :: m Doc - , replaceCatalog :: WireCatalog -> m (S.Either PrettyError ()) -- ^ - , replaceFacts :: [(Nodename, Facts)] -> m (S.Either PrettyError ()) -- ^ - , deactivateNode :: Nodename -> m (S.Either PrettyError ()) -- ^ - , getFacts :: Query FactField -> m (S.Either PrettyError [PFactInfo]) -- ^ - , getResources :: Query ResourceField -> m (S.Either PrettyError [Resource]) -- ^ - , getNodes :: Query NodeField -> m (S.Either PrettyError [PNodeInfo]) - , commitDB :: m (S.Either PrettyError ()) -- ^ This is only here to tell the test PuppetDB to save its content to disk. - , getResourcesOfNode :: Nodename -> Query ResourceField -> m (S.Either PrettyError [Resource]) - } +data PuppetDBAPI m = PuppetDBAPI + { pdbInformation :: m Doc + , replaceCatalog :: WireCatalog -> m (S.Either PrettyError ()) -- ^ + , replaceFacts :: [(Nodename, Facts)] -> m (S.Either PrettyError ()) -- ^ + , deactivateNode :: Nodename -> m (S.Either PrettyError ()) -- ^ + , getFacts :: Query FactField -> m (S.Either PrettyError [PFactInfo]) -- ^ + , getResources :: Query ResourceField -> m (S.Either PrettyError [Resource]) -- ^ + , getNodes :: Query NodeField -> m (S.Either PrettyError [PNodeInfo]) + , commitDB :: m (S.Either PrettyError ()) -- ^ This is only here to tell the test PuppetDB to save its content to disk. + , getResourcesOfNode :: Nodename -> Query ResourceField -> m (S.Either PrettyError [Resource]) + } -- | Pretty straightforward way to define the various PuppetDB queries data Query a = QEqual a T.Text @@ -350,7 +364,9 @@ | QEmpty -- | Fields for the fact endpoint -data FactField = FName | FValue | FCertname +data FactField = FName + | FValue + | FCertname -- | Fields for the node endpoint data NodeField = NName | NFact T.Text @@ -371,7 +387,7 @@ makeClassy ''ResDefaults makeClassy ''ResourceModifier makeClassy ''DaemonMethods -makeClassy ''PuppetTypeMethods +makeClassy ''NativeTypeMethods makeClassy ''ScopeInformation makeClassy ''Resource makeClassy ''InterpreterState @@ -394,17 +410,14 @@ instance MonadStack InterpreterMonad where getCallStack = singleton GetCurrentCallStack -tpe :: (MonadStack m, MonadError PrettyError m, MonadState InterpreterState m) => Doc -> m b -tpe s = do - p <- use (curPos . _1) - stack <- getCallStack - let dstack = if null stack - then mempty - else mempty string (renderStack stack) - throwError (PrettyError (s <+> "at" <+> showPos p <> dstack)) - instance MonadThrowPos InterpreterMonad where - throwPosError = tpe + throwPosError s = do + p <- use (curPos . _1) + stack <- getCallStack + let dstack = if null stack + then mempty + else mempty string (renderStack stack) + throwError (PrettyError (s <+> "at" <+> showPos p <> dstack)) getCurContainer :: InterpreterMonad CurContainer {-# INLINE getCurContainer #-} @@ -742,4 +755,3 @@ dummypos :: PPosition dummypos = initialPPos "dummy" - diff --git a/Puppet/Lens.hs b/Puppet/Lens.hs --- a/Puppet/Lens.hs +++ b/Puppet/Lens.hs @@ -28,6 +28,19 @@ , _Dependency , _TopContainer , _Statements + -- * More primitive prisms for 'Statement's + , _ResourceDeclaration' + , _DefaultDeclaration' + , _ResourceOverride' + , _ConditionalStatement' + , _ClassDeclaration' + , _DefineDeclaration' + , _Node' + , _VariableAssignment' + , _MainFunctionCall' + , _SHFunctionCall' + , _ResourceCollection' + , _Dependency' -- * Lenses and Prisms for 'Expression's , _Equal , _Different @@ -52,7 +65,7 @@ , _Negate , _ConditionalValue , _FunctionApplication - , _PValue + , _Terminal ) where import Control.Lens @@ -69,14 +82,106 @@ import qualified Data.Vector as V import qualified Data.HashMap.Strict as HM import qualified Data.Text as T +import qualified Data.Maybe.Strict as S import Data.Tuple.Strict hiding (uncurry) import Text.Parser.Combinators (eof) -- Prisms makePrisms ''PValue -makePrisms ''Statement +--makePrisms ''Statement makePrisms ''Expression +makePrisms ''ResDec +makePrisms ''DefaultDec +makePrisms ''ResOver +makePrisms ''CondStatement +makePrisms ''ClassDecl +makePrisms ''DefineDec +makePrisms ''Nd +makePrisms ''VarAss +makePrisms ''MFC +makePrisms ''SFC +makePrisms ''RColl +makePrisms ''Dep + +_ResourceDeclaration' :: Prism' Statement ResDec +_ResourceDeclaration' = prism ResourceDeclaration $ \x -> case x of + ResourceDeclaration a -> Right a + _ -> Left x +_DefaultDeclaration' :: Prism' Statement DefaultDec +_DefaultDeclaration' = prism DefaultDeclaration $ \x -> case x of + DefaultDeclaration a -> Right a + _ -> Left x +_ResourceOverride' :: Prism' Statement ResOver +_ResourceOverride' = prism ResourceOverride $ \x -> case x of + ResourceOverride a -> Right a + _ -> Left x +_ConditionalStatement' :: Prism' Statement CondStatement +_ConditionalStatement' = prism ConditionalStatement $ \x -> case x of + ConditionalStatement a -> Right a + _ -> Left x +_ClassDeclaration' :: Prism' Statement ClassDecl +_ClassDeclaration' = prism ClassDeclaration $ \x -> case x of + ClassDeclaration a -> Right a + _ -> Left x +_DefineDeclaration' :: Prism' Statement DefineDec +_DefineDeclaration' = prism DefineDeclaration $ \x -> case x of + DefineDeclaration a -> Right a + _ -> Left x +_Node' :: Prism' Statement Nd +_Node' = prism Node $ \x -> case x of + Node a -> Right a + _ -> Left x +_VariableAssignment' :: Prism' Statement VarAss +_VariableAssignment' = prism VariableAssignment $ \x -> case x of + VariableAssignment a -> Right a + _ -> Left x +_MainFunctionCall' :: Prism' Statement MFC +_MainFunctionCall' = prism MainFunctionCall $ \x -> case x of + MainFunctionCall a -> Right a + _ -> Left x +_SHFunctionCall' :: Prism' Statement SFC +_SHFunctionCall' = prism SHFunctionCall $ \x -> case x of + SHFunctionCall a -> Right a + _ -> Left x +_ResourceCollection' :: Prism' Statement RColl +_ResourceCollection' = prism ResourceCollection $ \x -> case x of + ResourceCollection a -> Right a + _ -> Left x +_Dependency' :: Prism' Statement Dep +_Dependency' = prism Dependency $ \x -> case x of + Dependency a -> Right a + _ -> Left x +_TopContainer :: Prism' Statement (V.Vector Statement, Statement) +_TopContainer = prism (uncurry TopContainer) $ \x -> case x of + TopContainer vs s -> Right (vs,s) + _ -> Left x + +_ResourceDeclaration :: Prism' Statement (T.Text, Expression, V.Vector (Pair T.Text Expression), Virtuality, PPosition) +_ResourceDeclaration = _ResourceDeclaration' . _ResDec +_DefaultDeclaration :: Prism' Statement (T.Text, V.Vector (Pair T.Text Expression), PPosition) +_DefaultDeclaration = _DefaultDeclaration' . _DefaultDec +_ResourceOverride :: Prism' Statement (T.Text, Expression, V.Vector (Pair T.Text Expression), PPosition) +_ResourceOverride = _ResourceOverride' . _ResOver +_ConditionalStatement :: Prism' Statement (V.Vector (Pair Expression (V.Vector Statement)), PPosition) +_ConditionalStatement = _ConditionalStatement' . _CondStatement +_ClassDeclaration :: Prism' Statement (T.Text, V.Vector (Pair T.Text (S.Maybe Expression)), S.Maybe T.Text, V.Vector Statement, PPosition) +_ClassDeclaration = _ClassDeclaration' . _ClassDecl +_DefineDeclaration :: Prism' Statement (T.Text, V.Vector (Pair T.Text (S.Maybe Expression)), V.Vector Statement, PPosition) +_DefineDeclaration = _DefineDeclaration' . _DefineDec +_Node :: Prism' Statement (NodeDesc, V.Vector Statement, S.Maybe NodeDesc, PPosition) +_Node = _Node' . _Nd +_VariableAssignment :: Prism' Statement (T.Text, Expression, PPosition) +_VariableAssignment = _VariableAssignment' . _VarAss +_MainFunctionCall :: Prism' Statement (T.Text, V.Vector Expression, PPosition) +_MainFunctionCall = _MainFunctionCall' . _MFC +_SHFunctionCall :: Prism' Statement (HFunctionCall, PPosition) +_SHFunctionCall = _SHFunctionCall' . _SFC +_ResourceCollection :: Prism' Statement (CollectorType, T.Text, SearchExpression, V.Vector (Pair T.Text Expression), PPosition) +_ResourceCollection = _ResourceCollection' . _RColl +_Dependency :: Prism' Statement (Pair T.Text Expression, Pair T.Text Expression, LinkType, PPosition) +_Dependency = _Dependency' . _Dep + -- | Incomplete _PResolveExpression :: Prism' Expression PValue _PResolveExpression = prism reinject extract @@ -84,7 +189,7 @@ extract e = case dummyEval (resolveExpression e) of Right x -> Right x Left _ -> Left e - reinject = PValue . review _PResolveValue + reinject = Terminal . review _PResolveValue _PResolveValue :: Prism' UValue PValue _PResolveValue = prism toU toP @@ -96,9 +201,9 @@ toU (PNumber x) = UNumber x toU PUndef = UUndef toU (PString s) = UString s - toU (PResourceReference t n) = UResourceReference t (PValue (UString n)) - toU (PArray r) = UArray (fmap (PValue . toU) r) - toU (PHash h) = UHash (V.fromList $ map (\(k,v) -> (PValue (UString k) :!: PValue (toU v))) $ HM.toList h) + toU (PResourceReference t n) = UResourceReference t (Terminal (UString n)) + toU (PArray r) = UArray (fmap (Terminal . toU) r) + toU (PHash h) = UHash (V.fromList $ map (\(k,v) -> (Terminal (UString k) :!: Terminal (toU v))) $ HM.toList h) _PParse :: Prism' T.Text (V.Vector Statement) _PParse = prism dspl prs @@ -114,16 +219,16 @@ _Statements = lens (V.toList . sget) (\s v -> sset s (V.fromList v)) where sget :: Statement -> V.Vector Statement - sget (ClassDeclaration _ _ _ s _) = s - sget (DefineDeclaration _ _ s _) = s - sget (Node _ s _ _) = s + sget (ClassDeclaration (ClassDecl _ _ _ s _)) = s + sget (DefineDeclaration (DefineDec _ _ s _)) = s + sget (Node (Nd _ s _ _)) = s sget (TopContainer s _) = s - sget (SHFunctionCall (HFunctionCall _ _ _ s _) _) = s + sget (SHFunctionCall (SFC (HFunctionCall _ _ _ s _) _)) = s sget _ = V.empty sset :: Statement -> V.Vector Statement -> Statement - sset (ClassDeclaration n args inh _ p) s = ClassDeclaration n args inh s p - sset (Node ns _ nd' p) s = Node ns s nd' p - sset (DefineDeclaration n args _ p) s = DefineDeclaration n args s p + sset (ClassDeclaration (ClassDecl n args inh _ p)) s = ClassDeclaration (ClassDecl n args inh s p) + sset (Node (Nd ns _ nd' p)) s = Node (Nd ns s nd' p) + sset (DefineDeclaration (DefineDec n args _ p)) s = DefineDeclaration (DefineDec n args s p) sset (TopContainer _ p) s = TopContainer s p - sset (SHFunctionCall (HFunctionCall t e pr _ e2) p) s = SHFunctionCall (HFunctionCall t e pr s e2) p + sset (SHFunctionCall (SFC (HFunctionCall t e pr _ e2) p)) s = SHFunctionCall (SFC (HFunctionCall t e pr s e2) p) sset x _ = x diff --git a/Puppet/Manifests.hs b/Puppet/Manifests.hs --- a/Puppet/Manifests.hs +++ b/Puppet/Manifests.hs @@ -22,14 +22,14 @@ filterStatements TopNode ndename 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 n@(Node (Nd (NodeName !nm) _ _ _)) = curstuff & _2 . at nm ?~ n + triage curstuff n@(Node (Nd (NodeMatch (CompRegex _ !rg)) _ _ _)) = curstuff & _3 %~ (|> (rg :!: n)) + triage curstuff n@(Node (Nd NodeDefault _ _ _)) = curstuff & _4 ?~ n triage curstuff x = curstuff & _1 %~ (|> x) bsnodename = T.encodeUtf8 ndename checkRegexp :: [Pair Regex Statement] -> ErrorT PrettyError IO (Maybe Statement) checkRegexp [] = return Nothing - checkRegexp ((regexp :!: s):xs) = do + checkRegexp ((regexp :!: s):xs) = case execute' regexp bsnodename of Left rr -> throwError (PrettyError ("Regexp match error:" <+> text (show rr))) Right Nothing -> checkRegexp xs @@ -45,8 +45,8 @@ Nothing -> throwError (PrettyError ("Couldn't find node" <+> ttext ndename)) filterStatements x ndename 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@(ClassDeclaration (ClassDecl cname _ _ _ _)) = curstuff & _3 . at cname ?~ n + triage curstuff n@(DefineDeclaration (DefineDec cname _ _ _)) = curstuff & _2 . at cname ?~ n triage curstuff n = curstuff & _1 %~ (|> n) tc n = if V.null spurious then n diff --git a/Puppet/NativeTypes.hs b/Puppet/NativeTypes.hs --- a/Puppet/NativeTypes.hs +++ b/Puppet/NativeTypes.hs @@ -1,30 +1,35 @@ {-| This module holds the /native/ Puppet resource types. -} -module Puppet.NativeTypes (baseNativeTypes,validateNativeType) where +module Puppet.NativeTypes ( + baseNativeTypes + , validateNativeType +) where -import Puppet.NativeTypes.Helpers -import Puppet.NativeTypes.File -import Puppet.NativeTypes.Cron -import Puppet.NativeTypes.Exec -import Puppet.NativeTypes.Group -import Puppet.NativeTypes.Host -import Puppet.NativeTypes.Mount -import Puppet.NativeTypes.Package -import Puppet.NativeTypes.User -import Puppet.NativeTypes.ZoneRecord -import Puppet.NativeTypes.SshSecure -import Puppet.Interpreter.Types +import Control.Lens +import Control.Monad.Operational import qualified Data.HashMap.Strict as HM -import Control.Lens -import Control.Monad.Operational -fakeTypes :: [(PuppetTypeName, PuppetTypeMethods)] +import Puppet.Interpreter.Types +import Puppet.NativeTypes.Concat +import Puppet.NativeTypes.Cron +import Puppet.NativeTypes.Exec +import Puppet.NativeTypes.File +import Puppet.NativeTypes.Group +import Puppet.NativeTypes.Helpers +import Puppet.NativeTypes.Host +import Puppet.NativeTypes.Mount +import Puppet.NativeTypes.Package +import Puppet.NativeTypes.SshSecure +import Puppet.NativeTypes.User +import Puppet.NativeTypes.ZoneRecord + +fakeTypes :: [(NativeTypeName, NativeTypeMethods)] fakeTypes = map faketype ["class"] -defaultTypes :: [(PuppetTypeName, PuppetTypeMethods)] +defaultTypes :: [(NativeTypeName, NativeTypeMethods)] 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","ssh_authorized_key","sshkey","stage","tidy","vlan","yumrepo","zfs","zone","zpool"] -- | The map of native types. They are described in "Puppet.NativeTypes.Helpers". -baseNativeTypes :: Container PuppetTypeMethods +baseNativeTypes :: Container NativeTypeMethods baseNativeTypes = HM.fromList ( nativeHost : nativeMount @@ -36,10 +41,11 @@ : nativePackage : nativeUser : nativeSshSecure + : nativeConcat + : nativeConcatFragment : fakeTypes ++ defaultTypes) --- | Contrary to the previous iteration, this will let non native types --- pass +-- | Contrary to the previous iteration, this will let non native types pass. validateNativeType :: Resource -> InterpreterMonad Resource validateNativeType r = do tps <- singleton GetNativeTypes @@ -48,4 +54,3 @@ Right nr -> return nr Left err -> throwPosError ("Invalid resource" <+> pretty r getError err) Nothing -> return r - diff --git a/Puppet/NativeTypes/Concat.hs b/Puppet/NativeTypes/Concat.hs new file mode 100644 --- /dev/null +++ b/Puppet/NativeTypes/Concat.hs @@ -0,0 +1,48 @@ +module Puppet.NativeTypes.Concat ( + nativeConcat + , nativeConcatFragment +) where + +import Puppet.NativeTypes.Helpers +import Puppet.Interpreter.Types +import qualified Data.Text as T + +nativeConcat :: (NativeTypeName, NativeTypeMethods) +nativeConcat = ("concat", nativetypemethods concatparamfunctions return) + +nativeConcatFragment :: (NativeTypeName, NativeTypeMethods) +nativeConcatFragment = ("concat::fragment", nativetypemethods fragmentparamfunctions validateSourceOrContent) + +concatparamfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])] +concatparamfunctions = + [("name" , [nameval]) + ,("ensure" , [defaultvalue "present", string, values ["present","absent"]]) + ,("path" , [string]) + ,("owner" , [string]) + ,("group" , [string]) + ,("mode" , [defaultvalue "0644", string]) + ,("warn" , [defaultvalue "false", string, values ["false", "true"]]) + ,("force" , [defaultvalue "false", string, values ["false", "true"]]) + ,("backup" , [defaultvalue "puppet", string]) + ,("replace" , [defaultvalue "true", string, values ["false", "true"]]) + ,("order" , [defaultvalue "alpha", string, values ["alpha","numeric"]]) + ,("ensure_newline" , [defaultvalue "false", string, values ["false", "true"]]) + -- deprecated + -- ,("gnu" , [string]) + ] + +fragmentparamfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])] +fragmentparamfunctions = + [("name" , [nameval]) + ,("target" , [string, mandatory]) + ,("content" , [string]) + ,("source" , [string]) + -- order should be an int or a string + ,("order" , [defaultvalue "10", string]) + ,("ensure" , [string, values ["present","absent"]]) + -- deprecated field + -- ,("mode" , [string]) + -- ,("owner" , [string]) + -- ,("group" , [string]) + -- ,("backup" , [string]) + ] diff --git a/Puppet/NativeTypes/Cron.hs b/Puppet/NativeTypes/Cron.hs --- a/Puppet/NativeTypes/Cron.hs +++ b/Puppet/NativeTypes/Cron.hs @@ -2,22 +2,17 @@ import qualified Text.PrettyPrint.ANSI.Leijen as P import Puppet.NativeTypes.Helpers -import Control.Monad.Error import Puppet.Interpreter.Types -import qualified Data.HashSet as HS import qualified Data.Text as T import Control.Lens import qualified Data.Vector as V import Data.Scientific -nativeCron :: (PuppetTypeName, PuppetTypeMethods) -nativeCron = ("cron", PuppetTypeMethods validateCron parameterset) +nativeCron :: (NativeTypeName, NativeTypeMethods) +nativeCron = ("cron", nativetypemethods parameterfunctions return ) -- 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 :: HS.HashSet T.Text -parameterset = HS.fromList $ map fst parameterfunctions - -parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] +parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])] parameterfunctions = [("ensure" , [defaultvalue "present", string, values ["present","absent"]]) ,("command" , [string, mandatoryIfNotAbsent]) @@ -34,10 +29,8 @@ ,("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 :: Integer -> Integer -> [T.Text] -> T.Text -> NativeTypeValidate 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 @@ -53,17 +46,17 @@ else parseval x mi ma param res x -> perror $ "Parameter" <+> paramname param <+> "value should be a valid cron declaration and not" <+> pretty x -parseval :: T.Text -> Integer -> Integer -> T.Text -> PuppetTypeValidate +parseval :: T.Text -> Integer -> Integer -> T.Text -> NativeTypeValidate 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 :: T.Text -> Integer -> Integer -> T.Text -> NativeTypeValidate checkint st mi ma pname res = case text2Scientific st of Just n -> checkint' n mi ma pname res Nothing -> perror $ "Invalid value type for parameter" <+> paramname pname <+> ": " <+> red (ttext st) -checkint' :: Scientific -> Integer -> Integer -> T.Text -> PuppetTypeValidate +checkint' :: Scientific -> Integer -> Integer -> T.Text -> NativeTypeValidate checkint' i mi ma param res = if (i >= fromIntegral mi) && (i <= fromIntegral ma) then Right res diff --git a/Puppet/NativeTypes/Exec.hs b/Puppet/NativeTypes/Exec.hs --- a/Puppet/NativeTypes/Exec.hs +++ b/Puppet/NativeTypes/Exec.hs @@ -2,19 +2,14 @@ import Puppet.NativeTypes.Helpers import Puppet.Interpreter.Types -import Control.Monad.Error -import qualified Data.HashSet as HS import qualified Data.Text as T import Control.Lens -nativeExec :: (PuppetTypeName, PuppetTypeMethods) -nativeExec = ("exec", PuppetTypeMethods validateExec parameterset) +nativeExec :: (NativeTypeName, NativeTypeMethods) +nativeExec = ("exec", nativetypemethods parameterfunctions fullyQualifiedOrPath) -- 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 :: HS.HashSet T.Text -parameterset = HS.fromList $ map fst parameterfunctions - -parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] +parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])] parameterfunctions = [("command" , [nameval]) ,("creates" , [rarray, strings, fullyQualifieds]) @@ -35,10 +30,7 @@ ,("user" , [string]) ] -validateExec :: PuppetTypeValidate -validateExec = defaultValidate parameterset >=> parameterFunctions parameterfunctions >=> fullyQualifiedOrPath - -fullyQualifiedOrPath :: PuppetTypeValidate +fullyQualifiedOrPath :: NativeTypeValidate fullyQualifiedOrPath res = case (res ^. rattributes . at "path", res ^. rattributes . at "command") of (Nothing, Just (PString x)) -> if T.head x == '/' then Right res diff --git a/Puppet/NativeTypes/File.hs b/Puppet/NativeTypes/File.hs --- a/Puppet/NativeTypes/File.hs +++ b/Puppet/NativeTypes/File.hs @@ -3,20 +3,17 @@ import Puppet.NativeTypes.Helpers import Control.Monad.Error import Puppet.Interpreter.Types -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) +nativeFile :: (NativeTypeName, NativeTypeMethods) +nativeFile = ("file", nativetypemethods parameterfunctions (validateSourceOrContent >=> validateMode)) + -- 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 :: HS.HashSet T.Text -parameterset = HS.fromList $ map fst parameterfunctions -parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] +parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])] parameterfunctions = [("backup" , [string]) ,("checksum" , [values ["md5", "md5lite", "mtime", "ctime", "none"]]) @@ -40,10 +37,7 @@ ,("source" , [rarray, strings, flip runarray checkSource]) ] -validateFile :: PuppetTypeValidate -validateFile = defaultValidate parameterset >=> parameterFunctions parameterfunctions >=> validateSourceOrContent >=> validateMode - -validateMode :: PuppetTypeValidate +validateMode :: NativeTypeValidate validateMode res = do modestr <- case res ^. rattributes . at "mode" of Just (PString s) -> return s @@ -55,16 +49,8 @@ then return $ res & rattributes . at "mode" ?~ PString (T.cons '0' modestr) else return res -validateSourceOrContent :: PuppetTypeValidate -validateSourceOrContent res = let - parammap = res ^. rattributes - source = HM.member "source" parammap - content = HM.member "content" parammap - in if source && content - then perror "Source and content can't be specified at the same time" - else Right res -checkSource :: T.Text -> PValue -> PuppetTypeValidate +checkSource :: T.Text -> PValue -> NativeTypeValidate checkSource _ (PString x) res | "puppet://" `T.isPrefixOf` x = Right res | "file://" `T.isPrefixOf` x = Right res | otherwise = throwError "A source should start with either puppet:// or file://" diff --git a/Puppet/NativeTypes/Group.hs b/Puppet/NativeTypes/Group.hs --- a/Puppet/NativeTypes/Group.hs +++ b/Puppet/NativeTypes/Group.hs @@ -2,18 +2,13 @@ import Puppet.NativeTypes.Helpers import Puppet.Interpreter.Types -import Control.Monad.Error -import qualified Data.HashSet as HS import qualified Data.Text as T -nativeGroup :: (PuppetTypeName, PuppetTypeMethods) -nativeGroup = ("group", PuppetTypeMethods validateGroup parameterset) +nativeGroup :: (NativeTypeName, NativeTypeMethods) +nativeGroup = ("group", nativetypemethods parameterfunctions return) -- 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 :: HS.HashSet T.Text -parameterset = HS.fromList $ map fst parameterfunctions - -parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] +parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])] parameterfunctions = [("allowdupe" , [string, defaultvalue "false", values ["true","false"]]) ,("attribute_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) @@ -27,7 +22,3 @@ ,("provider" , [string, values ["aix","directoryservice","groupadd","ldap","pw","window_adsi"]]) ,("system" , [string, defaultvalue "false", values ["true","false"]]) ] - -validateGroup :: PuppetTypeValidate -validateGroup = defaultValidate parameterset >=> parameterFunctions parameterfunctions - diff --git a/Puppet/NativeTypes/Helpers.hs b/Puppet/NativeTypes/Helpers.hs --- a/Puppet/NativeTypes/Helpers.hs +++ b/Puppet/NativeTypes/Helpers.hs @@ -4,6 +4,8 @@ module Puppet.NativeTypes.Helpers ( module Puppet.PP , ipaddr + -- smart constructor for NativeTypeMethods + , nativetypemethods , paramname , rarray , string @@ -13,9 +15,10 @@ , fullyQualifieds , values , defaultvalue + , concattype , nameval , defaultValidate - , PuppetTypeName + , NativeTypeName , parameterFunctions , integer , integers @@ -26,6 +29,7 @@ , defaulttype , runarray , perror + , validateSourceOrContent ) where import Puppet.PP hiding (string,integer) @@ -43,7 +47,7 @@ import Data.Aeson.Lens (_Number,_Integer) import Data.Maybe (fromMaybe) -type PuppetTypeName = T.Text +type NativeTypeName = T.Text paramname :: T.Text -> Doc paramname = red . ttext @@ -52,19 +56,30 @@ perror :: Doc -> Either PrettyError Resource perror = Left . PrettyError -faketype :: PuppetTypeName -> (PuppetTypeName, PuppetTypeMethods) -faketype tname = (tname, PuppetTypeMethods Right HS.empty) +nativetypemethods :: [(T.Text, [T.Text -> NativeTypeValidate])] -> NativeTypeValidate -> NativeTypeMethods +nativetypemethods def extraV = + let params = fromKeys def + in NativeTypeMethods (defaultValidate params >=> parameterFunctions def >=> extraV) params + where + fromKeys = HS.fromList . map fst -defaulttype :: PuppetTypeName -> (PuppetTypeName, PuppetTypeMethods) -defaulttype tname = (tname, PuppetTypeMethods (defaultValidate HS.empty) HS.empty) +faketype :: NativeTypeName -> (NativeTypeName, NativeTypeMethods) +faketype tname = (tname, NativeTypeMethods Right HS.empty) -{-| This helper will validate resources given a list of fields. It will run -'checkParameterList' and then 'addDefaults'. -} -defaultValidate :: HS.HashSet T.Text -> PuppetTypeValidate +concattype :: NativeTypeName -> (NativeTypeName, NativeTypeMethods) +concattype tname = (tname, NativeTypeMethods (defaultValidate HS.empty) HS.empty) + +defaulttype :: NativeTypeName -> (NativeTypeName, NativeTypeMethods) +defaulttype tname = (tname, NativeTypeMethods (defaultValidate HS.empty) HS.empty) + +{-| Validate resources given a list of valid parameters: + + * checks that no unknown parameters have been set (except metaparameters) +-} +defaultValidate :: HS.HashSet T.Text -> NativeTypeValidate defaultValidate validparameters = checkParameterList validparameters >=> addDefaults --- | This validator checks that no unknown parameters have been set (except metaparameters) -checkParameterList :: HS.HashSet T.Text -> PuppetTypeValidate +checkParameterList :: HS.HashSet T.Text -> NativeTypeValidate checkParameterList validparameters res | HS.null validparameters = Right res | otherwise = if HS.null setdiff then Right res @@ -74,7 +89,7 @@ setdiff = HS.difference keyset (metaparameters `HS.union` validparameters) -- | This validator always accept the resources, but add the default parameters (to be defined :) -addDefaults :: PuppetTypeValidate +addDefaults :: NativeTypeValidate addDefaults res = Right (res & rattributes %~ newparams) where def PUndef = False @@ -83,7 +98,7 @@ defaults = HM.empty -- | Helper function that runs a validor on a PArray -runarray :: T.Text -> (T.Text -> PValue -> PuppetTypeValidate) -> PuppetTypeValidate +runarray :: T.Text -> (T.Text -> PValue -> NativeTypeValidate) -> NativeTypeValidate runarray param func res = case res ^. rattributes . at param of Just (PArray x) -> V.foldM (flip (func param)) res x Just x -> perror $ "Parameter" <+> paramname param <+> "should be an array, not" <+> pretty x @@ -92,15 +107,15 @@ {-| 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 :: T.Text -> NativeTypeValidate string param res = case res ^. rattributes . at param of Just x -> string' param x res Nothing -> Right res -strings :: T.Text -> PuppetTypeValidate +strings :: T.Text -> NativeTypeValidate strings param = runarray param string' -string' :: T.Text -> PValue -> PuppetTypeValidate +string' :: T.Text -> PValue -> NativeTypeValidate string' param rev res = case rev of PString _ -> Right res PBoolean True -> Right (res & rattributes . at param ?~ PString "true") @@ -108,8 +123,10 @@ PNumber n -> Right (res & rattributes . at param ?~ PString (scientific2text n)) x -> perror $ "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 :: [T.Text] -> T.Text -> NativeTypeValidate values valuelist param res = case res ^. rattributes . at param of Just (PString x) -> if x `elem` valuelist then Right res @@ -118,29 +135,29 @@ Nothing -> Right res -- | This fills the default values of unset parameters. -defaultvalue :: T.Text -> T.Text -> PuppetTypeValidate +defaultvalue :: T.Text -> T.Text -> NativeTypeValidate defaultvalue value param = Right . over (rattributes . at param) (Just . fromMaybe (PString value)) -- | Checks that a given parameter, if set, is a 'ResolvedInt'. If it is a -- 'PString' it will attempt to parse it. -integer :: T.Text -> PuppetTypeValidate +integer :: T.Text -> NativeTypeValidate integer prm res = string prm res >>= integer' prm where integer' pr rs = case rs ^. rattributes . at pr of Just x -> integer'' prm x res Nothing -> Right rs -integers :: T.Text -> PuppetTypeValidate +integers :: T.Text -> NativeTypeValidate integers param = runarray param integer'' -integer'' :: T.Text -> PValue -> PuppetTypeValidate +integer'' :: T.Text -> PValue -> NativeTypeValidate integer'' param val res = case val ^? _Integer of Just v -> Right (res & rattributes . at param ?~ PNumber (fromIntegral v)) _ -> perror $ "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 :: T.Text -> NativeTypeValidate nameval prm res = string prm res >>= \r -> case r ^. rattributes . at prm of Just (PString al) -> Right (res & rid . iname .~ al) @@ -148,7 +165,7 @@ Nothing -> Right (r & rattributes . at prm ?~ PString (r ^. rid . iname)) -- | Checks that a given parameter is set unless the resources "ensure" is set to absent -mandatoryIfNotAbsent :: T.Text -> PuppetTypeValidate +mandatoryIfNotAbsent :: T.Text -> NativeTypeValidate mandatoryIfNotAbsent param res = case res ^. rattributes . at param of Just _ -> Right res Nothing -> case res ^. rattributes . at "ensure" of @@ -156,37 +173,37 @@ _ -> perror $ "Parameter" <+> paramname param <+> "should be set." -- | Checks that a given parameter is set. -mandatory :: T.Text -> PuppetTypeValidate +mandatory :: T.Text -> NativeTypeValidate mandatory param res = case res ^. rattributes . at param of Just _ -> Right res Nothing -> perror $ "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 :: [(T.Text, [T.Text -> NativeTypeValidate])] -> NativeTypeValidate parameterFunctions argrules rs = foldM parameterFunctions' rs argrules where - parameterFunctions' :: Resource -> (T.Text, [T.Text -> PuppetTypeValidate]) -> Either PrettyError Resource + parameterFunctions' :: Resource -> (T.Text, [T.Text -> NativeTypeValidate]) -> Either PrettyError Resource parameterFunctions' r (param, validationfunctions) = foldM (parameterFunctions'' param) r validationfunctions - parameterFunctions'' :: T.Text -> Resource -> (T.Text -> PuppetTypeValidate) -> Either PrettyError Resource + parameterFunctions'' :: T.Text -> Resource -> (T.Text -> NativeTypeValidate) -> Either PrettyError Resource parameterFunctions'' param r validationfunction = validationfunction param r -- checks that a parameter is fully qualified -fullyQualified :: T.Text -> PuppetTypeValidate +fullyQualified :: T.Text -> NativeTypeValidate fullyQualified param res = case res ^. rattributes . at param of Just path -> fullyQualified' param path res Nothing -> Right res -noTrailingSlash :: T.Text -> PuppetTypeValidate +noTrailingSlash :: T.Text -> NativeTypeValidate noTrailingSlash param res = case res ^. rattributes . at param of Just (PString x) -> if T.last x == '/' then perror ("Parameter" <+> paramname param <+> "should not have a trailing slash") else Right res _ -> Right res -fullyQualifieds :: T.Text -> PuppetTypeValidate +fullyQualifieds :: T.Text -> NativeTypeValidate fullyQualifieds param = runarray param fullyQualified' -fullyQualified' :: T.Text -> PValue -> PuppetTypeValidate +fullyQualified' :: T.Text -> PValue -> NativeTypeValidate fullyQualified' param path res = case path of PString ("") -> perror $ "Empty path for parameter" <+> paramname param PString p -> if T.head p == '/' @@ -194,13 +211,13 @@ else perror $ "Path must be absolute, not" <+> ttext p <+> "for parameter" <+> paramname param x -> perror $ "SHOULD NOT HAPPEN: path is not a resolved string, but" <+> pretty x <+> "for parameter" <+> paramname param -rarray :: T.Text -> PuppetTypeValidate +rarray :: T.Text -> NativeTypeValidate 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 :: T.Text -> NativeTypeValidate ipaddr param res = case res ^. rattributes . at param of Nothing -> Right res Just (PString ip) -> @@ -220,7 +237,7 @@ goodcur = not (T.null cur) && T.all isDigit cur && (let rcur = read (T.unpack cur) :: Int in (rcur >= 0) && (rcur <= 255)) in goodcur && nextfunc -inrange :: Integer -> Integer -> T.Text -> PuppetTypeValidate +inrange :: Integer -> Integer -> T.Text -> NativeTypeValidate inrange mi ma param res = let va = res ^. rattributes . at param na = va ^? traverse . _Number @@ -231,3 +248,11 @@ else perror $ "Parameter" <+> paramname param P.<> "'s value should be between" <+> P.integer mi <+> "and" <+> P.integer ma (Just x,_) -> perror $ "Parameter" <+> paramname param <+> "should be an integer, and not" <+> pretty x +validateSourceOrContent :: NativeTypeValidate +validateSourceOrContent res = let + parammap = res ^. rattributes + source = HM.member "source" parammap + content = HM.member "content" parammap + in if source && content + then perror "Source and content can't be specified at the same time" + else Right res diff --git a/Puppet/NativeTypes/Host.hs b/Puppet/NativeTypes/Host.hs --- a/Puppet/NativeTypes/Host.hs +++ b/Puppet/NativeTypes/Host.hs @@ -1,22 +1,17 @@ module Puppet.NativeTypes.Host (nativeHost) where import Puppet.NativeTypes.Helpers -import Control.Monad.Error import Puppet.Interpreter.Types -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) +nativeHost :: (NativeTypeName, NativeTypeMethods) +nativeHost = ("host", nativetypemethods parameterfunctions return) -- 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 :: HS.HashSet T.Text -parameterset = HS.fromList $ map fst parameterfunctions - -parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] +parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])] parameterfunctions = [("comment" , [string, values ["true","false"]]) ,("ensure" , [defaultvalue "present", string, values ["present","absent"]]) @@ -27,10 +22,7 @@ ,("target" , [string, fullyQualified]) ] -validateHost :: PuppetTypeValidate -validateHost = defaultValidate parameterset >=> parameterFunctions parameterfunctions - -checkhostname :: T.Text -> PuppetTypeValidate +checkhostname :: T.Text -> NativeTypeValidate checkhostname param res = case res ^. rattributes . at param of Nothing -> Right res Just (PArray xs) -> V.foldM (checkhostname' param) res xs @@ -52,4 +44,3 @@ in if T.null cur || (T.head cur == '-') || not (T.all (\x -> isAlphaNum x || (x=='-')) cur) then perror $ "Invalid hostname part for parameter" <+> paramname prm else nextfunc - diff --git a/Puppet/NativeTypes/Mount.hs b/Puppet/NativeTypes/Mount.hs --- a/Puppet/NativeTypes/Mount.hs +++ b/Puppet/NativeTypes/Mount.hs @@ -2,17 +2,12 @@ import Puppet.NativeTypes.Helpers import Puppet.Interpreter.Types -import Control.Monad.Error -import qualified Data.HashSet as HS import qualified Data.Text as T -nativeMount :: (PuppetTypeName, PuppetTypeMethods) -nativeMount = ("mount", PuppetTypeMethods validateMount parameterset) - -parameterset :: HS.HashSet T.Text -parameterset = HS.fromList $ map fst parameterfunctions +nativeMount :: (NativeTypeName, NativeTypeMethods) +nativeMount = ("mount", nativetypemethods parameterfunctions return) -parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] +parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])] parameterfunctions = [("atboot" , [string, values ["true","false"]]) ,("blockdevice" , [string]) @@ -27,7 +22,3 @@ ,("remounts" , [string, values ["true","false"]]) ,("target" , [string, fullyQualified]) ] - -validateMount :: PuppetTypeValidate -validateMount = defaultValidate parameterset >=> parameterFunctions parameterfunctions - diff --git a/Puppet/NativeTypes/Package.hs b/Puppet/NativeTypes/Package.hs --- a/Puppet/NativeTypes/Package.hs +++ b/Puppet/NativeTypes/Package.hs @@ -11,8 +11,8 @@ import GHC.Generics import Data.Hashable -nativePackage :: (PuppetTypeName, PuppetTypeMethods) -nativePackage = ("package", PuppetTypeMethods validatePackage parameterset) +nativePackage :: (NativeTypeName, NativeTypeMethods) +nativePackage = ("package", nativetypemethods parameterfunctions (getFeature >=> checkFeatures)) data PackagingFeatures = Holdable | InstallOptions | Installable | Purgeable | UninstallOptions | Uninstallable | Upgradeable | Versionable deriving (Show, Eq, Generic) @@ -54,9 +54,8 @@ , ("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 :: [(T.Text, [T.Text -> NativeTypeValidate])] parameterfunctions = [("adminfile" , [string, fullyQualified]) ,("allowcdrom" , [string, values ["true","false"]]) @@ -107,8 +106,3 @@ _ -> Right (s, res) decap :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError Resource decap = Right . snd - -validatePackage :: PuppetTypeValidate -validatePackage = defaultValidate parameterset >=> parameterFunctions parameterfunctions >=> getFeature >=> checkFeatures - - diff --git a/Puppet/NativeTypes/SshSecure.hs b/Puppet/NativeTypes/SshSecure.hs --- a/Puppet/NativeTypes/SshSecure.hs +++ b/Puppet/NativeTypes/SshSecure.hs @@ -3,18 +3,14 @@ import Puppet.NativeTypes.Helpers import Puppet.Interpreter.Types import Control.Monad.Error -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) +nativeSshSecure :: (NativeTypeName, NativeTypeMethods) +nativeSshSecure = ("ssh_authorized_key_secure", nativetypemethods parameterfunctions (userOrTarget >=> keyIfPresent)) -- 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 :: HS.HashSet T.Text -parameterset = HS.fromList $ map fst parameterfunctions - -parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] +parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])] parameterfunctions = [("type" , [string, defaultvalue "ssh-rsa", values ["rsa","dsa","ssh-rsa","ssh-dss"]]) ,("key" , [string]) @@ -24,18 +20,14 @@ ,("options" , [rarray, strings]) ] -userOrTarget :: PuppetTypeValidate +userOrTarget :: NativeTypeValidate userOrTarget res = case (res ^. rattributes & has (ix "user"), res ^. rattributes & has (ix "target")) of (False, False) -> Left "Parameters user or target are mandatory" _ -> Right res -keyIfPresent :: PuppetTypeValidate +keyIfPresent :: NativeTypeValidate keyIfPresent res = case (res ^. rattributes . at "key", res ^. rattributes . at "ensure") of (Just _, Just "present") -> Right res (_, Just "absent") -> Right res _ -> Left "Parameter key is mandatory when the resource is present" - -validateSshSecure :: PuppetTypeValidate -validateSshSecure = defaultValidate parameterset >=> parameterFunctions parameterfunctions >=> userOrTarget >=> keyIfPresent - diff --git a/Puppet/NativeTypes/User.hs b/Puppet/NativeTypes/User.hs --- a/Puppet/NativeTypes/User.hs +++ b/Puppet/NativeTypes/User.hs @@ -2,17 +2,13 @@ import Puppet.NativeTypes.Helpers import Puppet.Interpreter.Types -import Control.Monad.Error -import qualified Data.HashSet as HS import qualified Data.Text as T -nativeUser :: (PuppetTypeName, PuppetTypeMethods) -nativeUser = ("user", PuppetTypeMethods validateUser parameterset) +nativeUser :: (NativeTypeName, NativeTypeMethods) +nativeUser = ("user", nativetypemethods parameterfunctions return) -- 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 :: HS.HashSet T.Text -parameterset = HS.fromList $ map fst parameterfunctions -parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] +parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])] parameterfunctions = [("allowdupe" , [string, defaultvalue "false", values ["true","false"]]) ,("attribute_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) @@ -46,7 +42,3 @@ ,("system" , [string, defaultvalue "false", values ["true","false"]]) ,("uid" , [integer]) ] - -validateUser :: PuppetTypeValidate -validateUser = defaultValidate parameterset >=> parameterFunctions parameterfunctions - diff --git a/Puppet/NativeTypes/ZoneRecord.hs b/Puppet/NativeTypes/ZoneRecord.hs --- a/Puppet/NativeTypes/ZoneRecord.hs +++ b/Puppet/NativeTypes/ZoneRecord.hs @@ -3,18 +3,14 @@ import Puppet.NativeTypes.Helpers import Puppet.Interpreter.Types import Control.Monad.Error -import qualified Data.HashSet as HS import qualified Data.Text as T import Control.Lens -nativeZoneRecord :: (PuppetTypeName, PuppetTypeMethods) -nativeZoneRecord = ("zone_record", PuppetTypeMethods validateZoneRecord parameterset) +nativeZoneRecord :: (NativeTypeName, NativeTypeMethods) +nativeZoneRecord = ("zone_record", nativetypemethods parameterfunctions validateMandatories) -- 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 :: HS.HashSet T.Text -parameterset = HS.fromList $ map fst parameterfunctions - -parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] +parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])] parameterfunctions = [("name" , [nameval]) ,("owner" , [string]) @@ -33,10 +29,7 @@ ,("email" , [string]) ] -validateZoneRecord :: PuppetTypeValidate -validateZoneRecord = defaultValidate parameterset >=> parameterFunctions parameterfunctions >=> validateMandatories - -validateMandatories :: PuppetTypeValidate +validateMandatories :: NativeTypeValidate validateMandatories res = case res ^. rattributes . at "rtype" of Nothing -> perror "The rtype parameter is mandatory." Just (PString "SOA") -> foldM (flip mandatory) res ["nsname", "email", "serial", "slave_refresh", "slave_retry", "slave_expiration", "min_ttl"] diff --git a/Puppet/PP.hs b/Puppet/PP.hs --- a/Puppet/PP.hs +++ b/Puppet/PP.hs @@ -1,10 +1,10 @@ module Puppet.PP - ( module Text.PrettyPrint.ANSI.Leijen - , ttext + ( ttext , tshow - , dq , pshow , displayNocolor + -- * Re-exports + , module Text.PrettyPrint.ANSI.Leijen ) where import Text.PrettyPrint.ANSI.Leijen hiding ((<>)) @@ -16,9 +16,6 @@ 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) "" @@ -32,5 +29,3 @@ dropEffects (SText v t d) = SText v t (dropEffects d) dropEffects (SChar c d) = SChar c (dropEffects d) dropEffects x = x - - diff --git a/Puppet/Parser.hs b/Puppet/Parser.hs --- a/Puppet/Parser.hs +++ b/Puppet/Parser.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} @@ -15,28 +14,28 @@ import qualified Data.HashSet as HS import qualified Data.Maybe.Strict as S import qualified Data.Foldable as F -import Data.Tuple.Strict hiding (fst,zip) -import Text.Regex.PCRE.ByteString.Utils +import Data.Tuple.Strict hiding (fst,zip) +import Text.Regex.PCRE.ByteString.Utils -import Data.Char -import Control.Monad -import Control.Applicative -import Control.Lens hiding (noneOf) +import Data.Char +import Control.Monad +import Control.Applicative +import Control.Lens hiding (noneOf) -import Puppet.Parser.Types -import Puppet.Utils +import Puppet.Parser.Types +import Puppet.Utils -import Text.Parsec.Expr -import Text.Parser.Token hiding (stringLiteral') -import Text.Parser.Combinators -import Text.Parser.Char -import Text.Parsec.Pos (SourcePos,SourceName) -import Text.Parser.LookAhead -import Text.Parser.Token.Highlight -import Text.Parsec.Error (ParseError) +import Data.Scientific +import Text.Parsec.Error (ParseError) +import Text.Parsec.Expr +import Text.Parsec.Pos (SourcePos,SourceName) import qualified Text.Parsec.Prim as PP -import Text.Parsec.Text () -import Data.Scientific +import Text.Parsec.Text () +import Text.Parser.Char +import Text.Parser.Combinators +import Text.Parser.LookAhead +import Text.Parser.Token hiding (stringLiteral') +import Text.Parser.Token.Highlight newtype Parser a = ParserT { unParser :: PP.ParsecT T.Text () Identity a} deriving (Functor, Applicative, Alternative) @@ -65,7 +64,7 @@ <|> (oneOf "*/" >> inComment) variable :: Parser Expression -variable = PValue . UVariableReference <$> variableReference +variable = Terminal . UVariableReference <$> variableReference stringLiteral' :: Parser T.Text stringLiteral' = char '\'' *> interior <* symbolic '\'' @@ -133,24 +132,18 @@ parameterName :: Parser T.Text parameterName = moduleName --- this is not a token ! -inBraces :: Parser T.Text -inBraces = between (char '{') (char '}') (T.pack <$> some (satisfy (/= '}'))) - variableReference :: Parser T.Text variableReference = do void (char '$') - v <- lookAhead anyChar >>= \case - '{' -> inBraces - _ -> variableName + v <- variableName when (v == "string") (fail "The special variable $string must not be used") return v -interpolableString :: Parser (V.Vector UValue) +interpolableString :: Parser (V.Vector Expression) interpolableString = V.fromList <$> between (char '"') (symbolic '"') - ( many (fmap UVariableReference interpolableVariableReference <|> doubleQuotedStringContent <|> fmap (UString . T.singleton) (char '$')) ) + ( many (interpolableVariableReference <|> doubleQuotedStringContent <|> fmap (Terminal . UString . T.singleton) (char '$')) ) where - doubleQuotedStringContent = UString . T.pack . concat <$> + doubleQuotedStringContent = Terminal . UString . T.pack . concat <$> some ((char '\\' *> fmap stringEscape anyChar) <|> some (noneOf "\"\\$")) stringEscape :: Char -> String stringEscape 'n' = "\n" @@ -162,17 +155,23 @@ stringEscape x = ['\\',x] -- this is specialized because we can't be "tokenized" here variableAccept x = isAsciiLower x || isAsciiUpper x || isDigit x || x == '_' - interpolableVariableReference = try $ do - void (char '$') - v <- lookAhead anyChar >>= \case - '{' -> inBraces - -- This is not as robust as the "qualif" - -- implementation, but considerably shorter. - -- - -- This needs refactoring. - _ -> T.pack . concat <$> some (string "::" <|> some (satisfy variableAccept)) + rvariableName = do + v <- T.pack . concat <$> some (string "::" <|> some (satisfy variableAccept)) when (v == "string") (fail "The special variable $string must not be used") return v + rvariable = Terminal . UVariableReference <$> rvariableName + simpleIndexing = Lookup <$> rvariable <*> between (symbolic '[') (symbolic ']') expression + interpolableVariableReference = try $ do + void (char '$') + lookAhead anyChar >>= \c -> case c of + '{' -> between (symbolic '{') (char '}') ( try simpleIndexing + <|> rvariable + ) + -- This is not as robust as the "qualif" + -- implementation, but considerably shorter. + -- + -- This needs refactoring. + _ -> rvariable regexp :: Parser T.Text regexp = do @@ -205,7 +204,7 @@ (restype, resnames) <- resourceReferenceRaw return $ UResourceReference restype $ case resnames of [x] -> x - _ -> PValue (array resnames) + _ -> Terminal (array resnames) bareword :: Parser T.Text bareword = identl (satisfy isAsciiLower) (satisfy acceptable) "Bare word" @@ -219,7 +218,7 @@ -- 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 A") `sep` comma + let argsc sep e = (fmap (Terminal . UString) (qualif1 className) <|> e "Function argument A") `sep` comma terminalF = terminalG (fail "function hack") expressionF = ParserT (buildExpressionParser expressionTable (unParser (token terminalF)) "function expression") withparens = parens (argsc sepEndBy expression) @@ -237,36 +236,34 @@ literalValue :: Parser UValue literalValue = token (fmap UString stringLiteral' <|> fmap UString bareword <|> fmap UNumber numericalvalue "Literal Value") where - numericalvalue = integerOrDouble >>= \case + numericalvalue = integerOrDouble >>= \i -> case i of Left x -> return (fromIntegral x) Right y -> return (fromFloatDigits 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 + <|> fmap (Terminal . UInterpolable) interpolableString + <|> (reserved "undef" *> return (Terminal UUndef)) + <|> fmap (Terminal . URegexp) termRegexp <|> variable - <|> fmap PValue puppetArray - <|> fmap PValue puppetHash - <|> fmap (PValue . UBoolean) puppetBool - <|> fmap PValue resourceReference + <|> fmap Terminal puppetArray + <|> fmap Terminal puppetHash + <|> fmap (Terminal . UBoolean) puppetBool + <|> fmap Terminal resourceReference <|> g - <|> fmap PValue literalValue + <|> fmap Terminal literalValue -compileRegexp :: T.Text -> Parser Regex +compileRegexp :: T.Text -> Parser CompRegex compileRegexp p = case compile' compBlank execBlank (T.encodeUtf8 p) of - Right r -> return r + Right r -> return $ CompRegex p 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 +termRegexp :: Parser CompRegex +termRegexp = regexp >>= compileRegexp terminal :: Parser Expression -terminal = terminalG (fmap PValue (fmap UHFunctionCall (try hfunctionCall) <|> try functionCall)) +terminal = terminalG (fmap Terminal (fmap UHFunctionCall (try hfunctionCall) <|> try functionCall)) expression :: Parser Expression expression = condExpression @@ -281,7 +278,7 @@ <|> fmap UBoolean puppetBool <|> literalValue <|> fmap UInterpolable interpolableString - <|> termRegexp) + <|> (URegexp <$> termRegexp)) void $ symbol "=>" e <- expression return (c :!: e) @@ -327,9 +324,9 @@ reserved' = unParser . reserved stringExpression :: Parser Expression -stringExpression = fmap (PValue . UInterpolable) interpolableString <|> (reserved "undef" *> return (PValue UUndef)) <|> fmap (PValue . UBoolean) puppetBool <|> variable <|> fmap PValue literalValue +stringExpression = fmap (Terminal . UInterpolable) interpolableString <|> (reserved "undef" *> return (Terminal UUndef)) <|> fmap (Terminal . UBoolean) puppetBool <|> variable <|> fmap Terminal literalValue -variableAssignment :: Parser [Statement] +variableAssignment :: Parser VarAss variableAssignment = do p <- getPosition v <- variableReference @@ -337,23 +334,21 @@ e <- expression when (T.all isDigit v) (fail "Can't assign fully numeric variables") pe <- getPosition - return [VariableAssignment v e (p :!: pe)] + return (VarAss v e (p :!: pe)) -nodeStmt :: Parser [Statement] +nodeStmt :: Parser [Nd] 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 ?" - toString (UString s) = s + let toString (UString s) = s toString (UNumber n) = scientific2text n toString _ = error "Can't happen at nodeStmt" nodename = (reserved "default" >> return NodeDefault) <|> fmap (NodeName . toString) literalValue - ns <- ((termRegexp >>= nm) <|> nodename) `sepBy1` comma + ns <- (fmap NodeMatch termRegexp <|> 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] + return [Nd n st inheritance (p :!: pe) | n <- ns] puppetClassParameters :: Parser (V.Vector (Pair T.Text (S.Maybe Expression))) puppetClassParameters = V.fromList <$> parens (var `sepEndBy` comma) @@ -365,7 +360,7 @@ <$> variableReference <*> (toStrictMaybe <$> optional (symbolic '=' *> expression)) -defineStmt :: Parser [Statement] +defineStmt :: Parser DefineDec defineStmt = do p <- getPosition reserved "define" @@ -374,20 +369,20 @@ params <- option V.empty puppetClassParameters st <- braces statementList pe <- getPosition - return [DefineDeclaration name params st (p :!: pe)] + return (DefineDec name params st (p :!: pe)) puppetIfStyleCondition :: Parser (Pair Expression (V.Vector Statement)) puppetIfStyleCondition = (:!:) <$> expression <*> braces statementList -unlessCondition :: Parser [Statement] +unlessCondition :: Parser CondStatement unlessCondition = do p <- getPosition reserved "unless" (cond :!: stmts) <- puppetIfStyleCondition pe <- getPosition - return [ConditionalStatement (V.singleton (Not cond :!: stmts)) (p :!: pe)] + return (CondStatement (V.singleton (Not cond :!: stmts)) (p :!: pe)) -ifCondition :: Parser [Statement] +ifCondition :: Parser CondStatement ifCondition = do p <- getPosition reserved "if" @@ -396,22 +391,22 @@ elsecond <- option V.empty (reserved "else" *> braces statementList) let ec = if V.null elsecond then [] - else [PValue (UBoolean True) :!: elsecond] + else [Terminal (UBoolean True) :!: elsecond] pe <- getPosition - return [ ConditionalStatement (V.fromList (maincond : others ++ ec)) (p :!: pe) ] + return (CondStatement (V.fromList (maincond : others ++ ec)) (p :!: pe)) -caseCondition :: Parser [Statement] +caseCondition :: Parser CondStatement caseCondition = do let puppetRegexpCase = do reg <- termRegexp void $ symbolic ':' stmts <- braces statementList - return [ (PValue reg, stmts) ] + return [ (Terminal (URegexp reg), stmts) ] defaultCase = do try (reserved "default") void $ symbolic ':' stmts <- braces statementList - return [ (PValue (UBoolean True), stmts) ] + return [ (Terminal (UBoolean True), stmts) ] puppetCase = do compares <- expression `sepBy1` comma void $ symbolic ':' @@ -419,15 +414,15 @@ return $ map (,stmts) compares condsToExpression e (x, stmts) = f x :!: stmts where f = case x of - (PValue (UBoolean _)) -> id - (PValue (URegexp _ _)) -> RegexMatch e + (Terminal (UBoolean _))-> id + (Terminal (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) ] + return (CondStatement (V.fromList (map (condsToExpression expr1) (concat condlist))) (p :!: pe) ) data OperatorChain a = OperatorChain a LinkType (OperatorChain a) | EndOfChain a @@ -457,36 +452,7 @@ Just o' -> OperatorChain g o' <$> parseRelationships p Nothing -> pure (EndOfChain g) -statementRelationships :: Parser [Statement] -> Parser [Statement] -statementRelationships p = do - rels <- parseRelationships p - let relations = do - (g1, g2, lt) <- zipChain rels - ResourceDeclaration rt1 rn1 _ _ (_ :!: pe1) <- g1 - ResourceDeclaration rt2 rn2 _ _ (ps2 :!: _) <- g2 - return (Dependency (rt1 :!: rn1) (rt2 :!: rn2) lt (pe1 :!: ps2)) - return $ mconcat (F.toList rels) <> relations - -startDepChains :: Position -> T.Text -> [Expression] -> Parser [Statement] -startDepChains p restype resnames = do - d <- depOperator - groups <- zipChain . OperatorChain (restype, resnames) d <$> parseRelationships resourceReferenceRaw - pe <- getPosition - return $ do - ((rt, rns), (dt, dns), lt) <- groups - rn <- rns - dn <- dns - return (Dependency (rt :!: rn) (dt :!: dn) lt (p :!: pe)) - -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 - -resourceGroup :: Parser [Statement] -resourceGroup = statementRelationships resourceGroup' - -resourceGroup' :: Parser [Statement] +resourceGroup' :: Parser [ResDec] resourceGroup' = do let resourceName = token stringExpression resourceDeclaration = do @@ -505,7 +471,7 @@ "@" -> return Virtual "@@" -> return Exported _ -> fail "Invalid virtuality" - return [ ResourceDeclaration rtype rname conts virtuality pos | (rname, conts, pos) <- concat x ] + return [ ResDec rtype rname conts virtuality pos | (rname, conts, pos) <- concat x ] assignment :: Parser (Pair T.Text Expression) assignment = (:!:) <$> bw <*> (symbol "=>" *> expression) @@ -513,19 +479,6 @@ 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 <- 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 @@ -541,7 +494,7 @@ term <- stringExpression return (opr attrib term) -resourceCollection :: Position -> T.Text -> Parser [Statement] +resourceCollection :: Position -> T.Text -> Parser RColl resourceCollection p restype = do openchev <- some (char '<') when (length openchev > 2) (fail "Too many brackets") @@ -555,71 +508,118 @@ then Collector else ExportedCollector pe <- getPosition - return [ ResourceCollection collectortype restype e (V.fromList overrides) (p :!: pe) ] + return (RColl collectortype restype e (V.fromList overrides) (p :!: pe) ) -classDefinition :: Parser [Statement] +classDefinition :: Parser ClassDecl classDefinition = do p <- getPosition reserved "class" - x <- ClassDeclaration <$> className - <*> option V.empty puppetClassParameters - <*> option S.Nothing (fmap S.Just (reserved "inherits" *> className)) - <*> braces statementList - <*> ( (p :!:) <$> getPosition ) - return [x] + ClassDecl <$> className + <*> option V.empty puppetClassParameters + <*> option S.Nothing (fmap S.Just (reserved "inherits" *> className)) + <*> braces statementList + <*> ( (p :!:) <$> getPosition ) -mainFunctionCall :: Parser [Statement] +mainFunctionCall :: Parser MFC mainFunctionCall = do p <- getPosition (fname, args) <- genFunctionCall True pe <- getPosition - return [ MainFunctionCall fname args (p :!: pe) ] - -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" + return (MFC fname args (p :!: pe)) -mainHFunctionCall :: Parser [Statement] +mainHFunctionCall :: Parser SFC mainHFunctionCall = do p <- getPosition fc <- try hfunctionCall pe <- getPosition - return [SHFunctionCall fc (p :!: pe)] + return (SFC fc (p :!: pe)) -dotCall :: Parser [Statement] +dotCall :: Parser SFC dotCall = do p <- getPosition ex <- expression pe <- getPosition hf <- case ex of - FunctionApplication e (PValue (UHFunctionCall hf)) -> do + FunctionApplication e (Terminal (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 + Terminal (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)] + return (SFC hf (p :!: pe)) +data ChainableStuff = ChainResColl RColl + | ChainResDecl ResDec + | ChainResRefr T.Text [Expression] PPosition + +resourceDefaults :: Parser DefaultDec +resourceDefaults = do + p <- getPosition + rnd <- resourceNameRef + let assignmentList = V.fromList <$> assignment `sepEndBy1` comma + asl <- braces assignmentList + pe <- getPosition + return (DefaultDec rnd asl (p :!: pe)) + +resourceOverride :: Parser [ResOver] +resourceOverride = do + p <- getPosition + restype <- resourceNameRef + names <- brackets (expression `sepBy1` comma) "Resource reference values" + assignments <- V.fromList <$> braces (assignment `sepEndBy` comma) + pe <- getPosition + return [ ResOver restype n assignments (p :!: pe) | n <- names ] + +extractResRef :: ChainableStuff -> [(T.Text, Expression, PPosition)] +extractResRef (ChainResColl _) = [] +extractResRef (ChainResDecl (ResDec rt rn _ _ pp)) = [(rt,rn,pp)] +extractResRef (ChainResRefr rt rns pp) = [(rt,rn,pp) | rn <- rns] + +extractChainStatement :: ChainableStuff -> [Statement] +extractChainStatement (ChainResColl r) = [ResourceCollection r] +extractChainStatement (ChainResDecl d) = [ResourceDeclaration d] +extractChainStatement ChainResRefr{} = [] + +chainableStuff :: Parser [Statement] +chainableStuff = do + let withresname = do + p <- getPosition + restype <- resourceNameRef + lookAhead anyChar >>= \x -> case x of + '[' -> do + resnames <- brackets (expression `sepBy1` comma) + pe <- getPosition + pure (ChainResRefr restype resnames (p :!: pe)) + _ -> ChainResColl <$> resourceCollection p restype + chain <- parseRelationships $ pure <$> try withresname <|> map ChainResDecl <$> resourceGroup' + let relations = do + (g1, g2, lt) <- zipChain chain + (rt1, rn1, _ :!: pe1) <- concatMap extractResRef g1 + (rt2, rn2, ps2 :!: _ ) <- concatMap extractResRef g2 + return (Dep (rt1 :!: rn1) (rt2 :!: rn2) lt (pe1 :!: ps2)) + return $ map Dependency relations <> (chain ^.. folded . folded . to extractChainStatement . folded) + statement :: Parser [Statement] statement = - try dotCall - <|> variableAssignment - <|> nodeStmt - <|> defineStmt - <|> unlessCondition - <|> ifCondition - <|> caseCondition + (pure . SHFunctionCall <$> try dotCall) + <|> (pure . VariableAssignment <$> variableAssignment) + <|> (map Node <$> nodeStmt) + <|> (pure . DefineDeclaration <$> defineStmt) + <|> (pure . ConditionalStatement <$> unlessCondition) + <|> (pure . ConditionalStatement <$> ifCondition) + <|> (pure . ConditionalStatement <$> caseCondition) + <|> (pure . DefaultDeclaration <$> try resourceDefaults) + <|> (map ResourceOverride <$> try resourceOverride) + <|> chainableStuff + {- <|> resourceGroup <|> rrGroup - <|> classDefinition - <|> mainHFunctionCall - <|> mainFunctionCall + -} + <|> (pure . ClassDeclaration <$> classDefinition) + <|> (pure . SHFunctionCall <$> mainHFunctionCall) + <|> (pure . MainFunctionCall <$> mainFunctionCall) "Statement" @@ -647,9 +647,9 @@ hp = do vars <- (char '$' *> acceptablePart) `sepBy1` comma case vars of - [a] -> return (BPSingle a) + [a] -> return (BPSingle a) [a,b] -> return (BPPair a b) - _ -> fail "Invalid number of variables between the pipes" + _ -> fail "Invalid number of variables between the pipes" hfunctionCall :: Parser HFunctionCall hfunctionCall = do diff --git a/Puppet/Parser/PrettyPrinter.hs b/Puppet/Parser/PrettyPrinter.hs --- a/Puppet/Parser/PrettyPrinter.hs +++ b/Puppet/Parser/PrettyPrinter.hs @@ -55,7 +55,7 @@ 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 (Terminal a) = pretty a pretty (FunctionApplication e1 e2) = parens (pretty e1) <> text "." <> pretty e2 instance Pretty HigherFuncType where @@ -86,14 +86,15 @@ pretty (UNumber n) = cyan (ttext (scientific2text n)) pretty (UInterpolable v) = char '"' <> hcat (map specific (V.toList v)) <> char '"' where - specific (UString s) = dullcyan (ttext (stringEscape s)) - specific (UVariableReference vr) = dullblue (text "${" <> text (T.unpack vr) <> char '}') + specific (Terminal (UString s)) = dullcyan (ttext (stringEscape s)) + specific (Terminal (UVariableReference vr)) = dullblue (text "${" <> text (T.unpack vr) <> char '}') + specific (Lookup (Terminal (UVariableReference vr)) (Terminal x)) = dullblue (text "${" <> text (T.unpack vr) <> char '[' <> pretty x <> "]}") 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 (URegexp (CompRegex 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 @@ -150,46 +151,46 @@ instance Pretty NodeDesc where pretty NodeDefault = dullmagenta (text "default") pretty (NodeName n) = pretty (UString n) - pretty (NodeMatch m r) = pretty (URegexp m r) + pretty (NodeMatch r) = pretty (URegexp r) instance Pretty Statement where - pretty (SHFunctionCall c p) = pretty c <+> showPPos p - pretty (ConditionalStatement conds p) + pretty (SHFunctionCall (SFC c p)) = pretty c <+> showPPos p + pretty (ConditionalStatement (CondStatement 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 (Terminal (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 '}' + pretty (MainFunctionCall (MFC funcname args p)) = showFunc funcname args <+> showPPos p + pretty (DefaultDeclaration (DefaultDec rtype defaults p)) = capitalize rtype <+> nest 2 (char '{' <+> showPPos p <$> showAss defaults) <$> char '}' + pretty (ResourceOverride (ResOver rtype rnames overs p)) = pretty (UResourceReference rtype rnames) <+> nest 2 (char '{' <+> showPPos p <$> showAss overs) <$> char '}' + pretty (ResourceDeclaration (ResDec 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 + pretty (DefineDeclaration (DefineDec cname args stts p)) = dullyellow (text "define") <+> dullgreen (ttext cname) <> showArgs args <+> showPPos p <$> braceStatements stts + pretty (ClassDeclaration (ClassDecl 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 + pretty (VariableAssignment (VarAss a b p)) = dullblue (char '$' <> text (T.unpack a)) <+> char '=' <+> pretty b <+> showPPos p + pretty (Node (Nd 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) lt p) = pretty (UResourceReference st sn) <+> pretty lt <+> pretty (UResourceReference dt dn) <+> showPPos p + pretty (Dependency (Dep (st :!: sn) (dt :!: dn) lt p)) = pretty (UResourceReference st sn) <+> pretty lt <+> 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 + pretty (ResourceCollection (RColl 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 '}' @@ -199,4 +200,3 @@ ppStatements :: V.Vector Statement -> Doc ppStatements = vcat . map pretty . V.toList - diff --git a/Puppet/Parser/Types.hs b/Puppet/Parser/Types.hs --- a/Puppet/Parser/Types.hs +++ b/Puppet/Parser/Types.hs @@ -25,6 +25,7 @@ HFunctionCall(..), HasHFunctionCall(..), BlockParameters(..), + CompRegex(..), CollectorType(..), Virtuality(..), NodeDesc(..), @@ -32,24 +33,39 @@ -- ** Search Expressions SearchExpression(..), -- ** Statements - Statement(..) + Statement(..), + ResDec(..), + DefaultDec(..), + ResOver(..), + CondStatement(..), + ClassDecl(..), + DefineDec(..), + Nd(..), + VarAss(..), + MFC(..), + SFC(..), + RColl(..), + Dep(..) ) where + +import Control.Lens + +import Data.Aeson +import Data.Char (toUpper) +import Data.Hashable +import qualified Data.Maybe.Strict as S +import Data.Scientific +import Data.String import qualified Data.Text as T +import Data.Tuple.Strict import qualified Data.Vector as V -import Data.Hashable -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 Data.String -import Data.Scientific -import Data.Aeson -import Text.Parsec.Pos +import GHC.Generics +import Text.Regex.PCRE.String +import Text.Parsec.Pos + -- | Properly capitalizes resource types capitalizeRT :: T.Text -> T.Text capitalizeRT = T.intercalate "::" . map capitalize' . T.splitOn "::" @@ -91,63 +107,56 @@ | HFReduce | HFFilter | HFSlice - deriving Eq + deriving (Eq, Show) -- | Currently only two types of block parameters are supported, single -- values and pairs. data BlockParameters = BPSingle !T.Text -- ^ @|k|@ | BPPair !T.Text !T.Text -- ^ @|k,v|@ - deriving Eq + deriving (Eq, Show) -- The description of the /higher level function/ call. -data HFunctionCall = HFunctionCall { _hftype :: !HigherFuncType - , _hfexpr :: !(S.Maybe Expression) - , _hfparams :: !BlockParameters - , _hfstatements :: !(V.Vector Statement) - , _hfexpression :: !(S.Maybe Expression) - } - deriving Eq +data HFunctionCall = HFunctionCall + { _hftype :: !HigherFuncType + , _hfexpr :: !(S.Maybe Expression) + , _hfparams :: !BlockParameters + , _hfstatements :: !(V.Vector Statement) + , _hfexpression :: !(S.Maybe Expression) + } deriving (Eq,Show) +data CompRegex = CompRegex !T.Text !Regex +instance Show CompRegex where + show (CompRegex t _) = show t +instance Eq CompRegex where + (CompRegex a _) == (CompRegex b _) = a == b + -- | An unresolved value, typically the parser's output. data UValue = UBoolean !Bool -- ^ Special tokens generated when parsing the @true@ or @false@ literals. | UString !T.Text -- ^ Raw string. - | UInterpolable !(V.Vector UValue) -- ^ A string that might contain variable references. The type should be refined at one point. + | UInterpolable !(V.Vector Expression) -- ^ A string that might contain variable references. The type should be refined at one point. | UUndef -- ^ Special token that is generated when parsing the @undef@ literal. | UResourceReference !T.Text !Expression -- ^ A Resource[reference] | UArray !(V.Vector Expression) | UHash !(V.Vector (Pair Expression Expression)) - | URegexp !T.Text !Regex -- ^ The regular expression compilation is performed during parsing. + | URegexp !CompRegex -- ^ The regular expression compilation is performed during parsing. | UVariableReference !T.Text | UFunctionCall !T.Text !(V.Vector Expression) | UHFunctionCall !HFunctionCall | UNumber Scientific + deriving (Show, Eq) + instance IsString UValue where fromString = UString . T.pack --- The Eq instance is manual, because of the 'Regex' comparison 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) - (==) (UNumber a) (UNumber b) = a == b - (==) _ _ = False - -- | A helper function for writing 'array's. array :: [Expression] -> UValue array = UArray . V.fromList data SelectorCase = SelectorValue UValue | SelectorDefault - deriving (Eq) + deriving (Eq, Show) -- | The 'Expression's data Expression @@ -174,14 +183,14 @@ | Negate !Expression | ConditionalValue !Expression !(V.Vector (Pair SelectorCase Expression)) -- ^ All conditionals are stored in this format. | FunctionApplication !Expression !Expression -- ^ This is for /higher order functions/. - | PValue !UValue - deriving Eq + | Terminal !UValue + deriving (Eq, Show) instance Num Expression where (+) = Addition (-) = Substraction (*) = Multiplication - fromInteger = PValue . UNumber . fromInteger + fromInteger = Terminal . UNumber . fromInteger abs x = ConditionalValue (MoreEqualThan x 0) (V.fromList [SelectorValue (UBoolean True) :!: x, SelectorDefault :!: negate x]) signum x = ConditionalValue (MoreThan x 0) (V.fromList [SelectorValue (UBoolean True) :!: 1, SelectorDefault :!: ConditionalValue (Equal x 0) (V.fromList [SelectorValue (UBoolean True) :!: 0, SelectorDefault :!: (-1)]) @@ -190,10 +199,10 @@ instance Fractional Expression where (/) = Division recip x = 1 / x - fromRational = PValue . UNumber . fromRational + fromRational = Terminal . UNumber . fromRational instance IsString Expression where - fromString = PValue . fromString + fromString = Terminal . fromString data SearchExpression = EqualitySearch !T.Text !Expression @@ -201,10 +210,10 @@ | AndSearch !SearchExpression !SearchExpression | OrSearch !SearchExpression !SearchExpression | AlwaysTrue - deriving Eq + deriving (Eq, Show) data CollectorType = Collector | ExportedCollector - deriving (Eq) + deriving (Eq, Show) -- | Tries to turn an unresolved value into a 'Bool' without any context. toBool :: UValue -> Bool @@ -218,18 +227,12 @@ | Virtual -- ^ Type for virtual resources | Exported -- ^ Type for exported resources | ExportedRealized -- ^ These are resources that are exported AND included in the catalog - deriving (Generic, Eq) + deriving (Generic, Eq, Show) data NodeDesc = NodeName !T.Text - | NodeMatch !T.Text !Regex + | NodeMatch !CompRegex | NodeDefault - -instance Eq NodeDesc where - (==) (NodeName a) (NodeName b) = a == b - (==) NodeDefault NodeDefault = True - (==) (NodeMatch a _) (NodeMatch b _) = a == b - (==) _ _ = False - + deriving (Show, Eq) -- | Relationship link type. data LinkType = RNotify | RRequire | RBefore | RSubscribe deriving(Show, Eq,Generic) @@ -251,22 +254,37 @@ instance ToJSON LinkType where toJSON = String . rel2text +data ResDec = ResDec !T.Text !Expression !(V.Vector (Pair T.Text Expression)) !Virtuality !PPosition deriving (Eq, Show) +data DefaultDec = DefaultDec !T.Text !(V.Vector (Pair T.Text Expression)) !PPosition deriving (Eq, Show) +data ResOver = ResOver !T.Text !Expression !(V.Vector (Pair T.Text Expression)) !PPosition deriving (Eq, Show) +-- | All types of conditional statements are stored that way (@case@, @if@, etc.) +data CondStatement = CondStatement !(V.Vector (Pair Expression (V.Vector Statement))) !PPosition deriving (Eq, Show) +data ClassDecl = ClassDecl !T.Text !(V.Vector (Pair T.Text (S.Maybe Expression))) !(S.Maybe T.Text) !(V.Vector Statement) !PPosition deriving (Eq, Show) +data DefineDec = DefineDec !T.Text !(V.Vector (Pair T.Text (S.Maybe Expression))) !(V.Vector Statement) !PPosition deriving (Eq, Show) +data Nd = Nd !NodeDesc !(V.Vector Statement) !(S.Maybe NodeDesc) !PPosition deriving (Eq, Show) +data VarAss = VarAss !T.Text !Expression !PPosition deriving (Eq, Show) +data MFC = MFC !T.Text !(V.Vector Expression) !PPosition deriving (Eq, Show) +-- | /Higher order function/ call. +data SFC = SFC !HFunctionCall !PPosition deriving (Eq, Show) +-- | For all types of collectors. +data RColl = RColl !CollectorType !T.Text !SearchExpression !(V.Vector (Pair T.Text Expression)) !PPosition deriving (Eq, Show) +data Dep = Dep !(Pair T.Text Expression) !(Pair T.Text Expression) !LinkType !PPosition deriving (Eq, Show) + -- | All the possible statements 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 -- ^ All types of conditional statements are stored that way (@case@, @if@, etc.) - | 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 -- ^ /Higher order function/ call. - | ResourceCollection !CollectorType !T.Text !SearchExpression !(V.Vector (Pair T.Text Expression)) !PPosition -- ^ For all types of collectors. - | Dependency !(Pair T.Text Expression) !(Pair T.Text Expression) !LinkType !PPosition + = ResourceDeclaration !ResDec + | DefaultDeclaration !DefaultDec + | ResourceOverride !ResOver + | ConditionalStatement !CondStatement + | ClassDeclaration !ClassDecl + | DefineDeclaration !DefineDec + | Node !Nd + | VariableAssignment !VarAss + | MainFunctionCall !MFC + | SHFunctionCall !SFC + | ResourceCollection !RColl + | Dependency !Dep | TopContainer !(V.Vector Statement) !Statement -- ^ This is a special statement that is used to include the expressions that are top level. This is certainly buggy, but probably just like the original implementation. - deriving Eq + deriving (Eq, Show) makeClassy ''HFunctionCall - diff --git a/Puppet/Preferences.hs b/Puppet/Preferences.hs --- a/Puppet/Preferences.hs +++ b/Puppet/Preferences.hs @@ -2,7 +2,11 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -module Puppet.Preferences where +module Puppet.Preferences ( + setupPreferences + , HasPreferences(..) + , Preferences(Preferences) +) where import Puppet.Utils import Puppet.Interpreter.Types @@ -22,7 +26,7 @@ , _modulesPath :: FilePath -- ^ The path to the modules. , _templatesPath :: FilePath -- ^ The path to the template. , _prefPDB :: PuppetDBAPI m - , _natTypes :: Container PuppetTypeMethods -- ^ The list of native types. + , _natTypes :: Container NativeTypeMethods -- ^ The list of native types. , _prefExtFuncs :: Container ( [PValue] -> InterpreterMonad PValue ) , _hieraPath :: Maybe FilePath , _ignoredmodules :: HS.HashSet T.Text -- ^ The set of ignored modules @@ -39,3 +43,10 @@ typenames <- fmap (map takeBaseName) (getFiles (T.pack modulesdir) "lib/puppet/type" ".rb") let loadedTypes = HM.fromList (map defaulttype typenames) return $ Preferences manifestdir modulesdir templatedir dummyPuppetDB (baseNativeTypes `HM.union` loadedTypes) (stdlibFunctions) (Just (basedir <> "/hiera.yaml")) mempty + +-- | Setup preferences from external/custom params +-- k is set through lenses (ie: hieraPath.~mypath) +setupPreferences :: FilePath -> (Preferences IO -> Preferences IO) -> IO (Preferences IO) +setupPreferences basedir k = + -- use lens composition + fmap k (genPreferences basedir) diff --git a/Puppet/Stdlib.hs b/Puppet/Stdlib.hs --- a/Puppet/Stdlib.hs +++ b/Puppet/Stdlib.hs @@ -44,8 +44,10 @@ , singleArgument "is_array" isArray , singleArgument "is_domain_name" isDomainName , singleArgument "is_integer" isInteger + , singleArgument "is_bool" isBool , singleArgument "is_hash" isHash , singleArgument "is_string" isString + , ("join", puppetJoin) , singleArgument "keys" keys , ("has_key", hasKey) , ("lstrip", stringArrayFunction T.stripStart) @@ -179,7 +181,7 @@ deleteUndefValues x = throwPosError ("delete_undef_values(): Expects an Array or a Hash, not" <+> pretty x) _empty :: PValue -> InterpreterMonad PValue -_empty = return . PBoolean . flip elem [PUndef, PString "", PString "undef", PArray V.empty, PHash HM.empty] +_empty = return . PBoolean . flip elem [PUndef, PString "", PString "undef", PArray V.empty, PHash HM.empty] flatten :: PValue -> InterpreterMonad PValue flatten r@(PArray _) = return $ PArray (flatten' r) @@ -232,6 +234,16 @@ (Just _, _) -> True _ -> False +isBool :: PValue -> InterpreterMonad PValue +isBool = return . PBoolean . has _PBoolean + +puppetJoin :: [PValue] -> InterpreterMonad PValue +puppetJoin [PArray rr, PString interc] = do + rrt <- mapM resolvePValueString (V.toList rr) + return (PString (T.intercalate interc rrt)) +puppetJoin [_,_] = throwPosError "join(): expected an array of strings, and a string" +puppetJoin _ = throwPosError "join(): expected two arguments" + 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) @@ -241,7 +253,7 @@ k' <- resolvePValueString k return (PBoolean (has (ix k') h)) hasKey [a, _] = throwPosError ("has_key(): expected a Hash, not" <+> pretty a) -hasKey _ = throwPosError ("has_key(): expected two arguments.") +hasKey _ = throwPosError "has_key(): expected two arguments." merge :: [PValue] -> InterpreterMonad PValue merge [PHash a, PHash b] = return (PHash (b `HM.union` a)) diff --git a/Puppet/Testing.hs b/Puppet/Testing.hs --- a/Puppet/Testing.hs +++ b/Puppet/Testing.hs @@ -200,8 +200,8 @@ -> IO (T.Text -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))) testingDaemon pdb pdir allFacts = do LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel LOG.WARNING) - prefs <- genPreferences pdir - q <- initDaemon (prefs { _prefPDB = pdb }) + prefs <- setupPreferences pdir (prefPDB.~pdb) + q <- initDaemon prefs return (\nodname -> allFacts nodname >>= _dGetCatalog q nodname) -- | A default testing daemon. @@ -211,4 +211,3 @@ S.Left x -> error (show (getError x)) S.Right y -> return y testingDaemon pdb pdir (flip puppetDBFacts pdb) - diff --git a/PuppetDB/TestDB.hs b/PuppetDB/TestDB.hs --- a/PuppetDB/TestDB.hs +++ b/PuppetDB/TestDB.hs @@ -23,10 +23,11 @@ import Puppet.PP hiding ((<$>)) import Puppet.Lens -data DBContent = DBContent { _dbcontentResources :: Container WireCatalog - , _dbcontentFacts :: Container Facts - , _dbcontentBackingFile :: Maybe FilePath - } +data DBContent = DBContent + { _dbcontentResources :: Container WireCatalog + , _dbcontentFacts :: Container Facts + , _dbcontentBackingFile :: Maybe FilePath + } makeFields ''DBContent type DB = TVar DBContent diff --git a/README.adoc b/README.adoc new file mode 100644 --- /dev/null +++ b/README.adoc @@ -0,0 +1,138 @@ += Language-puppet + +A library to work with Puppet manifests, test them and eventually replace everything ruby. + +.Basic usage: +``` +puppetresources -p /where/your/puppet/files/are -o node.name.com +``` + +.Easy build instructions: +``` +cd language-puppet +cabal update +cabal sandbox init +cabal install -j -p +``` + +There are also http://lpuppet.banquise.net/download/[binary packages available] . + +== Puppetresources + +The `puppetresources` command is a command line utility that let you interactively compute catalogs on your local computer. It will then display them on screen, in a nice, +user-friendly colored fashion. It is much faster than its ruby counterpart, and has been designed for giving assistance to the Puppet catalog writer. Here is a list of command line +arguments : + +`-p` or `--puppetdir`:: + +This is the only mandatory argument. It accepts a directory or file path as the argument. In the absence of `-o`, it will parse and display the puppet file given as a parameter. +With `-o` it must point to the base of the puppet directory (the directory that contains the `modules` and `manifests` directories). + +`-o` or `--node`:: + +This let you specify the name of the node you wish to compute the catalog for. ++ +If you use `allnodes` as the node name, it will compute the catalogs for all nodes that are specified in `site.pp` (this will not work for regexp-specified or the default nodes). This is useful +for writing automated tests, to check a change didn't break something. ++ +If you use `deadcode` as the node name, it will also compute the catalogs for all nodes, but will display the list of puppet files that have not been used, and that might be +deprecated. ++ +You might want to run the program with `+RTS -N` with those two modes. + +`-t` or `--type`:: + +Filters the resources of the resulting catalog by type, but specifying a regular expression. Only the resources whose types match the submitted regexp will be displayed. + +`-n` or `--name`:: + +Filters the resources of the resulting catalog by name, but specifying a regular expression. Only the resources whose names match the submitted regexp will be displayed. + +`-c` or `--showcontent`:: + +If `-n` is the exact name of a file defined in the catalog, this will display its content. This is mainly useful for debugging templates. + +`--loglevel` or `-v`:: + +Expects a log level. Possible values are : DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY. + +`--pdburl`:: + +Expects the url of a live PuppetDB. + +`--pdbfile`:: + +Expects a path to a *fake* PuppetDB, represented as a YAML file on disk. This option is pretty slow but can be invaluable to test exported resources tricks. + +`--hiera`:: + +Expects the path to the `hiera.yaml` file. + +`--ignoremodules`:: + +Expects a list of comma-separated modules. The interpreter will not try to evaluate the defined types and classes from this module. This is useful for using modules that use bad +practices forbidden by `puppetresources`. + +`--nousergrouptest`:: + +By default, `puppetresources` will check that all users and groups referenced by `cron`, `file`, etc. types are defined somewhere in the catalog (except for a list of widely +available users, such as `root`). This flag disables these tests. + +`--commitdb`:: + +When this flag is set, exported resources, catalogs and facts are saved in the PuppetDB. This is useful in conjunction with `--pdbfile`. + +`--checkExported`:: + +When this flag is set, exported resources are saved in the PuppetDB. This is useful in conjunction with `--pdbfile`. + +`-j` or `--JSON`:: + +Displays the catalog as a Puppet-compatible JSON file, that can then be used with `puppet apply`. + +`--facts-override` and `--facts-defaults`:: + +Both options expect a path to a YAML file defining facts. The first option will override the facts that are collected locally, while the second will merely provide default values +for them. + +== pdbQuery + +The `pdbQuery` command is used to work with different implementations of PuppetDB (the official one with its HTTP API, the file-based backend and dummy ones). Its main use is to +export data from production PuppetDB to a file in order to debug some issue with `puppetresources`. Here is a list of command line arguments : + +`-l` or `--location`:: + +The URL of the PuppetDB when working with a remote PuppetDB, a file path when working with the file-based test implementation. + +`-t` or `--pdbtype`:: + +The type of PuppetDB to work with: + +* dummy: a dummy PuppetDB. +* remote: a "real" PuppetDB, accessed by its HTTP API. +* test: a file-based backend emulating a PuppetDB. + +.Commands +`dumpfacts`:: + +Dump all facts, and store them in `/tmp/allfacts.yaml`. + +`nodes`:: + +Dump all nodes + +`snapshot`:: + +Create a test DB from the current DB + +`addfacts`:: + +Adds facts to the test DB for the given node name, if they are not already defined. + +== Unsupported Puppet idioms or features + +puppet functions:: + * the `require` function is not supported (see https://github.com/bartavelle/language-puppet/issues/17[issue #17]) + +custom ruby functions:: +Currently the only way to support your custom ruby functions is to rewrite them in Lua. diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet -version: 1.0.0 +version: 1.0.1 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/ @@ -15,8 +15,11 @@ build-type: Simple cabal-version: >=1.8 +extra-source-files: + CHANGELOG.markdown + README.adoc + Data-Files: - ruby/calcerb.rb ruby/hrubyerb.rb source-repository head @@ -59,6 +62,7 @@ , Paths_language_puppet , Puppet.Manifests , Puppet.NativeTypes.ZoneRecord + , Puppet.NativeTypes.Concat , Puppet.NativeTypes.Cron , Puppet.NativeTypes.Exec , Puppet.NativeTypes.Group @@ -75,46 +79,46 @@ ghc-prof-options: -auto-all -caf-all -- other-modules: build-depends: base >=4.6 && < 4.8 - , hruby >= 0.2.5 && <0.3 + , aeson >= 0.7 && < 0.9 + , ansi-wl-pprint == 0.6.* + , attoparsec >= 0.11 && < 0.13 + , base16-bytestring == 0.1.* , bytestring - , strict-base-types >= 0.2.2 + , case-insensitive == 1.2.* + , containers == 0.5.* + , cryptohash >= 0.10 && < 0.12 + , directory == 1.2.* + , filecache >= 0.2.5 && < 0.3 , hashable == 1.2.* - , unordered-containers == 0.2.* - , text >= 0.11 - , vector == 0.10.* - , parsec == 3.1.* - , mtl == 2.1.* - , lens >= 4 && < 4.4 - , parsers == 0.11.* - , ansi-wl-pprint == 0.6.* - , unix >= 2.6 && < 2.8 - , aeson == 0.7.* - , luautils >= 0.1.3 && < 0.1.4 - , hslua >= 0.3.10 && < 0.4 - , transformers == 0.3.* + , hruby >= 0.2.5 && <0.3 , hslogger == 1.2.* - , time == 1.4.* - , filecache >= 0.2.5 && < 0.3 - , regex-pcre-builtin >= 0.94.4 + , hslua >= 0.3.10 && < 0.4 + , hspec >= 1.9 && < 1.12 + , http-conduit >= 2.1 && < 2.2 + , http-types == 0.8.* + , iconv == 0.4.* + , lens >= 4.4 && < 4.5 + , lens-aeson >= 1.0 + , luautils >= 0.1.3 && < 0.1.4 + , mtl == 2.1.* + , operational + , parsec == 3.1.* + , parsers >= 0.11 && < 0.13 , pcre-utils >= 0.1.4 && < 0.2 , process >= 1.1 && < 1.3 - , iconv == 0.4.* - , http-types == 0.8.* - , http-conduit >= 2.1 && < 2.2 - , attoparsec == 0.11.* - , case-insensitive == 1.2.* - , cryptohash >= 0.10 && < 0.12 - , base16-bytestring == 0.1.* - , containers == 0.5.* + , regex-pcre-builtin >= 0.94.4 + , scientific >= 0.2 && < 0.4 + , split == 0.2.* + , stateWriter >= 0.2.1 && < 0.3 , stm == 2.4.* - , hspec >= 1.9.0 && < 2.0.0 + , strict-base-types >= 0.2.2 + , text >= 0.11 + , time == 1.4.* + , transformers == 0.3.* + , unix >= 2.6 && < 2.8 + , unordered-containers == 0.2.* + , vector == 0.10.* , yaml >= 0.8.8 && < 0.9 - , stateWriter >= 0.2.1 && < 0.3 - , split == 0.2.* - , scientific >= 0.2 && < 0.4 - , directory == 1.2.* - , operational - Test-Suite test-evals hs-source-dirs: tests type: exitcode-stdio-1.0 @@ -163,7 +167,7 @@ extensions: BangPatterns, OverloadedStrings ghc-options: -Wall -rtsopts -threaded -with-rtsopts "-A2M" -eventlog 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==0.8.*,regex-pcre-builtin,lens,aeson,yaml,parallel-io,containers,Glob,hspec >= 1.9 + build-depends: language-puppet,base,text,parsec,vector,ansi-wl-pprint,bytestring,mtl,hslogger,Diff,unordered-containers,strict-base-types,optparse-applicative >=0.11,regex-pcre-builtin,lens,aeson,yaml,parallel-io,containers,Glob,hspec >= 1.9 main-is: PuppetResources.hs executable pdbquery @@ -171,6 +175,5 @@ 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 + build-depends: language-puppet,base,optparse-applicative >= 0.11,text,yaml,bytestring,strict-base-types,lens,unordered-containers,vector main-is: pdbQuery.hs - diff --git a/progs/PuppetResources.hs b/progs/PuppetResources.hs --- a/progs/PuppetResources.hs +++ b/progs/PuppetResources.hs @@ -1,76 +1,154 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} module Main where -import System.IO +import Control.Concurrent.ParallelIO (parallel) +import Control.Lens +import Control.Monad +import Data.Aeson (encode) +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Either (partitionEithers) +import qualified Data.Either.Strict as S import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS +import Data.List (isInfixOf) +import Data.Maybe (mapMaybe) +import Data.Monoid hiding (First) import qualified Data.Set as Set -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 Data.Text.Strict.Lens +import Data.Tuple (swap) import qualified Data.Vector as V -import qualified Data.Either.Strict as S -import Options.Applicative as O hiding ((&)) -import Options.Applicative.Help.Chunk (stringChunk,Chunk(..)) -import Control.Monad -import Text.Regex.PCRE.String -import Data.Text.Strict.Lens -import Data.Aeson (encode) -import Data.Yaml (decodeFileEither) -import Control.Lens as L -import Control.Concurrent.ParallelIO (parallel) -import Data.Maybe (mapMaybe) +import Data.Yaml (decodeFileEither) +import Options.Applicative +import System.Exit (exitFailure, exitSuccess) import qualified System.FilePath.Glob as G -import Data.Either (partitionEithers) -import Data.List (isInfixOf) +import System.IO +import qualified System.Log.Logger as LOG import qualified Test.Hspec.Runner as H -import System.Exit (exitFailure, exitSuccess) -import Data.Tuple (swap) +import qualified Text.Parsec as P +import Text.Regex.PCRE.String -import Facter +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 -import Puppet.Stats +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(ppStatements) +import Puppet.Interpreter.PrettyPrinter() +import PuppetDB.Remote +import PuppetDB.Dummy +import PuppetDB.TestDB +import PuppetDB.Common +import Puppet.Testing +import Puppet.Stats -tshow :: Show a => a -> T.Text -tshow = T.pack . show type QueryFunc = T.Text -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) -checkErrorStrict :: S.Either PrettyError x -> IO x -checkErrorStrict (S.Left rr) = putDoc (getError rr) >> putStrLn "" >> error "error!" -checkErrorStrict (S.Right x) = return x +data Options = Options + { _pdb :: Maybe String + , _showjson :: Bool + , _showContent :: Bool + , _resourceType :: Maybe T.Text + , _resourceName :: Maybe T.Text + , _puppetdir :: FilePath + , _nodename :: Maybe T.Text + , _pdbfile :: Maybe FilePath + , _loglevel :: LOG.Priority + , _hieraFile :: Maybe FilePath + , _factsOverr :: Maybe FilePath + , _factsDefault :: Maybe FilePath + , _commitDB :: Bool + , _checkExport :: Bool + , _nousergrouptest :: Bool + , _ignoredMods :: HS.HashSet T.Text + } deriving (Show) +options :: Parser Options +options = Options + <$> optional (strOption + ( long "pdburl" + <> help "URL of the puppetdb (ie. http://localhost:8080/).")) + <*> switch + ( long "JSON" + <> short 'j' + <> help "Shows the output as a JSON document (useful for full catalog views)") + <*> switch + ( long "showcontent" + <> short 'c' + <> help "When specifying a file resource, only output its content (useful for testing templates)") + <*> optional (T.pack <$> strOption + ( long "type" + <> short 't' + <> help "Filter the output by resource type (accepts a regular expression, ie '^file$')")) + <*> optional (T.pack <$> strOption + ( long "name" + <> short 'n' + <> help "Filter the output by resource name (accepts a regular expression)")) + <*> strOption + ( long "puppetdir" + <> short 'p' + <> help "Puppet directory") + <*> optional (T.pack <$> strOption + ( long "node" + <> short 'o' + <> help "Node name. Using 'allnodes' enables a special mode where all nodes present in site.pp are tried. \ + \ Run with +RTS -N. Using 'deadcode' will do the same, but will print warnings about code that's not being used.")) + <*> optional (strOption + ( long "pdbfile" + <> help "Path to the testing PuppetDB file.")) + <*> option auto + ( long "loglevel" + <> short 'v' + <> help "Values are : DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY" + <> value LOG.WARNING) + <*> optional (strOption + ( long "hiera" + <> help "Path to the Hiera configuration file (default hiera.yaml)" + <> value "hiera.yaml")) + <*> optional (strOption + ( long "facts-override" + <> help "Path to a Yaml file containing a list of 'facts' that will override locally resolved facts")) + <*> optional (strOption + ( long "facts-defaults" + <> help "Path to a Yaml file containing a list of 'facts' that will be used as defaults")) + <*> switch + ( long "commitdb" + <> help "Commit the computed catalogs in the puppetDB") + <*> switch + ( long "checkExported" + <> help "Save exported resources in the puppetDB") + <*> switch + ( long "nousergrouptest" + <> help "Disable the user and group tests") + <*> (HS.fromList . T.splitOn "," . T.pack <$> + strOption + ( long "ignoremodules" + <> help "Specify a comma-separated list of modules to ignore" + <> value "")) + +checkError :: Doc -> S.Either PrettyError a -> IO a +checkError r (S.Left rr) = error (show (red r <> ": " <+> getError rr)) +checkError _ (S.Right x) = return x + {-| 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 IO -> FilePath -> Maybe FilePath -> (Facts -> Facts) -> HS.HashSet T.Text -> IO (QueryFunc, MStats, MStats, MStats) -initializedaemonWithPuppet prio pdbapi puppetdir hierapath overrideFacts ignord = do - LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel prio) - q <- fmap ((prefPDB .~ pdbapi) . (hieraPath .~ hierapath) . (ignoredmodules .~ ignord)) (genPreferences puppetdir) >>= initDaemon - let f ndename = fmap overrideFacts (puppetDBFacts ndename pdbapi) - >>= _dGetCatalog q ndename +initializedaemonWithPuppet loglevel pdbapi puppetdir hiera overrideFacts ignoremod = do + LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel loglevel) + q <- initDaemon =<< setupPreferences puppetdir ((prefPDB.~ pdbapi) . (hieraPath.~ hiera) . (ignoredmodules.~ ignoremod)) + let f node = fmap overrideFacts (puppetDBFacts node pdbapi) >>= _dGetCatalog q node return (f, _dParserStats q, _dCatalogStats q, _dTemplateStats q) parseFile :: FilePath -> IO (Either P.ParseError (V.Vector Statement)) -parseFile fp = fmap (runPParser puppetParser fp) (T.readFile fp) +parseFile = fmap . runPParser puppetParser <*> T.readFile printContent :: T.Text -> FinalCatalog -> IO () printContent filename catalog = @@ -81,24 +159,6 @@ 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 - , _hieraFile :: Maybe FilePath - , _factsFile :: Maybe FilePath - , _factsDef :: Maybe FilePath - , _commitDB :: Bool - , _checkExport :: Bool - , _testusergroups :: Bool - , _ignoredMods :: HS.HashSet T.Text - } deriving Show - prepareForPuppetApply :: WireCatalog -> WireCatalog prepareForPuppetApply w = let res = V.filter (\r -> r ^. rvirtuality == Normal) (w ^. wResources) :: V.Vector Resource @@ -130,74 +190,6 @@ . (wEdges .~ correctEdges) $ w -cmdlineParser :: Parser CommandLine -cmdlineParser = CommandLine <$> optional remotepdb - <*> sj - <*> sc - <*> optional (T.pack <$> rt) - <*> optional (T.pack <$> rn) - <*> pdir - <*> optional nn - <*> optional pdbfile - <*> priority - <*> optional hiera - <*> optional fcts - <*> optional fco - <*> commitdb - <*> checkExported - <*> tug - <*> imods - where - imods = HS.fromList . T.splitOn "," . T.pack <$> - strOption ( long "ignoremodules" - <> help "Specify a comma-separated list of modules to ignore" - <> value "" - ) - tug = switch ( long "nousergrouptest" - <> help "Disable the user and group tests" - ) - commitdb = switch ( long "commitdb" - <> help "Commit the computed catalogs in the puppetDB" - ) - checkExported = switch ( long "checkExported" - <> help "Save exported resources in the puppetDB") - 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. Using 'allnodes' enables a special mode where all nodes present in site.pp are tried. Run with +RTS -N. Using 'deadcode' will do the same, but will print warnings about code that's not being used.") - pdbfile = strOption ( long "pdbfile" - <> help "Path to the testing PuppetDB file.") - hiera = strOption ( long "hiera" - <> help "Path to the Hiera configuration file (default hiera.yaml)" - <> value "hiera.yaml" - ) - priority = option ( long "loglevel" - <> short 'v' - <> help "Values are : DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY" - <> value LOG.WARNING - ) - fcts = strOption ( long "facts-override" - <> help "Path to a Yaml file containing a list of 'facts' that will override locally resolved facts" - ) - fco = strOption ( long "facts-defaults" - <> help "Path to a Yaml file containing a list of 'facts' that will be used as defaults" - ) loadFactsOverrides :: FilePath -> IO Facts loadFactsOverrides fp = decodeFileEither fp >>= \case @@ -222,7 +214,7 @@ putDoc ("The following" <+> int (length parseFailed) <+> "files could not be parsed:" indent 4 (vcat (map (string . show) parseFailed))) putStrLn "" let getSubStatements s@(ResourceDeclaration{}) = [s] - getSubStatements (ConditionalStatement conds _) = conds ^.. traverse . _2 . tgt + getSubStatements (ConditionalStatement (CondStatement conds _)) = conds ^.. traverse . _2 . tgt getSubStatements s@(ClassDeclaration{}) = extractPrism s getSubStatements s@(DefineDeclaration{}) = extractPrism s getSubStatements s@(Node{}) = extractPrism s @@ -230,10 +222,10 @@ getSubStatements (TopContainer v s) = getSubStatements s ++ v ^.. tgt getSubStatements _ = [] tgt = folded . to getSubStatements . folded - extractPrism s = s ^.. _Statements . traverse . to getSubStatements . traverse + extractPrism = toListOf (_Statements . traverse . to getSubStatements . traverse) allResources = parseSucceeded ^.. folded . folded . to getSubStatements . folded deadResources = filter isDead allResources - isDead (ResourceDeclaration _ _ _ _ pp) = not $ Set.member pp allpositions + isDead (ResourceDeclaration (ResDec _ _ _ _ pp)) = not $ Set.member pp allpositions isDead _ = True unless (null deadResources) $ do putDoc ("The following" <+> int (length deadResources) <+> "resource declarations are not used:" indent 4 (vcat (map pretty deadResources))) @@ -248,40 +240,38 @@ mappend (Maximum (Just a1)) (Maximum (Just a2)) = Maximum (Just (max a1 a2)) -run :: CommandLine -> IO () -run (CommandLine _ _ _ _ _ f Nothing _ _ _ _ _ _ _ _ _) = parseFile f >>= \case +run :: Options -> IO () +run (Options {_nodename = Nothing, _puppetdir}) = parseFile _puppetdir >>= \case Left rr -> error ("parse error:" ++ show rr) - Right s -> putDoc (vcat (map pretty (V.toList s))) -run c@(CommandLine puppeturl _ _ _ _ puppetdir (Just ndename) mpdbf prio hpath fcts fdef docommit _ _ _) = do - let checkError r (S.Left rr) = error (show (red r <> ":" <+> getError rr)) - checkError _ (S.Right x) = return x - tnodename = T.pack ndename - pdbapi <- case (puppeturl, mpdbf) of + Right s -> putDoc $ ppStatements s + +run cmd@(Options {_nodename = Just node, _pdb, _puppetdir, _pdbfile, _loglevel, _hieraFile, _factsOverr, _factsDefault, _commitDB, _ignoredMods}) = do + pdbapi <- case (_pdb, _pdbfile) 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" - !factsOverrides <- case (fcts, fdef) of + !factsOverrides <- case (_factsOverr, _factsDefault) of (Just _, Just _) -> error "You can't use --facts-override and --facts-defaults at the same time" (Just p, Nothing) -> HM.union `fmap` loadFactsOverrides p (Nothing, Just p) -> (flip HM.union) `fmap` loadFactsOverrides p (Nothing, Nothing) -> return id - (queryfunc,mPStats,mCStats,mTStats) <- initializedaemonWithPuppet prio pdbapi puppetdir hpath factsOverrides (_ignoredMods c) + (queryfunc,mPStats,mCStats,mTStats) <- initializedaemonWithPuppet _loglevel pdbapi _puppetdir _hieraFile factsOverrides _ignoredMods printFunc <- hIsTerminalDevice stdout >>= \isterm -> return $ \x -> if isterm then putDoc x >> putStrLn "" else displayIO stdout (renderCompact x) >> putStrLn "" - let allnodes = tnodename == "allnodes" || deadcode - deadcode = tnodename == "deadcode" + let allnodes = node == "allnodes" || deadcode + deadcode = node == "deadcode" exit <- if allnodes then do - allstmts <- parseFile (puppetdir <> "/manifests/site.pp") >>= \presult -> case presult of + allstmts <- parseFile (_puppetdir <> "/manifests/site.pp") >>= \presult -> case presult of Left rr -> error (show rr) Right x -> return x let topnodes = mapMaybe getNodeName (V.toList allstmts) - getNodeName (Node (NodeName n) _ _ _) = Just n + getNodeName (Node (Nd (NodeName n) _ _ _)) = Just n getNodeName _ = Nothing - cats <- parallel (map (computeCatalogs True queryfunc pdbapi printFunc c) topnodes) + cats <- parallel (map (computeCatalogs True queryfunc pdbapi printFunc cmd) topnodes) -- the the parsing statistics, so that we known which files -- were parsed pStats <- getStats mPStats @@ -292,7 +282,7 @@ testFailures = getSum (cats ^. traverse . _2 . _Just . to (Sum . H.summaryFailures)) allres = (cc ^.. folded . _1 . folded) ++ (cc ^.. folded . _2 . folded) allfiles = Set.fromList $ map T.unpack $ HM.keys pStats - when deadcode $ findDeadCode puppetdir allres allfiles + when deadcode $ findDeadCode _puppetdir allres allfiles -- compute statistics let (parsing, Just (wPName, wPMean)) = worstAndSum pStats (cataloging, Just (wCName, wCMean)) = worstAndSum cStats @@ -307,7 +297,7 @@ putStr ("Tested " ++ show nbnodes ++ " nodes. ") unless (nbnodes == 0) $ do putStrLn (formatDouble parserShare <> "% of total CPU time spent parsing, " <> formatDouble templateShare <> "% spent computing templates") - when (prio <= LOG.INFO) $ do + when (_loglevel <= LOG.INFO) $ do putStrLn ("Slowest template: " <> T.unpack wTName <> ", taking " <> formatDouble wTMean <> "s on average") putStrLn ("Slowest file to parse: " <> T.unpack wPName <> ", taking " <> formatDouble wPMean <> "s on average") putStrLn ("Slowest catalog to compute: " <> T.unpack wCName <> ", taking " <> formatDouble wCMean <> "s on average") @@ -315,62 +305,62 @@ then exitFailure else exitSuccess else do - r <- computeCatalogs False queryfunc pdbapi printFunc c tnodename + r <- computeCatalogs False queryfunc pdbapi printFunc cmd node return $ case snd r of - Just s -> if (H.summaryFailures s > 0) + Just s -> if (H.summaryFailures s > 0) then exitFailure else exitSuccess Nothing -> exitSuccess - when docommit $ void $ commitDB pdbapi + when _commitDB $ void $ commitDB pdbapi exit -computeCatalogs :: Bool -> QueryFunc -> PuppetDBAPI IO -> (Doc -> IO ()) -> CommandLine -> T.Text -> IO (Maybe (FinalCatalog, [Resource]), Maybe H.Summary) -computeCatalogs testOnly queryfunc pdbapi printFunc (CommandLine _ showjson showcontent mrt mrn puppetdir _ _ _ _ _ _ _ checkExported disableugtest _) tnodename = queryfunc tnodename >>= \case - S.Left rr -> do - if testOnly - then putDoc ("Problem with" <+> ttext tnodename <+> ":" <+> getError rr mempty) - else putDoc (getError rr) >> putStrLn "" >> error "error!" - return (Nothing, Just (H.Summary 1 1)) - S.Right (rawcatalog,m,rawexported,knownRes) -> do - let wireCatalog = generateWireCatalog tnodename (rawcatalog <> rawexported) m - when checkExported $ void $ replaceCatalog pdbapi wireCatalog - 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) - testResult <- case (testOnly, showcontent, showjson) of - (True, _, _) -> Just `fmap` testCatalog tnodename puppetdir rawcatalog basicTest - (_, _, True) -> BSL.putStrLn (encode (prepareForPuppetApply wireCatalog)) >> return Nothing - (_, True, _) -> do - catalog <- filterCatalog rawcatalog - 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" - return Nothing - _ -> do - catalog <- filterCatalog rawcatalog - exported <- filterCatalog rawexported - r <- testCatalog tnodename puppetdir rawcatalog (basicTest >> unless disableugtest usersGroupsDefined) - printFunc (pretty (HM.elems catalog)) - unless (HM.null exported) $ do - printFunc (mempty <+> dullyellow "Exported:" <+> mempty) - printFunc (pretty (HM.elems exported)) - return (Just r) - return (Just (rawcatalog <> rawexported, knownRes), testResult) +computeCatalogs :: Bool -> QueryFunc -> PuppetDBAPI IO -> (Doc -> IO ()) -> Options -> T.Text -> IO (Maybe (FinalCatalog, [Resource]), Maybe H.Summary) +computeCatalogs testOnly queryfunc pdbapi printFunc (Options {_showjson, _showContent, _resourceType, _resourceName, _puppetdir, _checkExport, _nousergrouptest}) node = + queryfunc node >>= \case + S.Left rr -> do + if testOnly + then putDoc ("Problem with" <+> ttext node <+> ":" <+> getError rr mempty) + else putDoc (getError rr) >> putStrLn "" >> error "error!" + return (Nothing, Just (H.Summary 1 1)) + S.Right (rawcatalog, m, rawexported, knownRes) -> do + 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 _resourceType (_1 . itype . unpacked) >=> cmpMatch _resourceName (_1 . iname . unpacked) + catalog <- filterCatalog rawcatalog + exported <- filterCatalog rawexported + let wireCatalog = generateWireCatalog node (catalog <> exported ) m + rawWireCatalog = generateWireCatalog node (rawcatalog <> rawexported) m + when _checkExport $ void $ replaceCatalog pdbapi rawWireCatalog + testResult <- case (testOnly, _showContent, _showjson) of + (True, _, _) -> Just `fmap` testCatalog node _puppetdir rawcatalog basicTest + (_, _, True) -> BSL.putStrLn (encode (prepareForPuppetApply wireCatalog)) >> return Nothing + (_, True, _) -> do + unless (_resourceType == Just "file" || _resourceType == Nothing) (error $ "Show content only works for file, not for " ++ show _resourceType) + case _resourceName of + Just f -> printContent f catalog + Nothing -> error "You should supply a resource name when using showcontent" + return Nothing + _ -> do + r <- testCatalog node _puppetdir rawcatalog (basicTest >> unless _nousergrouptest usersGroupsDefined) + printFunc (pretty (HM.elems catalog)) + unless (HM.null exported) $ do + printFunc (mempty <+> dullyellow "Exported:" <+> mempty) + printFunc (pretty (HM.elems exported)) + return (Just r) + return (Just (rawcatalog <> rawexported, knownRes), testResult) main :: IO () -main = execParser pinfo >>= run +main = execParser opts >>= run where - pinfo :: ParserInfo CommandLine - pinfo = ParserInfo (helper <*> cmdlineParser) - True - (stringChunk "A useful program for parsing puppet files, generating and inspecting catalogs") - (stringChunk "puppetresources - a useful utility for dealing with Puppet") - (Chunk Nothing) - 3 True + opts :: ParserInfo Options + opts = info (helper <*> options) + (fullDesc + <> progDesc "A program for parsing puppet files, generating and inspecting catalogs" + <> header "puppetresources - a development tool for Puppet" + <> failureCode 3) diff --git a/progs/pdbQuery.hs b/progs/pdbQuery.hs --- a/progs/pdbQuery.hs +++ b/progs/pdbQuery.hs @@ -1,29 +1,28 @@ {-# LANGUAGE LambdaCase #-} module Main where -import Puppet.Interpreter.Types -import PuppetDB.Common -import PuppetDB.TestDB -import PuppetDB.Remote -import Facter +import Puppet.Interpreter.Types +import PuppetDB.Common +import PuppetDB.TestDB +import PuppetDB.Remote +import Facter -import Options.Applicative as O hiding ((&)) -import Options.Applicative.Help.Chunk (stringChunk,Chunk(..)) -import qualified Data.Text as T -import Data.Monoid -import Data.Yaml hiding (Parser) +import Control.Lens +import Control.Monad (forM_,unless) 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_,unless) +import Data.List (foldl') +import Data.Monoid +import qualified Data.Text as T import qualified Data.Vector as V -import Data.List (foldl') +import Data.Yaml hiding (Parser) +import Options.Applicative as O -data CommandLine = CommandLine { _pdbloc :: Maybe FilePath - , _pdbtype :: PDBType - , _pdbcmd :: Command - } +data Options = Options { _pdbloc :: Maybe FilePath + , _pdbtype :: PDBType + , _pdbcmd :: Command + } data Command = DumpFacts | DumpNodes @@ -33,42 +32,44 @@ | CreateTestDB FilePath | AddFacts T.Text +options :: Parser Options +options = Options + <$> optional (strOption + ( long "location" + <> short 'l' + <> metavar "FILE|URL" + <> help "Location of the PuppetDB, a file for type 'test' or an URL for type 'remote'")) + <*> option auto + ( long "pdbtype" + <> short 't' + <> value PDBTest + <> help "PuppetDB types : test, remote, dummy") + <*> cmd + where + cmd = subparser ( command "dumpfacts" (info (pure DumpFacts)(progDesc "Dump all facts, store in /tmp/allfacts.yaml" <> failureCode 4)) + <> command "editfact" (info factedit (progDesc "Edit a fact corresponding to a node" <> failureCode 7 )) + <> command "dumpres" (info resourcesparser (progDesc "Dump resources" <> failureCode 5)) + <> command "delnode" (info delnodeparser (progDesc "Deactivate node" <> failureCode 6)) + <> command "nodes" (info (pure DumpNodes)(progDesc "Dump all nodes" <> failureCode 8)) + <> command "snapshot" (info createtestdb (progDesc "Create a test DB from the current DB" <> failureCode 10)) + <> command "addfacts" (info addfacts (progDesc "Adds facts to the test DB for the given node name, if they are not already defined" <> failureCode 11)) + ) + factedit :: Parser Command -factedit = EditFact <$> O.argument (Just . T.pack) mempty <*> O.argument (Just . T.pack) mempty +factedit = EditFact <$> O.argument auto mempty <*> O.argument auto mempty resourcesparser :: Parser Command -resourcesparser = DumpResources <$> O.argument (Just . T.pack) mempty +resourcesparser = DumpResources <$> O.argument auto mempty delnodeparser :: Parser Command -delnodeparser = DeactivateNode <$> O.argument (Just . T.pack) mempty +delnodeparser = DeactivateNode <$> O.argument auto mempty createtestdb :: Parser Command -createtestdb = CreateTestDB <$> O.argument Just mempty +createtestdb = CreateTestDB <$> O.argument auto mempty addfacts :: Parser Command -addfacts = AddFacts <$> O.argument (Just . T.pack) mempty +addfacts = AddFacts <$> O.argument auto 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" - ) - ec = Chunk Nothing - cmd = subparser ( command "dumpfacts" (ParserInfo (pure DumpFacts) True (stringChunk "Dump all facts") (stringChunk "Dump all facts, and store them in /tmp/allfacts.yaml") ec 4 True) - <> command "editfact" (ParserInfo factedit True (stringChunk "Edit a fact corresponding to a node") ec ec 7 True) - <> command "dumpres" (ParserInfo resourcesparser True (stringChunk "Dump resources") (stringChunk "Dump resources") ec 5 True) - <> command "delnode" (ParserInfo delnodeparser True (stringChunk "Deactivate node")(stringChunk "Deactivate node") ec 6 True) - <> command "nodes" (ParserInfo (pure DumpNodes) True (stringChunk "Dump all nodes") (stringChunk "Dump all nodes") ec 8 True) - <> command "snapshot" (ParserInfo createtestdb True (stringChunk "Create a test DB from the current DB") ec ec 10 True) - <> command "addfacts" (ParserInfo addfacts True (stringChunk "Adds facts to the test DB for the given node name, if they are not already defined") ec ec 11 True) - ) display :: (Show r, ToJSON a) => String -> S.Either r a -> IO () display s (S.Left rr) = error (s <> " " <> show rr) @@ -78,14 +79,14 @@ checkError s (S.Left rr) = error (s <> " " <> show rr) checkError _ (S.Right a) = return a -run :: CommandLine -> IO () +run :: Options -> 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 (getError r)) + S.Left r -> error (show r) S.Right x -> return x let getOrError s (S.Left rr) = error (s <> " " <> show rr) getOrError _ (S.Right x) = return x @@ -121,7 +122,11 @@ _ -> error "Not yet implemented" main :: IO () -main = execParser pinfo >>= run +main = execParser opts >>= run where - pinfo :: ParserInfo CommandLine - pinfo = ParserInfo (helper <*> cmdlineParser) True (stringChunk "A program to work with PuppetDB implementations") (stringChunk "pdbQuery - work with PuppetDB implementations") (Chunk Nothing) 3 True + opts :: ParserInfo Options + opts = info (helper <*> options) + (fullDesc + <> progDesc "A program to work with PuppetDB implementations" + <> header "pdbQuery - work with PuppetDB implementations" + <> failureCode 3) diff --git a/ruby/calcerb.rb b/ruby/calcerb.rb deleted file mode 100644 --- a/ruby/calcerb.rb +++ /dev/null @@ -1,63 +0,0 @@ -require 'erb' -require 'digest/md5' - -class Scope - def initialize(scpv, ctx) - @mvars = eval(scpv) - @context = ctx - end - - def [](key) - lookupvar(key) - end - - def lookupvar(name) - if name.start_with?("::") - name = name[2..-1] - end - if has_variable?(name) - @mvars[name] - elsif has_variable?("::" + name) - @mvars["::" + name] - elsif has_variable?(@context + "::" + name) - @mvars[@context + "::" + name] - else - throw("Unknown variable " + name) - end - end - - def has_variable?(name) - @mvars.include?(name) - end -end - -class ErbBinding - def initialize(scp, ctx) - @scope = Scope.new(scp, ctx) - end - def get_binding - return binding() - end - def has_variable?(name) - @scope.has_variable?(name.to_s) - end - def method_missing(sname) - name = sname.to_s - if name == 'scope' - @scope - else - @scope.lookupvar(name) - end - end -end - -context = $stdin.readline.chomp! -templatefile = $stdin.readline.chomp! -varscope = $stdin.read -content = IO.read(templatefile) - -nerb = ERB.new(content, nil, "-") -binding = ErbBinding.new(varscope, context).get_binding - -out = nerb.result(binding) -puts out diff --git a/ruby/hrubyerb.rb b/ruby/hrubyerb.rb --- a/ruby/hrubyerb.rb +++ b/ruby/hrubyerb.rb @@ -39,6 +39,36 @@ def to_hash vl('~g~e~t_h~a~s~h~') end + + def function_versioncmp(args) + version_a = args[0] + version_b = args[1] + vre = /[-.]|\d+|[^-.\d]+/ + ax = version_a.scan(vre) + bx = version_b.scan(vre) + + while (ax.length>0 && bx.length>0) + a = ax.shift + b = bx.shift + + if( a == b ) then next + elsif (a == '-' && b == '-') then next + elsif (a == '-') then return -1 + elsif (b == '-') then return 1 + elsif (a == '.' && b == '.') then next + elsif (a == '.' ) then return -1 + elsif (b == '.' ) then return 1 + elsif (a =~ /^\d+$/ && b =~ /^\d+$/) then + if( a =~ /^0/ or b =~ /^0/ ) then + return a.to_s.upcase <=> b.to_s.upcase + end + return a.to_i <=> b.to_i + else + return a.upcase <=> b.upcase + end + end + version_a <=> version_b; + end end class ErbBinding diff --git a/tests/expr.hs b/tests/expr.hs --- a/tests/expr.hs +++ b/tests/expr.hs @@ -1,7 +1,5 @@ module Main where -import Text.PrettyPrint.ANSI.Leijen - import Puppet.Parser import Puppet.Parser.PrettyPrinter() import Puppet.Parser.Types @@ -11,21 +9,26 @@ import qualified Data.Text as T import Control.Applicative import qualified Data.Vector as V +import Control.Arrow (first) testcases :: [(T.Text, Expression)] testcases = [ ("5 + 3 * 2", 5 + 3 * 2) , ("5+2 == 7", Equal (5 + 2) 7) - , ("include(foo::bar)", PValue (UFunctionCall "include" (V.singleton "foo::bar") )) + , ("include(foo::bar)", Terminal (UFunctionCall "include" (V.singleton "foo::bar") )) + , ("$x", Terminal (UVariableReference "x")) + , ("\"${x}\"", Terminal (UInterpolable (V.fromList [Terminal (UVariableReference "x")]))) + , ("\"${x[3]}\"", Terminal (UInterpolable (V.fromList [Lookup (Terminal (UVariableReference "x")) 3]))) + , ("\"${x[$y]}\"", Terminal (UInterpolable (V.fromList [Lookup (Terminal (UVariableReference "x")) (Terminal (UVariableReference "y")) ]))) ] main :: IO () main = do - let testres = map (\(a,b) -> (runPParser (expression <* eof) "tests" a, b)) testcases + let testres = map (first (runPParser (expression <* eof) "tests")) testcases 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)) "") + else Just ("Expected: " ++ show e ++ "\nActual: " ++ show x) bads = mapMaybe isFailure testres unless (null bads) $ do mapM_ putStrLn bads