language-puppet 1.0.0 → 1.0.1
raw patch · 36 files changed
+1689/−1109 lines, 36 filesdep +lens-aesondep ~aesondep ~attoparsecdep ~hspec
Dependencies added: lens-aeson
Dependency ranges changed: aeson, attoparsec, hspec, lens, optparse-applicative, parsers
Files
- CHANGELOG.markdown +331/−0
- Hiera/Server.hs +55/−53
- Puppet/Daemon.hs +34/−42
- Puppet/Interpreter.hs +28/−23
- Puppet/Interpreter/Resolve.hs +9/−11
- Puppet/Interpreter/Types.hs +162/−150
- Puppet/Lens.hs +119/−14
- Puppet/Manifests.hs +6/−6
- Puppet/NativeTypes.hs +26/−21
- Puppet/NativeTypes/Concat.hs +48/−0
- Puppet/NativeTypes/Cron.hs +7/−14
- Puppet/NativeTypes/Exec.hs +4/−12
- Puppet/NativeTypes/File.hs +6/−20
- Puppet/NativeTypes/Group.hs +3/−12
- Puppet/NativeTypes/Helpers.hs +59/−34
- Puppet/NativeTypes/Host.hs +4/−13
- Puppet/NativeTypes/Mount.hs +3/−12
- Puppet/NativeTypes/Package.hs +4/−10
- Puppet/NativeTypes/SshSecure.hs +5/−13
- Puppet/NativeTypes/User.hs +3/−11
- Puppet/NativeTypes/ZoneRecord.hs +4/−11
- Puppet/PP.hs +3/−8
- Puppet/Parser.hs +161/−161
- Puppet/Parser/PrettyPrinter.hs +21/−21
- Puppet/Parser/Types.hs +87/−69
- Puppet/Preferences.hs +13/−2
- Puppet/Stdlib.hs +14/−2
- Puppet/Testing.hs +2/−3
- PuppetDB/TestDB.hs +5/−4
- README.adoc +138/−0
- language-puppet.cabal +41/−38
- progs/PuppetResources.hs +193/−203
- progs/pdbQuery.hs +53/−48
- ruby/calcerb.rb +0/−63
- ruby/hrubyerb.rb +30/−0
- tests/expr.hs +8/−5
+ CHANGELOG.markdown view
@@ -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.
Hiera/Server.hs view
@@ -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
Puppet/Daemon.hs view
@@ -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
Puppet/Interpreter.hs view
@@ -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 []
Puppet/Interpreter/Resolve.hs view
@@ -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)-
Puppet/Interpreter/Types.hs view
@@ -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 <http://docs.puppetlabs.com/puppetdb/1.5/api/wire_format/catalog_format.html>.-data WireCatalog = WireCatalog { _wirecatalogNodename :: !Nodename- , _wirecatalogWVersion :: !T.Text- , _wirecatalogWEdges :: !(V.Vector PuppetEdge)- , _wirecatalogWResources :: !(V.Vector Resource)- , _wirecatalogTransactionUUID :: !T.Text- }+data 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 ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>- , replaceFacts :: [(Nodename, Facts)] -> m (S.Either PrettyError ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>- , deactivateNode :: Nodename -> m (S.Either PrettyError ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>- , getFacts :: Query FactField -> m (S.Either PrettyError [PFactInfo]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>- , getResources :: Query ResourceField -> m (S.Either PrettyError [Resource]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>- , 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 ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>+ , replaceFacts :: [(Nodename, Facts)] -> m (S.Either PrettyError ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>+ , deactivateNode :: Nodename -> m (S.Either PrettyError ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>+ , getFacts :: Query FactField -> m (S.Either PrettyError [PFactInfo]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>+ , getResources :: Query ResourceField -> m (S.Either PrettyError [Resource]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>+ , 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"-
Puppet/Lens.hs view
@@ -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
Puppet/Manifests.hs view
@@ -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
Puppet/NativeTypes.hs view
@@ -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-
+ Puppet/NativeTypes/Concat.hs view
@@ -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])+ ]
Puppet/NativeTypes/Cron.hs view
@@ -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
Puppet/NativeTypes/Exec.hs view
@@ -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
Puppet/NativeTypes/File.hs view
@@ -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://"
Puppet/NativeTypes/Group.hs view
@@ -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-
Puppet/NativeTypes/Helpers.hs view
@@ -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
Puppet/NativeTypes/Host.hs view
@@ -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-
Puppet/NativeTypes/Mount.hs view
@@ -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-
Puppet/NativeTypes/Package.hs view
@@ -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--
Puppet/NativeTypes/SshSecure.hs view
@@ -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-
Puppet/NativeTypes/User.hs view
@@ -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-
Puppet/NativeTypes/ZoneRecord.hs view
@@ -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"]
Puppet/PP.hs view
@@ -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--
Puppet/Parser.hs view
@@ -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
Puppet/Parser/PrettyPrinter.hs view
@@ -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-
Puppet/Parser/Types.hs view
@@ -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-
Puppet/Preferences.hs view
@@ -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)
Puppet/Stdlib.hs view
@@ -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))
Puppet/Testing.hs view
@@ -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)-
PuppetDB/TestDB.hs view
@@ -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
+ README.adoc view
@@ -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.
language-puppet.cabal view
@@ -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-
progs/PuppetResources.hs view
@@ -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)
progs/pdbQuery.hs view
@@ -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)
− ruby/calcerb.rb
@@ -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
ruby/hrubyerb.rb view
@@ -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
tests/expr.hs view
@@ -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