language-puppet 1.3.12.1 → 1.3.13
raw patch · 117 files changed
+9719/−9436 lines, 117 filesdep +filepathdep +neat-interpolationdep +protoludedep ~mtldep ~scientificdep ~servant
Dependencies added: filepath, neat-interpolation, protolude
Dependency ranges changed: mtl, scientific, servant, servant-client
Files
- CHANGELOG +581/−0
- CHANGELOG.markdown +0/−549
- Erb/Compute.hs +0/−232
- Erb/Evaluate.hs +0/−86
- Erb/Parser.hs +0/−182
- Erb/Ruby.hs +0/−57
- Facter.hs +0/−196
- Hiera/Server.hs +0/−234
- Puppet/Daemon.hs +0/−204
- Puppet/Interpreter.hs +0/−945
- Puppet/Interpreter/IO.hs +0/−103
- Puppet/Interpreter/PrettyPrinter.hs +0/−166
- Puppet/Interpreter/Pure.hs +0/−157
- Puppet/Interpreter/Resolve.hs +0/−763
- Puppet/Interpreter/Resolve/Sprintf.hs +0/−145
- Puppet/Interpreter/RubyRandom.hs +0/−118
- Puppet/Interpreter/Types.hs +0/−754
- Puppet/Interpreter/Utils.hs +0/−160
- Puppet/Lens.hs +0/−180
- Puppet/Manifests.hs +0/−63
- Puppet/NativeTypes.hs +0/−58
- Puppet/NativeTypes/Concat.hs +0/−48
- Puppet/NativeTypes/Cron.hs +0/−66
- Puppet/NativeTypes/Exec.hs +0/−38
- Puppet/NativeTypes/File.hs +0/−108
- Puppet/NativeTypes/Group.hs +0/−24
- Puppet/NativeTypes/Helpers.hs +0/−266
- Puppet/NativeTypes/Host.hs +0/−46
- Puppet/NativeTypes/Mount.hs +0/−24
- Puppet/NativeTypes/Notify.hs +0/−15
- Puppet/NativeTypes/Package.hs +0/−110
- Puppet/NativeTypes/SshSecure.hs +0/−33
- Puppet/NativeTypes/User.hs +0/−45
- Puppet/NativeTypes/ZoneRecord.hs +0/−39
- Puppet/OptionalTests.hs +0/−99
- Puppet/PP.hs +0/−31
- Puppet/Parser.hs +0/−735
- Puppet/Parser/PrettyPrinter.hs +0/−239
- Puppet/Parser/Types.hs +0/−401
- Puppet/Parser/Utils.hs +0/−12
- Puppet/Paths.hs +0/−23
- Puppet/Preferences.hs +0/−147
- Puppet/Puppetlabs.hs +0/−125
- Puppet/Stats.hs +0/−64
- Puppet/Stdlib.hs +0/−499
- Puppet/Utils.hs +0/−156
- PuppetDB/Common.hs +0/−57
- PuppetDB/Dummy.hs +0/−18
- PuppetDB/Remote.hs +0/−52
- PuppetDB/TestDB.hs +0/−192
- language-puppet.cabal +19/−12
- progs/PuppetResources.hs +83/−89
- progs/pdbQuery.hs +46/−48
- progs/yera.hs +31/−38
- src/Erb/Compute.hs +228/−0
- src/Erb/Evaluate.hs +91/−0
- src/Erb/Parser.hs +182/−0
- src/Erb/Ruby.hs +58/−0
- src/Facter.hs +198/−0
- src/Hiera/Server.hs +261/−0
- src/Puppet/Daemon.hs +216/−0
- src/Puppet/Interpreter.hs +960/−0
- src/Puppet/Interpreter/IO.hs +118/−0
- src/Puppet/Interpreter/PrettyPrinter.hs +188/−0
- src/Puppet/Interpreter/Pure.hs +166/−0
- src/Puppet/Interpreter/Resolve.hs +800/−0
- src/Puppet/Interpreter/Resolve/Sprintf.hs +143/−0
- src/Puppet/Interpreter/RubyRandom.hs +120/−0
- src/Puppet/Interpreter/Types.hs +787/−0
- src/Puppet/Interpreter/Utils.hs +163/−0
- src/Puppet/Lens.hs +178/−0
- src/Puppet/Manifests.hs +60/−0
- src/Puppet/NativeTypes.hs +59/−0
- src/Puppet/NativeTypes/Concat.hs +49/−0
- src/Puppet/NativeTypes/Cron.hs +66/−0
- src/Puppet/NativeTypes/Exec.hs +40/−0
- src/Puppet/NativeTypes/File.hs +111/−0
- src/Puppet/NativeTypes/Group.hs +25/−0
- src/Puppet/NativeTypes/Helpers.hs +265/−0
- src/Puppet/NativeTypes/Host.hs +48/−0
- src/Puppet/NativeTypes/Mount.hs +25/−0
- src/Puppet/NativeTypes/Notify.hs +15/−0
- src/Puppet/NativeTypes/Package.hs +108/−0
- src/Puppet/NativeTypes/SshSecure.hs +32/−0
- src/Puppet/NativeTypes/User.hs +47/−0
- src/Puppet/NativeTypes/ZoneRecord.hs +38/−0
- src/Puppet/OptionalTests.hs +95/−0
- src/Puppet/PP.hs +32/−0
- src/Puppet/Parser.hs +747/−0
- src/Puppet/Parser/PrettyPrinter.hs +240/−0
- src/Puppet/Parser/Types.hs +394/−0
- src/Puppet/Parser/Utils.hs +12/−0
- src/Puppet/Paths.hs +22/−0
- src/Puppet/Preferences.hs +151/−0
- src/Puppet/Prelude.hs +222/−0
- src/Puppet/Puppetlabs.hs +124/−0
- src/Puppet/Stats.hs +63/−0
- src/Puppet/Stdlib.hs +494/−0
- src/PuppetDB/Common.hs +59/−0
- src/PuppetDB/Dummy.hs +19/−0
- src/PuppetDB/Remote.hs +50/−0
- src/PuppetDB/TestDB.hs +188/−0
- tests/DT/Parser.hs +12/−10
- tests/Function/AssertPrivateSpec.hs +1/−9
- tests/Function/DeleteAtSpec.hs +2/−7
- tests/Function/EachSpec.hs +1/−6
- tests/Function/LookupSpec.hs +29/−0
- tests/Function/MergeSpec.hs +3/−9
- tests/Function/ShellquoteSpec.hs +3/−20
- tests/Function/SizeSpec.hs +1/−11
- tests/Function/SprintfSpec.hs +5/−24
- tests/Helpers.hs +53/−21
- tests/Interpreter/CollectorSpec.hs +8/−11
- tests/Interpreter/IfSpec.hs +3/−6
- tests/InterpreterSpec.hs +10/−17
- tests/Spec.hs +4/−0
- tests/hiera.hs +67/−34
+ CHANGELOG view
@@ -0,0 +1,581 @@+language-puppet (1.3.13) xenial; urgency=medium++ * Support for a "rebasefile" option to make file() calls with absolute files relative to another directory.+ * Fix an infinite loop with fqdn_rand+ * Recognize v5 hiera configuration format+ * Added debian stuff+ * Support for the hiera module layer+ * Support new lookup puppet function++ -- Simon Marechal <simon.marechal@edf.fr> Wed, 13 Dec 2017 14:56:33 +0100++language-puppet (1.3.12.1) xenial; urgency=medium++ * Support for Glob >= 0.9, even for the test suite :)++ -- Simon Marechal <bartavelle@gmail.com> Mon, 09 Oct 2017 15:00:00 +0100++language-puppet (1.3.12) xenial; urgency=medium++ * Support for Glob >= 0.9++ -- Simon Marechal <bartavelle@gmail.com> Mon, 09 Oct 2017 15:00:00 +0100++language-puppet (1.3.11) xenial; urgency=medium++ * Added yera command+ * Minor fixes to the validate_integer function, and to the mount resource+ * Support for the "lookup" command in hiera files+ * Fix Glob compilation problem++ -- Simon Marechal <bartavelle@gmail.com> Sat, 07 Oct 2017 15:00:00 +0100++language-puppet (1.3.10) xenial; urgency=medium++ * Add `sort` stdlib function+ * Remove `SafeProcess` module (fix `ghc-8.2` compilation)+ * Remove `ghc-7.x` support++ -- Simon Marechal <bartavelle@gmail.com> Mon, 28 Aug 2017 15:00:00 +0100++language-puppet (1.3.9) xenial; urgency=medium++ * Moved to megaparsec 6++ -- Simon Marechal <bartavelle@gmail.com> Sun, 30 Jul 2017 15:00:00 +0100++language-puppet (1.3.8.1) xenial; urgency=medium++ * Fix haddocks error (#208)++ -- Simon Marechal <bartavelle@gmail.com> Fri, 21 Jul 2017 15:00:00 +0100++language-puppet (1.3.8) xenial; urgency=medium++ * Add support for calling Functions in Strings (#199)+ * Add $facts hash for Puppet 4 (#198)+ * Initial support for datatype syntax (#206)++ -- Simon Marechal <bartavelle@gmail.com> Thu, 20 Jul 2017 15:00:00 +0100++language-puppet (1.3.7) xenial; urgency=medium++ * Add puppet `sprintf` function+ * Fix scientific2text (#196)++ -- Simon Marechal <bartavelle@gmail.com> Tue, 14 Mar 2017 15:00:00 +0100++language-puppet (1.3.6) xenial; urgency=medium++ * The `defined` function can now test variables+ * Fixed the `delete_at` function, added new tests, TBC+ * Fixed the `ensure_resource` function, so that its second argument can take an array.++ -- Simon Marechal <bartavelle@gmail.com> Mon, 27 Feb 2017 15:00:00 +0100++language-puppet (1.3.5.1) xenial; urgency=medium++ * Version bumps for megaparsec & servant++ -- Simon Marechal <bartavelle@gmail.com> Thu, 02 Feb 2017 15:00:00 +0100++language-puppet (1.3.5) xenial; urgency=medium++ * Ignored packages are not parsed anymore++ -- Simon Marechal <bartavelle@gmail.com> Tue, 31 Jan 2017 15:00:00 +0100++language-puppet (1.3.4.1) xenial; urgency=medium++ * Version bump for the directory dependency++ -- Simon Marechal <bartavelle@gmail.com> Thu, 12 Jan 2017 15:00:00 +0100++language-puppet (1.3.4) xenial; urgency=medium++ * Adds implicit dependencies for some types where users and groups are defined++ -- Simon Marechal <bartavelle@gmail.com> Wed, 14 Dec 2016 15:00:00 +0100++language-puppet (1.3.3) xenial; urgency=medium++ * Rename some pdbquery subcommands+ * Output pdbquery in `json` instead of `yaml`+ * Fix `pdbquery resources NODENAME`+ * Add `pdbquery fact NODENAME`++ -- Simon Marechal <bartavelle@gmail.com> Mon, 05 Dec 2016 15:00:00 +0100++language-puppet (1.3.2.1) xenial; urgency=medium++ * Support for megaparsec 5.1++ -- Simon Marechal <bartavelle@gmail.com> Tue, 04 Oct 2016 15:00:00 +0100++language-puppet (1.3.2) xenial; urgency=medium++ * Add stdlib `validate_integer`+ * Support for servant 0.9++ -- Simon Marechal <bartavelle@gmail.com> Wed, 21 Sep 2016 15:00:00 +0100++language-puppet (1.3.1) xenial; urgency=medium++ * Add `--version` to puppetresources and pdbquery+ * Version bump for some dependencies++ -- Simon Marechal <bartavelle@gmail.com> Wed, 31 Aug 2016 15:00:00 +0100++language-puppet (1.3) xenial; urgency=medium++ * External Lua plugins are not a thing anymore+ * `validate_numeric` function+ * Preliminary implementation of variable captures in regexp matches+ * Ready for GHC 8 and corresponding stackage nightly+ * Fixed a deadlock when template code called the `template` or `inline_template` functions. It just stops now :(+ * `assert_private` function+ * `join_keys_to_values` function+ * Several resource collector misbehaviour+ * Case expressions can now have multiple matchers of any kind as the same selector++ -- Simon Marechal <bartavelle@gmail.com> Mon, 11 Jul 2016 15:00:00 +0100++language-puppet (1.1.5) xenial; urgency=medium++ * Added the `pick_default` function+ * `merge` now works with an arbitrary number of hashes+ * Added the `hash` function+ * puppet native type `file` resource accept selinux parameters+ * Added the `shellquote` function+ * `create_resources` can now create virtual and exported resources+ * puppet native type `file` fix for parameters `sourceselect` and `recurselimit`+ * Hiera array merge now only keeps unique values+ * `merge` now properly priorizes the lastest arguments++ -- Simon Marechal <bartavelle@gmail.com> Tue, 02 Feb 2016 15:00:00 +0100++language-puppet (1.1.4.1) xenial; urgency=medium++ * Support for the new puppet `contain` function+ * Fix parser for search expression (see #132)+ * Fix logger set up (see #136)+ * Fix some regsubst (see #119)+ * Fix the `template` and `inline_template` functions (see #142)+ * Support lookups for expressions used in selector (TODO: arbitrary expression)+ * Fix a ruby 1.8 syntax error+ * Fix a case where resource overrides were not applied to the correct resource+ * Fix a bug where a class value would be incorrectly inferred as having a default value whereas it doesn't+ * Replace `parsec` `megaparsec` (see #138)+ * All resource names are normalized. The leading `::` is ignored (see #140)+ * Add CI using travis+ * Drop support for ghc < 7.10 explicitly++ -- Simon Marechal <bartavelle@gmail.com> Sun, 15 Nov 2015 15:00:00 +0100++language-puppet (1.1.4) xenial; urgency=medium++ * The `regsubst` function now works with arrays.+ * The `file` variable is resolved in templates.+ * Support for `function_x` calls in templates.+ * Expressions such as (-1) are now supported.+ * Selectors recognize the undef token now.+ * Fixed a bug with parsing lines starting with `::`.+ * Sanitize resource names in some missing instances to fix bugs++ -- Simon Marechal <bartavelle@gmail.com> Mon, 07 Sep 2015 15:00:00 +0100++language-puppet (1.1.3) xenial; urgency=medium++ * Support for the `$settings` variables.+ * Support for the `to_yaml` function in templates.+ * Settings can now be altered in the default YAML file.+ * Defaults and overriden facts are now controlled in the YAML file too.++ -- Simon Marechal <bartavelle@gmail.com> Sun, 31 May 2015 15:00:00 +0100++language-puppet (1.1.1.2) xenial; urgency=medium+++ -- Simon Marechal <bartavelle@gmail.com> Tue, 28 Apr 2015 15:00:00 +0100++language-puppet (1.1.1) xenial; urgency=medium++ * Add 'notify' native type+ * Ability to provide defaults via a yaml file for some options+ * Added the 'ensure_packages' and 'ensure_resources' functions+ * Enable 'package' native type (issue #102)+ * Builds against GHC 7.10+ * Even in Permissive mode, don't resolve unknown variable (see #103)+ * Add priority to the logger permissive output (see #106)+ * New hruby version+ * Rename option `--ignoremodules` into `--ignoredmodules`+ * Hiera config interpolation logs decrease from NOTICE to INFO++ -- Simon Marechal <bartavelle@gmail.com> Mon, 20 Apr 2015 15:00:00 +0100++language-puppet (1.1.0) xenial; urgency=medium++ * New `dumpinfos` debug function.+ * The interpreter can now run in a strict or permissive mode.+ * The new `-a` option accepts a comma separated list of nodes for gathering stats.+ * The new `--noextratests` option disable optional tests from `Puppet.OptionalTests`.+ * Implementation of `member()` from stdlib (see issue #100 for details)+ * Exported/virtual custom types are not expanded. This is a huge bug.+ * Class/define parameters that are explicitely set as undefined are now overriden by+ * Empty resource groups are now rejected.+ * An existing resource can now be realized.+ * Hiera config interpolation logs decrease from WARN to NOTICE+ * Remove option `--nousergrouptest`+ * Ease the use of the puppetresources command options. See the README file for changes.++ -- Simon Marechal <bartavelle@gmail.com> Wed, 11 Mar 2015 15:00:00 +0100++language-puppet (1.0.1) xenial; urgency=medium++ * 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)+ * Fix array value extrapolation in string (issue #35)+ * ${var} without quotes will now be rejected by the parser (issue #78)+ * `README` moved to asciidoc (Pierre Radermecker)++ -- Simon Marechal <bartavelle@gmail.com> Thu, 13 Nov 2014 15:00:00 +0100++language-puppet (1.0.0) xenial; urgency=medium++ * Support for Debian distribution detection in facter.+ * Support for the "~>" operator.+ * Support for mixed-case resource references.+ * Added the `grep` function.+ * Better support for --ignoremodules.+ * Fixed parsing of standalone `$` characters in strings.++ -- Simon Marechal <bartavelle@gmail.com> Sun, 31 Aug 2014 15:00:00 +0100++language-puppet (0.14.0) xenial; urgency=medium++ * Overhauled the dependency check system+ * Added an option to skip the user and group checks+ * Added an option to ignore some modules+ * 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.++ -- Simon Marechal <bartavelle@gmail.com> Thu, 12 Jun 2014 15:00:00 +0100++language-puppet (0.13.0) xenial; urgency=medium++ * 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`.+ * 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+ * Fixed associativity priority between `=~` and `and`.++ -- Simon Marechal <bartavelle@gmail.com> Wed, 21 May 2014 15:00:00 +0100++language-puppet (0.12.3) xenial; urgency=medium++ * puppetresources now tests that groups and users are defined before being used++ -- Simon Marechal <bartavelle@gmail.com> Thu, 13 Mar 2014 15:00:00 +0100++language-puppet (0.12.2) xenial; urgency=medium++ * Facts are now dumped in `TestDB` format by `pdbquery`.+ * The `puppetresources` command now has switch controlling the PuppetDB commit and "catalog update".++ -- Simon Marechal <bartavelle@gmail.com> Tue, 18 Feb 2014 15:00:00 +0100++language-puppet (0.12.1) xenial; urgency=medium++ * *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.+ * Fixed dependencies so that builds with GHC 7.8-rc1 work.++ -- Simon Marechal <bartavelle@gmail.com> Mon, 10 Feb 2014 15:00:00 +0100++language-puppet (0.12.0) xenial; urgency=medium++ * Builds against GHC 7.8-rc1.++ -- Simon Marechal <bartavelle@gmail.com> Fri, 07 Feb 2014 15:00:00 +0100++language-puppet (0.11.1) xenial; urgency=medium++ * Fixed build issues with strict-base-types version.++ -- Simon Marechal <bartavelle@gmail.com> Fri, 31 Jan 2014 15:00:00 +0100++language-puppet (0.11.0) xenial; urgency=medium++ * 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++ -- Simon Marechal <bartavelle@gmail.com> Thu, 30 Jan 2014 15:00:00 +0100++language-puppet (0.10.6) xenial; urgency=medium++ * New all nodes testing for puppetresources.+ * Added some uname related facts.+ * Added some lenses and prisms.+ * Parsing function calls without parens at the expression level is not+ * 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.++ -- Simon Marechal <bartavelle@gmail.com> Sat, 25 Jan 2014 15:00:00 +0100++language-puppet (0.10.5) xenial; urgency=medium++ * Lambda blocks can now end with a bare function call+ * Fix version bounds with hslua and luautils++ -- Simon Marechal <bartavelle@gmail.com> Mon, 06 Jan 2014 15:00:00 +0100++language-puppet (0.10.4) xenial; urgency=medium++ * Moved to the latest hruby version.+ * Updated the text bound++ -- Simon Marechal <bartavelle@gmail.com> Wed, 18 Dec 2013 15:00:00 +0100++language-puppet (0.10.3) xenial; urgency=medium++ * The scope tracking system has been improved. It is now possible to know+ * 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+ * 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++ -- Simon Marechal <bartavelle@gmail.com> Tue, 03 Dec 2013 15:00:00 +0100++language-puppet (0.10.2) xenial; urgency=medium++ * PVP support+ * Support for properly setting instance variables before computing++ -- Simon Marechal <bartavelle@gmail.com> Sun, 27 Oct 2013 15:00:00 +0100++language-puppet (0.10.1) xenial; urgency=medium++ * The TestDB file was never created.++ -- Simon Marechal <bartavelle@gmail.com> Sun, 27 Oct 2013 15:00:00 +0100++language-puppet (0.10.0) xenial; urgency=medium++ * 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+ * This is a hack : variables declared in a parent (inheritance) can now be++ -- Simon Marechal <bartavelle@gmail.com> Sun, 27 Oct 2013 15:00:00 +0100++language-puppet (0.9.0) xenial; urgency=medium++ * See http://lpuppet.banquise.net/blog/2013/08/15/version-0-dot-9-0-is-out-for-testing/++ -- Simon Marechal <bartavelle@gmail.com> Thu, 15 Aug 2013 15:00:00 +0100++language-puppet (0.4.2) xenial; urgency=medium++ * Functions 'values' and 'keys' from stdlib are now implemented.+ * hruby integration++ -- Simon Marechal <bartavelle@gmail.com> Sat, 01 Jun 2013 15:00:00 +0100++language-puppet (0.4.0) xenial; urgency=medium++ * 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+ * fqdn_rand now puppet perfect (at least for 32 bit max values)+ * Now depends on the built-in bytestring library that comes with+ * 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.++ -- Simon Marechal <bartavelle@gmail.com> Thu, 16 May 2013 15:00:00 +0100++language-puppet (0.3.3) xenial; urgency=medium++ * 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.+ * 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.++ -- Simon Marechal <bartavelle@gmail.com> Mon, 21 Jan 2013 15:00:00 +0100++language-puppet (0.3.2) xenial; urgency=medium++ * It is now possible to use expressions in include blocks. This is++ -- Simon Marechal <bartavelle@gmail.com> Thu, 13 Dec 2012 15:00:00 +0100++language-puppet (0.3.1) xenial; urgency=medium++ * Yes, we can generate JSon catalogs now.+ * Several bugs about resource relationships.++ -- Simon Marechal <bartavelle@gmail.com> Fri, 23 Nov 2012 15:00:00 +0100++language-puppet (0.3.0) xenial; urgency=medium++ * Resource relationships are somehow supported. The API is broken as a+ * Exported resources are now returned.++ -- Simon Marechal <bartavelle@gmail.com> Mon, 19 Nov 2012 15:00:00 +0100++language-puppet (0.2.2) xenial; urgency=medium++ * A few statistics are exported.++ -- Simon Marechal <bartavelle@gmail.com> Mon, 12 Nov 2012 15:00:00 +0100++language-puppet (0.2.1) xenial; urgency=medium++ * The defaults system was pretty much broken, it should be better now.+ * 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+ * Various internal changes.++ -- Simon Marechal <bartavelle@gmail.com> Mon, 12 Nov 2012 15:00:00 +0100++language-puppet (0.2.0) xenial; urgency=medium++ * Lua integration for custom functions.+ * Automatically creates magic types based on the content of the modules.+ * Defaults parameters can now end with a comma.++ -- Simon Marechal <bartavelle@gmail.com> Mon, 08 Oct 2012 15:00:00 +0100++language-puppet (0.1.8.0) xenial; urgency=medium++ * Refactoring of the PuppetDB API for interfacing with the facter library.+ * Support of exported resource resolution through PuppetDB ! This results+ * Make binary distribution possible (ruby helper path).+ * Defines with spurious parameters, or unset mandatory parameters, should+ * Exception handling for the HTTP failures.+ * Handles undefined variables in Ruby templates.+ * Undefined variables in Erbs now always throw exceptions. This is++ -- Simon Marechal <bartavelle@gmail.com> Thu, 20 Sep 2012 15:00:00 +0100++language-puppet (0.1.7.2) xenial; urgency=medium++ * Preliminary support for PuppetDB++ -- Simon Marechal <bartavelle@gmail.com> Mon, 17 Sep 2012 15:00:00 +0100++language-puppet (0.1.7.1) xenial; urgency=medium++ * Various details have been modified since the official language+ * Better handling of collector conditions.+ * Solves bug with interpolable strings that are not resolved when first+ * Amending attributes with a collector.+ * Stdlib functions : chomp+ * Resource pretty printer now aligns =>.+ * Case statements with regexps.++ -- Simon Marechal <bartavelle@gmail.com> Fri, 14 Sep 2012 15:00:00 +0100++language-puppet (0.1.7) xenial; urgency=medium++ * Fix bug with '<' in the Erb parser !+ * Assignments can now be any valid Puppet expression.+ * Proper list of metaparameters.+ * 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.++ -- Simon Marechal <bartavelle@gmail.com> Fri, 24 Aug 2012 15:00:00 +0100++language-puppet (0.1.6) xenial; urgency=medium++ * 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.+ * Metaparameters now include stages (not handled).+ * Resolving non empty arrays as boolean returns true.+ * Duplicate parameters are now detected.++ -- Simon Marechal <bartavelle@gmail.com> Wed, 01 Aug 2012 15:00:00 +0100++language-puppet (0.1.5) xenial; urgency=medium++ * Detection of spurious parameters when declaring parametrized classes now+ * Resource overrides with non trivial names should now work.+ * Require statements in required files would not be loaded.++ -- Simon Marechal <bartavelle@gmail.com> Fri, 06 Jul 2012 15:00:00 +0100++language-puppet (0.1.4) xenial; urgency=medium++ * Basic native template function.+ * Added anchor as a native type for now. A better fix will be to just parse+ * Tentative defined() implementation. Will not work for resource references.+ * Functions md5, sha1, lowcase, upcase, split.+ * 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.+ * Removed the title parameter from the catalog printing functions.+ * Used hslint a bit.++ -- Simon Marechal <bartavelle@gmail.com> Mon, 02 Jul 2012 15:00:00 +0100
− CHANGELOG.markdown
@@ -1,549 +0,0 @@-# v1.3.12.1 (2017/10/09)--* Support for Glob >= 0.9, even for the test suite :)--# v1.3.12 (2017/10/09)--* Support for Glob >= 0.9--# v1.3.11 (2017/10/07)--* Added yera command-* Minor fixes to the validate_integer function, and to the mount resource-* Support for the "lookup" command in hiera files-* Fix Glob compilation problem--# v1.3.10 (2017/08/28)--* Add `sort` stdlib function-* Remove `SafeProcess` module (fix `ghc-8.2` compilation)-* Remove `ghc-7.x` support--# v1.3.9 (2017/07/30)--* Moved to megaparsec 6--# v1.3.8.1 (2017/07/21)--* Fix haddocks error (#208)--# v1.3.8 (2017/07/20)--* Add support for calling Functions in Strings (#199)-* Add $facts hash for Puppet 4 (#198)-* Initial support for datatype syntax (#206)--# v1.3.7 (2017/03/14)--* Add puppet `sprintf` function-* Fix scientific2text (#196)--# v1.3.6 (2017/02/27)--* The `defined` function can now test variables-* Fixed the `delete_at` function, added new tests, TBC-* Fixed the `ensure_resource` function, so that its second argument can take an array.--# v1.3.5.1 (2017/02/02)--* Version bumps for megaparsec & servant--# v1.3.5 (2017/01/31)--* Ignored packages are not parsed anymore--# v1.3.4.1 (2017/01/12)--* Version bump for the directory dependency--# v1.3.4 (2016/12/14)--* Adds implicit dependencies for some types where users and groups are defined--# v1.3.3 (2016/12/05)--* Rename some pdbquery subcommands-* Output pdbquery in `json` instead of `yaml`-* Fix `pdbquery resources NODENAME`-* Add `pdbquery fact NODENAME`--# v1.3.2.1 (2016/10/04)--* Support for megaparsec 5.1--# v1.3.2 (2016/09/21)--* Add stdlib `validate_integer`-* Support for servant 0.9--# v1.3.1 (2016/08/31)--* Add `--version` to puppetresources and pdbquery-* Version bump for some dependencies--# v1.3 (2016/07/11)--This release is about dependencies versions upgrades.--## Removed features-* External Lua plugins are not a thing anymore--#v1.2 (2016/05/31)--## New features-* `validate_numeric` function-* Preliminary implementation of variable captures in regexp matches-* Ready for GHC 8 and corresponding stackage nightly--## Bugs fixed-* Fixed a deadlock when template code called the `template` or `inline_template` functions. It just stops now :(--# v1.1.5.1 (2016/03/14)--## New features-* `assert_private` function-* `join_keys_to_values` function--## Bugs Fixed-* Several resource collector misbehaviour-* Case expressions can now have multiple matchers of any kind as the same selector--# v1.1.5 (2016/02/02)--## New features--* Added the `pick_default` function-* `merge` now works with an arbitrary number of hashes-* Added the `hash` function-* puppet native type `file` resource accept selinux parameters-* Added the `shellquote` function--## Bugs fixed--* `create_resources` can now create virtual and exported resources-* puppet native type `file` fix for parameters `sourceselect` and `recurselimit`-* Hiera array merge now only keeps unique values-* `merge` now properly priorizes the lastest arguments--# v1.1.4.1 (2015/11/15)--## New features-* Support for the new puppet `contain` function--## Bugs fixed-* Fix parser for search expression (see #132)-* Fix logger set up (see #136)-* Fix some regsubst (see #119)-* Fix the `template` and `inline_template` functions (see #142)-* Support lookups for expressions used in selector (TODO: arbitrary expression)-* Fix a ruby 1.8 syntax error-* Fix a case where resource overrides were not applied to the correct resource-* Fix a bug where a class value would be incorrectly inferred as having a default value whereas it doesn't--## Changes-* Replace `parsec` `megaparsec` (see #138)-* All resource names are normalized. The leading `::` is ignored (see #140)-* Add CI using travis-* Drop support for ghc < 7.10 explicitly--# v1.1.4 (2015/09/07)--## New features-* The `regsubst` function now works with arrays.-* The `file` variable is resolved in templates.-* Support for `function_x` calls in templates.--## Bugs fixed-* Expressions such as (-1) are now supported.-* Selectors recognize the undef token now.-* Fixed a bug with parsing lines starting with `::`.-* Sanitize resource names in some missing instances to fix bugs- when they were starting with `::`.--# v1.1.3 (2015/05/31)--## New features-* Support for the `$settings` variables.-* Support for the `to_yaml` function in templates.-* Settings can now be altered in the default YAML file.-* Defaults and overriden facts are now controlled in the YAML file too.--# v1.1.1.2 (2015/04/28)--Various packaging changes.--# v1.1.1 (2015/04/20)--## New features-* Add 'notify' native type-* Ability to provide defaults via a yaml file for some options-* Added the 'ensure_packages' and 'ensure_resources' functions--## Bugs fixed-* Enable 'package' native type (issue #102)-* Builds against GHC 7.10--## Changes-* Even in Permissive mode, don't resolve unknown variable (see #103)-* Add priority to the logger permissive output (see #106)-* New hruby version-* Rename option `--ignoremodules` into `--ignoredmodules`--## Various-* Hiera config interpolation logs decrease from NOTICE to INFO--# v1.1.0 (2015/03/11)--Critical bugs have been fixed, upgrade recommended.--## New features-* New `dumpinfos` debug function.-* The interpreter can now run in a strict or permissive mode.-* The new `-a` option accepts a comma separated list of nodes for gathering stats.-* The new `--noextratests` option disable optional tests from `Puppet.OptionalTests`.-* Implementation of `member()` from stdlib (see issue #100 for details)--## Bugs fixed-* Exported/virtual custom types are not expanded. This is a huge bug.-* Class/define parameters that are explicitely set as undefined are now overriden by- default values.-* Empty resource groups are now rejected.-* An existing resource can now be realized.--## Various-* Hiera config interpolation logs decrease from WARN to NOTICE-* Remove option `--nousergrouptest`-* Ease the use of the puppetresources command options. See the README file for changes.---# 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.
− Erb/Compute.hs
@@ -1,232 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-module Erb.Compute (- computeTemplate- , initTemplateDaemon-) where--import Control.Concurrent-import Control.Exception-import Control.Monad.Except-import Data.Aeson.Lens-import qualified Data.Either.Strict as S-import Data.FileCache-import qualified Data.Text as T-import Data.String-import qualified Data.Vector as V-import Debug.Trace-import Erb.Evaluate-import Erb.Parser-import Erb.Ruby-import Paths_language_puppet (getDataFileName)-import System.Environment-import qualified System.Log.Logger as LOG-import System.Posix.Files-import Text.Parsec hiding (string)-import Text.Parsec.Error-import Text.Parsec.Pos-import Control.Lens--import Data.Tuple.Strict-import qualified Foreign.Ruby.Helpers as FR-import qualified Foreign.Ruby.Bindings as FR-import Foreign.Ruby-import GHC.Conc (labelThread)--import Puppet.Interpreter.Types-import Puppet.Interpreter.IO-import Puppet.Interpreter.Resolve-import Puppet.PP-import Puppet.Preferences-import Puppet.Stats-import Puppet.Utils--instance IsString TemplateParseError where- fromString s = TemplateParseError $ newErrorMessage (Message s) (initialPos "dummy")--newtype TemplateParseError = TemplateParseError { tgetError :: ParseError }--type TemplateQuery = (Chan TemplateAnswer, Either T.Text T.Text, InterpreterState, InterpreterReader IO)-type TemplateAnswer = S.Either PrettyError T.Text--showRubyError :: RubyError -> PrettyError-showRubyError (Stack msg stk) = PrettyError $ dullred (string msg) </> dullyellow (string stk)-showRubyError (WithOutput str _) = PrettyError $ dullred (string str)-showRubyError (OtherError rr) = PrettyError (dullred (text rr))--initTemplateDaemon :: RubyInterpreter -> Preferences IO -> MStats -> IO (Either T.Text T.Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError T.Text))-initTemplateDaemon intr prefs mvstats = do- controlchan <- newChan- templatecache <- newFileCache- let returnError rs = return $ \_ _ _ -> return (S.Left (showRubyError rs))- x <- runExceptT $ do- liftIO (getRubyScriptPath "hrubyerb.rb") >>= ExceptT . loadFile intr- ExceptT (registerGlobalFunction4 intr "varlookup" hrresolveVariable)- ExceptT (registerGlobalFunction5 intr "callextfunc" hrcallfunction)- liftIO $ void $ forkIO $ templateDaemon intr- (T.pack (prefs ^. prefPuppetPaths.modulesPath))- (T.pack (prefs ^. prefPuppetPaths.templatesPath))- controlchan- mvstats- templatecache- return (templateQuery controlchan)- either returnError return x--templateQuery :: Chan TemplateQuery -> Either T.Text T.Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError T.Text)-templateQuery qchan filename stt rdr = do- rchan <- newChan- writeChan qchan (rchan, filename, stt, rdr)- readChan rchan--templateDaemon :: RubyInterpreter -> T.Text -> T.Text -> Chan TemplateQuery -> MStats -> FileCacheR TemplateParseError [RubyStatement] -> IO ()-templateDaemon intr modpath templatepath qchan mvstats filecache = do- let nameThread :: String -> IO ()- nameThread n = myThreadId >>= flip labelThread n- nameThread "RubyTemplateDaemon"-- (respchan, fileinfo, stt, rdr) <- readChan qchan- case fileinfo of- Right filename -> do- let prts = T.splitOn "/" filename- searchpathes | length prts > 1 = [modpath <> "/" <> head prts <> "/templates/" <> T.intercalate "/" (tail prts), templatepath <> "/" <> filename]- | otherwise = [templatepath <> "/" <> filename]- acceptablefiles <- filterM (fileExist . T.unpack) searchpathes- if null acceptablefiles- then writeChan respchan (S.Left $ PrettyError $ "Can't find template file for" <+> ttext filename <+> ", looked in" <+> list (map ttext searchpathes))- else measure mvstats filename (computeTemplate intr (Right (head acceptablefiles)) stt rdr mvstats filecache) >>= writeChan respchan- Left _ -> measure mvstats "inline" (computeTemplate intr fileinfo stt rdr mvstats filecache) >>= writeChan respchan- templateDaemon intr modpath templatepath qchan mvstats filecache--computeTemplate :: RubyInterpreter -> Either T.Text T.Text -> InterpreterState -> InterpreterReader IO -> MStats -> FileCacheR TemplateParseError [RubyStatement] -> IO TemplateAnswer-computeTemplate intr fileinfo stt rdr mstats filecache = do- let (curcontext, fvariables) = case extractFromState stt of- Nothing -> (mempty, mempty)- Just (c,v) -> (c,v)- let (filename, ufilename) = case fileinfo of- Left _ -> ("inline", "inline")- Right x -> (x, T.unpack x)- mkSafe a = makeSafe intr a >>= \case- Left rr -> return (S.Left (showRubyError rr))- Right x -> return x- encapsulateError = _Left %~ TemplateParseError- variables = fvariables & traverse . scopeVariables . traverse . _1 . _1 %~ toStr- toStr (PNumber n) = PString (scientific2text n)- toStr x = x- traceEventIO ("START template " ++ T.unpack filename)- parsed <- case fileinfo of- Right _ -> measure mstats ("parsing - " <> filename) $ lazyQuery filecache ufilename $ fmap encapsulateError (parseErbFile ufilename)- Left content -> measure mstats ("parsing - " <> filename) $ return $ encapsulateError (runParser erbparser () "inline" (T.unpack content))- o <- case parsed of- Left err -> do- let !msg = "template " ++ ufilename ++ " could not be parsed " ++ show (tgetError err)- traceEventIO msg- LOG.debugM "Erb.Compute" msg- measure mstats ("ruby - " <> filename) $ mkSafe $ computeTemplateWRuby fileinfo curcontext variables stt rdr- Right ast -> case rubyEvaluate variables curcontext ast of- Right ev -> return (S.Right ev)- Left err -> do- let !msg = "template " ++ ufilename ++ " evaluation failed " ++ show err- traceEventIO msg- LOG.debugM "Erb.Compute" msg- measure mstats ("ruby efail - " <> filename) $ mkSafe $ computeTemplateWRuby fileinfo curcontext variables stt rdr- traceEventIO ("STOP template " ++ T.unpack filename)- return o--getRubyScriptPath :: String -> IO String-getRubyScriptPath rubybin = do- let checkpath :: FilePath -> IO FilePath -> IO FilePath- checkpath fp nxt = do- e <- fileExist fp- if e- then return fp- else nxt- withExecutablePath = do- path <- fmap (T.unpack . takeDirectory . T.pack) getExecutablePath- let fullpath = path <> "/" <> rubybin- checkpath fullpath $ checkpath ("/usr/local/bin/" <> rubybin) (return rubybin)- cabalPath <- getDataFileName $ "ruby/" ++ rubybin :: IO FilePath- checkpath cabalPath withExecutablePath---- This must be called from the proper thread. As this is callback, this--- should be ok.-hrresolveVariable :: RValue -> RValue -> RValue -> RValue -> IO RValue--- T.Text -> Container PValue -> RValue -> RValue -> IO RValue-hrresolveVariable _ rscp rvariables rtoresolve = do- scope <- FR.extractHaskellValue rscp- variables <- FR.extractHaskellValue rvariables- toresolve <- FR.fromRuby rtoresolve- let answer = case toresolve of- Right "~g~e~t_h~a~s~h~" ->- let getvars ctx = (variables ^. ix ctx . scopeVariables) & traverse %~ view (_1 . _1)- vars = getvars "::" <> getvars scope- in Right (PHash vars)- Right t -> getVariable variables scope t- Left rr -> Left ("The variable name is not a string" <+> text rr)- case answer of- Left _ -> getSymbol "undef"- Right r -> FR.toRuby r--hrcallfunction :: RValue -> RValue -> RValue -> RValue -> RValue -> IO RValue-hrcallfunction _ rfname rargs rstt rrdr = do- efname <- FR.fromRuby rfname- eargs <- FR.fromRuby rargs- rdr <- FR.extractHaskellValue rrdr- stt <- FR.extractHaskellValue rstt- let err :: String -> IO RValue- err rr = fmap (either Prelude.snd id) (FR.toRuby (T.pack rr) >>= FR.safeMethodCall "MyError" "new" . (:[]))- case (,) <$> efname <*> eargs of- Right (fname, varray) | fname `elem` ["template", "inline_template"] -> err "Can't call template from a Ruby function, as this will stall (yes it sucks ...)"- | otherwise -> do- let args = case varray of- [PArray vargs] -> V.toList vargs- _ -> varray- (x,_,_) <- interpretMonad rdr stt (resolveFunction' fname args)- case x of- Right o -> case o ^? _Number of- Just n -> FR.toRuby n- Nothing -> FR.toRuby o- Left rr -> err (show rr)- Left rr -> err rr--computeTemplateWRuby :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> InterpreterState -> InterpreterReader IO -> IO TemplateAnswer-computeTemplateWRuby fileinfo curcontext variables stt rdr = FR.freezeGC $ eitherDocIO $ do- rscp <- FR.embedHaskellValue curcontext- rvariables <- FR.embedHaskellValue variables- rstt <- FR.embedHaskellValue stt- rrdr <- FR.embedHaskellValue rdr- let varlist = variables ^. ix curcontext . scopeVariables- -- must be called from a "makeSafe" thingie- contentinfo <- case fileinfo of- Right fname -> FR.toRuby fname- Left _ -> FR.toRuby ("-" :: T.Text)- let withBinding f = do- erbBinding <- FR.safeMethodCall "ErbBinding" "new" [rscp,rvariables,rstt,rrdr,contentinfo]- case erbBinding of- Left x -> return (Left x)- Right v -> do- forM_ (itoList varlist) $ \(varname, varval :!: _ :!: _) -> FR.toRuby varval >>= FR.rb_iv_set v (T.unpack varname)- f v- o <- case fileinfo of- Right fname -> do- rfname <- FR.toRuby fname- withBinding $ \v -> FR.safeMethodCall "Controller" "runFromFile" [rfname,v]- Left content -> withBinding $ \v -> FR.toRuby content >>= FR.safeMethodCall "Controller" "runFromContent" . (:[v])- FR.freeHaskellValue rrdr- FR.freeHaskellValue rstt- FR.freeHaskellValue rvariables- FR.freeHaskellValue rscp- case o of- Left (rr, _) ->- let fname = case fileinfo of- Right f -> T.unpack f- Left _ -> "inline_template"- in return (S.Left $ PrettyError (dullred (text rr) <+> "in" <+> dullgreen (text fname)))- Right r -> FR.fromRuby r >>= \case- Right result -> return (S.Right result)- Left rr -> return (S.Left $ PrettyError ("Could not deserialiaze ruby output" <+> text rr))--eitherDocIO :: IO (S.Either PrettyError a) -> IO (S.Either PrettyError a)-eitherDocIO computation = (computation >>= check) `catch` (\e -> return $ S.Left $ PrettyError $ dullred $ text $ show (e :: SomeException))- where- check (S.Left r) = return (S.Left r)- check (S.Right x) = return (S.Right x)
− Erb/Evaluate.hs
@@ -1,86 +0,0 @@-{-# LANGUAGE LambdaCase #-}--- | Evaluates a ruby template from what's generated by "Erb.Parser".-module Erb.Evaluate (rubyEvaluate, getVariable, extractFromState) where--import Control.Lens-import Data.Aeson.Lens-import Data.Char (isSpace)-import qualified Data.HashMap.Strict as HM-import Data.Maybe (fromMaybe)-import qualified Data.Text as T-import Data.Tuple.Strict-import qualified Data.Vector as V-import Erb.Ruby--import Puppet.Interpreter.PrettyPrinter ()-import Puppet.Interpreter.Resolve-import Puppet.Interpreter.Types-import Puppet.Interpreter.Utils-import Puppet.Parser.Utils-import Puppet.PP-import Puppet.Utils-import qualified Text.PrettyPrint.ANSI.Leijen as P--extractFromState :: InterpreterState -> Maybe (T.Text, Container ScopeInformation)-extractFromState stt =- let cs = stt ^. curScope- in if null cs- then Nothing- else let scp = scopeName (head cs)- classes = (PArray . V.fromList . map PString . HM.keys) (stt ^. loadedClasses)- scps = stt ^. scopes- cd = fromMaybe ContRoot (scps ^? ix scp . scopeContainer . cctype) -- get the current containder description- cscps = scps & ix scp . scopeVariables . at "classes" ?~ ( classes :!: dummyppos :!: cd )- in Just (scp, cscps)--rubyEvaluate :: Container ScopeInformation -> T.Text -> [RubyStatement] -> Either Doc T.Text-rubyEvaluate vars ctx = foldl (evalruby vars ctx) (Right "") . optimize- where- optimize [] = []- optimize (Puts x : DropPrevSpace' : xs) = optimize $ DropPrevSpace (Puts x) : xs- optimize (x:xs) = x : optimize xs--spaceNotCR :: Char -> Bool-spaceNotCR c = isSpace c && c /= '\n' && c /= '\r'--evalruby :: Container ScopeInformation -> T.Text -> Either Doc T.Text -> RubyStatement -> Either Doc T.Text-evalruby _ _ (Left err) _ = Left err-evalruby _ _ (Right _) (DropPrevSpace') = Left "Could not evaluate a non optimize DropPrevSpace'"-evalruby mp ctx (Right curstr) (DropNextSpace x) = case evalruby mp ctx (Right curstr) x of- Left err -> Left err- Right y -> Right (T.dropWhile spaceNotCR y)-evalruby mp ctx (Right curstr) (DropPrevSpace x) = case evalruby mp ctx (Right curstr) x of- Left err -> Left err- Right y -> Right (T.dropWhileEnd spaceNotCR y)-evalruby mp ctx (Right curstr) (Puts e) = case evalExpression mp ctx e of- Left err -> Left err- Right ex -> Right (curstr <> ex)--evalExpression :: Container ScopeInformation -> T.Text -> Expression -> Either Doc T.Text-evalExpression mp ctx (LookupOperation varname varindex) = do- rvname <- evalExpression mp ctx varname- rvindx <- evalExpression mp ctx varindex- getVariable mp ctx rvname >>= \case- PArray arr ->- case a2i rvindx of- Nothing -> Left $ "Can't convert index to integer when resolving" <+> ttext rvname P.<> brackets (ttext rvindx)- Just i -> if fromIntegral (V.length arr) <= i- then Left $ "Array out of bound" <+> ttext rvname P.<> brackets (ttext rvindx)- else evalValue (arr V.! fromIntegral i)- PHash hs -> case hs ^. at rvindx of- Just x -> evalValue x- _ -> Left $ "Can't index variable" <+> ttext rvname <+> ", it is " <+> pretty (PHash hs)- varvalue -> Left $ "Can't index variable" <+> ttext rvname <+> ", it is " <+> pretty varvalue-evalExpression _ _ (Value (Literal x)) = Right x-evalExpression mp ctx (Object (Value (Literal x))) = getVariable mp ctx x >>= evalValue-evalExpression _ _ x = Left $ "Can't evaluate" <+> pretty x--evalValue :: PValue -> Either Doc T.Text-evalValue (PString x) = Right x-evalValue (PNumber x) = Right (scientific2text x)-evalValue x = Right $ T.pack $ show x--a2i :: T.Text -> Maybe Integer-a2i x = case text2Scientific x of- Just y -> y ^? _Integer- _ -> Nothing
− Erb/Parser.hs
@@ -1,182 +0,0 @@-{-# LANGUAGE LambdaCase #-}-module Erb.Parser where--import Text.Parsec.String-import Text.Parsec.Prim hiding ((<|>),many)-import Text.Parsec.Char-import Text.Parsec.Error-import Text.Parsec.Combinator hiding (optional)-import Text.Parsec.Language (emptyDef)-import Erb.Ruby-import Text.Parsec.Expr-import Text.Parsec.Pos-import qualified Text.Parsec.Token as P-import qualified Data.Text as T-import qualified Data.Text.IO as T-import Control.Monad.Identity-import Control.Exception (catch,SomeException)-import Control.Applicative--def :: P.GenLanguageDef String u Identity-def = emptyDef- { P.commentStart = "/*"- , P.commentEnd = "*/"- , P.commentLine = "#"- , P.nestedComments = True- , P.identStart = letter- , P.identLetter = alphaNum <|> oneOf "_"- , P.reservedNames = ["if", "else", "case", "elsif"]- , P.reservedOpNames= ["=>","=","+","-","/","*","+>","->","~>","!"]- , P.caseSensitive = True- }--lexer :: P.GenTokenParser String u Identity-lexer = P.makeTokenParser def--parens :: Parser a -> Parser a-parens = P.parens lexer--braces :: Parser a -> Parser a-braces = P.braces lexer--operator :: Parser String-operator = P.operator lexer--symbol :: String -> Parser String-symbol = P.symbol lexer--reservedOp :: String -> Parser ()-reservedOp = P.reservedOp lexer--whiteSpace :: Parser ()-whiteSpace = P.whiteSpace lexer--naturalOrFloat :: Parser (Either Integer Double)-naturalOrFloat = P.naturalOrFloat lexer--identifier :: Parser String-identifier = P.identifier lexer--rubyexpression :: Parser Expression-rubyexpression = buildExpressionParser table term <?> "expression"--table :: [[Operator String () Identity Expression]]-table = [ [ Infix ( reservedOp "+" >> return PlusOperation ) AssocLeft- , Infix ( reservedOp "-" >> return MinusOperation ) AssocLeft ]- , [ Infix ( reservedOp "/" >> return DivOperation ) AssocLeft- , Infix ( reservedOp "*" >> return MultiplyOperation ) AssocLeft ]- , [ Infix ( reservedOp "<<" >> return ShiftLeftOperation ) AssocLeft- , Infix ( reservedOp ">>" >> return ShiftRightOperation ) AssocLeft ]- , [ Infix ( reservedOp "and" >> return AndOperation ) AssocLeft- , Infix ( reservedOp "or" >> return OrOperation ) AssocLeft ]- , [ Infix ( reservedOp "==" >> return EqualOperation ) AssocLeft- , Infix ( reservedOp "!=" >> return DifferentOperation ) AssocLeft ]- , [ Infix ( reservedOp ">" >> return AboveOperation ) AssocLeft- , Infix ( reservedOp ">=" >> return AboveEqualOperation ) AssocLeft- , Infix ( reservedOp "<=" >> return UnderEqualOperation ) AssocLeft- , Infix ( reservedOp "<" >> return UnderOperation ) AssocLeft ]- , [ Infix ( reservedOp "=~" >> return RegexpOperation ) AssocLeft- , Infix ( reservedOp "!~" >> return NotRegexpOperation ) AssocLeft ]- , [ Prefix ( symbol "!" >> return NotOperation ) ]- , [ Prefix ( symbol "-" >> return NegOperation ) ]- , [ Infix ( reservedOp "?" >> return ConditionalValue ) AssocLeft ]- , [ Infix ( reservedOp "." >> return MethodCall ) AssocLeft ]- ]-term :: Parser Expression-term- = parens rubyexpression- <|> scopeLookup- <|> stringLiteral- <|> objectterm- <|> variablereference--scopeLookup :: Parser Expression-scopeLookup = do- void $ try $ string "scope"- end <- (string ".lookupvar(" >> return (char ')')) <|> (char '[' >> return (char ']'))- expr <- rubyexpression- void end- return $ Object expr--stringLiteral :: Parser Expression-stringLiteral = Value `fmap` (doubleQuoted <|> singleQuoted)--doubleQuoted :: Parser Value-doubleQuoted = Interpolable <$> between (char '"') (char '"') quoteInternal- where- quoteInternal = many (basicContent <|> interpvar <|> escaped)- escaped = char '\\' >> (Value . Literal . T.singleton) `fmap` anyChar- basicContent = (Value . Literal . T.pack) `fmap` many1 (noneOf "\"\\#")- interpvar = do- void $ try (string "#{")- o <- many1 (noneOf "}")- void $ char '}'- return (Object (Value (Literal (T.pack o))))--singleQuoted :: Parser Value-singleQuoted = Literal . T.pack <$> between (char '\'') (char '\'') (many $ noneOf "'")--objectterm :: Parser Expression-objectterm = do- void $ optional (char '@')- methodname' <- fmap T.pack identifier- let methodname = Value (Literal methodname')- lookAhead anyChar >>= \case- '[' -> do- hr <- many (symbol "[" *> rubyexpression <* symbol "]")- return $! foldl LookupOperation (Object methodname) hr- '{' -> fmap (MethodCall methodname . BlockOperation . T.pack) (braces (many1 $ noneOf "}"))- '(' -> fmap (MethodCall methodname . Value . Array) (parens (rubyexpression `sepBy` symbol ","))- _ -> return $ Object methodname--variablereference :: Parser Expression-variablereference = fmap (Object . Value . Literal . T.pack) identifier--rubystatement :: Parser RubyStatement-rubystatement = fmap Puts rubyexpression--textblockW :: Maybe Char -> Parser [RubyStatement]-textblockW c = do- s <- many (noneOf "<")- let ns = case c of- Just x -> x:s- Nothing -> s- returned = Puts $ Value $ Literal $ T.pack ns- optionMaybe eof >>= \case- Just _ -> return [returned]- Nothing -> do- void $ char '<'- n <- optionMaybe (char '%') >>= \case- Just _ -> rubyblock- Nothing -> textblockW (Just '<')- return (returned : n)--textblock :: Parser [RubyStatement]-textblock = textblockW Nothing--rubyblock :: Parser [RubyStatement]-rubyblock = do- ps <- option [] (char '-' >> return [DropPrevSpace'])- parsed <- optionMaybe (char '=') >>= \case- Just _ -> spaces >> fmap (return . Puts) rubyexpression- Nothing -> spaces >> many1 rubystatement- spaces- let dn (x:xs) = DropNextSpace x : xs- dn x = x- ns <- option id (char '-' >> return dn)- void $ string "%>"- n <- textblock- return (ps ++ parsed ++ ns n)--erbparser :: Parser [RubyStatement]-erbparser = textblock--parseErbFile :: FilePath -> IO (Either ParseError [RubyStatement])-parseErbFile fname = parseContent `catch` handler- where- parseContent = (runParser erbparser () fname . T.unpack) `fmap` T.readFile fname- handler e = let msg = show (e :: SomeException)- in return $ Left $ newErrorMessage (Message msg) (initialPos fname)--parseErbString :: String -> Either ParseError [RubyStatement]-parseErbString = runParser erbparser () "dummy"
− Erb/Ruby.hs
@@ -1,57 +0,0 @@--- | Base types for the internal ruby parser ("Erb.Parser").-module Erb.Ruby where--import qualified Data.Text as T-import Text.PrettyPrint.ANSI.Leijen--data Value- = Literal !T.Text- | Interpolable ![Expression]- | Symbol !T.Text- | Array ![Expression]- deriving (Show, Ord, Eq)--data Expression- = LookupOperation !Expression !Expression- | PlusOperation !Expression !Expression- | MinusOperation !Expression !Expression- | DivOperation !Expression !Expression- | MultiplyOperation !Expression !Expression- | ShiftLeftOperation !Expression !Expression- | ShiftRightOperation !Expression !Expression- | AndOperation !Expression !Expression- | OrOperation !Expression !Expression- | EqualOperation !Expression !Expression- | DifferentOperation !Expression !Expression- | AboveOperation !Expression !Expression- | AboveEqualOperation !Expression !Expression- | UnderEqualOperation !Expression !Expression- | UnderOperation !Expression !Expression- | RegexpOperation !Expression !Expression- | NotRegexpOperation !Expression !Expression- | NotOperation !Expression- | NegOperation !Expression- | ConditionalValue !Expression !Expression- | Object !Expression- | MethodCall !Expression !Expression- | BlockOperation !T.Text- | Value !Value- | BTrue- | BFalse- | Error !String- deriving (Show, Ord, Eq)--instance Pretty Expression where- pretty (LookupOperation a b) = pretty a <> brackets (pretty b)- pretty (PlusOperation a b) = parens (pretty a <+> text "+" <+> pretty b)- pretty (MinusOperation a b) = parens (pretty a <+> text "-" <+> pretty b)- pretty (DivOperation a b) = parens (pretty a <+> text "/" <+> pretty b)- pretty (MultiplyOperation a b) = parens (pretty a <+> text "*" <+> pretty b)- pretty op = text (show op)--data RubyStatement- = Puts !Expression- | DropPrevSpace !RubyStatement- | DropPrevSpace'- | DropNextSpace !RubyStatement- deriving(Show,Eq)
− Facter.hs
@@ -1,196 +0,0 @@-{-# LANGUAGE LambdaCase #-}-module Facter where--import Data.Char-import Text.Printf-import qualified Data.HashSet as HS-import qualified Data.HashMap.Strict as HM-import Puppet.Interpreter.Types-import qualified Data.Text as T-import Control.Arrow-import Control.Lens-import System.Posix.User-import System.Posix.Unistd (getSystemID, SystemID(..))-import Data.List.Split (splitOn)-import Data.List (intercalate,stripPrefix)-import System.Environment-import System.Directory (doesFileExist)-import Data.Maybe (mapMaybe)-import Control.Monad.Trans.Except--storageunits :: [(String, Int)]-storageunits = [ ("", 0), ("K", 1), ("M", 2), ("G", 3), ("T", 4) ]--getPrefix :: Int -> String-getPrefix n | null fltr = error $ "Could not get unit prefix for order " ++ show n- | otherwise = fst $ head fltr- where fltr = filter (\(_, x) -> x == n) storageunits--getOrder :: String -> Int-getOrder n | null fltr = error $ "Could not get order for unit prefix " ++ show n- | otherwise = snd $ head fltr- where- nu = map toUpper n- fltr = filter (\(x, _) -> x == nu) storageunits--normalizeUnit :: (Double, Int) -> Double -> (Double, Int)-normalizeUnit (unit, order) base | unit > base = normalizeUnit (unit/base, order + 1) base- | otherwise = (unit, order)--storagedesc :: (String, String) -> String-storagedesc (ssize, unit) = let- size = read ssize :: Double- uprefix | unit == "B" = ""- | otherwise = [head unit]- uorder = getOrder uprefix- (osize, oorder) = normalizeUnit (size, uorder) 1024- in printf "%.2f %sB" osize (getPrefix oorder)--factRAM :: IO [(String, String)]-factRAM = do- meminfo <- fmap (map words . lines) (readFile "/proc/meminfo")- let memtotal = ginfo "MemTotal:"- memfree = ginfo "MemFree:"- swapfree = ginfo "SwapFree:"- swaptotal = ginfo "SwapTotal:"- ginfo st = sdesc $ head $ filter ((== st) . head) meminfo- sdesc [_, size, unit] = storagedesc (size, unit)- sdesc _ = storagedesc ("1","B")- return [("memorysize", memtotal), ("memoryfree", memfree), ("swapfree", swapfree), ("swapsize", swaptotal)]--factNET :: IO [(String, String)]-factNET = return [("ipaddress", "192.168.0.1")]--factOS :: IO [(String, String)]-factOS = do- islsb <- doesFileExist "/etc/lsb-release"- isdeb <- doesFileExist "/etc/debian_version"- case (islsb, isdeb) of- (True, _) -> factOSLSB- (_, True) -> factOSDebian- _ -> return []--factOSDebian :: IO [(String, String)]-factOSDebian = fmap (toV . head . lines) (readFile "/etc/debian_version")- where- toV v = [ ("lsbdistid" , "Debian")- , ("operatingsystem" , "Debian")- , ("lsbdistrelease" , v)- , ("operatingsystemrelease" , v)- , ("lsbmajdistrelease" , takeWhile (/='.') v)- , ("osfamily" , "Debian")- , ("lsbdistcodename" , codename v)- , ("lsbdistdescription" , "Debian GNU/Linux " ++ v ++ " (" ++ codename v ++ ")")- ]- codename v | null v = "unknown"- | h '7' = "wheezy"- | h '6' = "squeeze"- | h '5' = "lenny"- | h '4' = "etch"- | v == "3.1" = "sarge"- | v == "3.0" = "woody"- | v == "2.2" = "potato"- | v == "2.1" = "slink"- | v == "2.0" = "hamm"- | otherwise = "unknown"- where h x = head v == x--factOSLSB :: IO [(String, String)]-factOSLSB = do- lsb <- fmap (map (break (== '=')) . lines) (readFile "/etc/lsb-release")- let getval st | null filterd = "?"- | otherwise = rvalue- where filterd = filter (\(k,_) -> k == st) lsb- value = (tail . snd . head) filterd- rvalue | head value == '"' = read value- | otherwise = value- lrelease = getval "DISTRIB_RELEASE"- distid = getval "DISTRIB_ID"- maj | lrelease == "?" = "?"- | otherwise = takeWhile (/= '.') lrelease- osfam | distid == "Ubuntu" = "Debian"- | otherwise = distid- return [ ("lsbdistid" , distid)- , ("operatingsystem" , distid)- , ("lsbdistrelease" , lrelease)- , ("operatingsystemrelease" , lrelease)- , ("operatingsystemmajrelease" , lrelease)- , ("lsbmajdistrelease" , maj)- , ("lsbminordistrelease" , "")- , ("osfamily" , osfam)- , ("lsbdistcodename" , getval "DISTRIB_CODENAME")- , ("lsbdistdescription" , getval "DISTRIB_DESCRIPTION")- ]--factMountPoints :: IO [(String, String)]-factMountPoints = do- mountinfo <- fmap (map words . lines) (readFile "/proc/mounts")- let ignorefs = HS.fromList- ["NFS", "nfs", "nfs4", "nfsd", "afs", "binfmt_misc", "proc", "smbfs",- "autofs", "iso9660", "ncpfs", "coda", "devpts", "ftpfs", "devfs",- "mfs", "shfs", "sysfs", "cifs", "lustre_lite", "tmpfs", "usbfs", "udf",- "fusectl", "fuse.snapshotfs", "rpc_pipefs", "configfs", "devtmpfs",- "debugfs", "securityfs", "ecryptfs", "fuse.gvfs-fuse-daemon", "rootfs"- ]- goodlines = filter (\x -> not $ HS.member (x !! 2) ignorefs) mountinfo- goodfs = map (!! 1) goodlines- return [("mountpoints", unwords goodfs)]--fversion :: IO [(String, String)]-fversion = return [("facterversion", "0.1"),("environment","test")]--factUser :: IO [(String, String)]-factUser = do- username <- getEffectiveUserName- return [("id",username)]--factUName :: IO [(String, String)]-factUName = do- SystemID sn nn rl _ mc <- getSystemID- let vparts = splitOn "." (takeWhile (/='-') rl)- return [ ("kernel" , sn) -- Linux- , ("kernelmajversion" , intercalate "." (take 2 vparts)) -- 3.5- , ("kernelrelease" , rl) -- 3.5.0-45-generic- , ("kernelversion" , intercalate "." (take 3 vparts)) -- 3.5.0- , ("hardwareisa" , mc) -- x86_64- , ("hardwaremodel" , mc) -- x86_64- , ("hostname" , nn)- ]--fenv :: IO [(String,String)]-fenv = do- path <- getEnv "PATH"- return [ ("path", path) ]--factProcessor :: IO [(String,String)]-factProcessor = do- cpuinfo <- readFile "/proc/cpuinfo"- let cpuinfos = zip [ "processor" ++ show (n :: Int) | n <- [0..]] modelnames- modelnames = mapMaybe (fmap (dropWhile (`elem` ("\t :" :: String))) . stripPrefix "model name") (lines cpuinfo)- return $ ("processorcount", show (length cpuinfos)) : cpuinfos--puppetDBFacts :: NodeName -> PuppetDBAPI IO -> IO (Container PValue)-puppetDBFacts node pdbapi =- runExceptT (getFacts pdbapi (QEqual FCertname node)) >>= \case- Right facts@(_:_) -> return (HM.fromList (map (\f -> (f ^. factInfoName, f ^. factInfoVal)) facts))- _ -> do- rawFacts <- fmap concat (sequence [factNET, factRAM, factOS, fversion, factMountPoints, factOS, factUser, factUName, fenv, factProcessor])- let ofacts = genFacts $ map (T.pack *** T.pack) rawFacts- (hostname, ddomainname) = T.break (== '.') node- domainname = if T.null ddomainname- then ""- else T.tail ddomainname- nfacts = genFacts [ ("fqdn", node)- , ("hostname", hostname)- , ("domain", domainname)- , ("rootrsa", "xxx")- , ("operatingsystem", "Ubuntu")- , ("puppetversion", "language-puppet")- , ("virtual", "xenu")- , ("clientcert", node)- , ("is_virtual", "true")- , ("concat_basedir", "/var/lib/puppet/concat")- ]- allfacts = nfacts `HM.union` ofacts- genFacts = HM.fromList- return (allfacts & traverse %~ PString)
− Hiera/Server.hs
@@ -1,234 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}--{- | 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- , hieraLoggerName- -- * Query API- , HieraQueryFunc-) where--import Control.Applicative-import Control.Lens-import Control.Monad.Except-import Control.Monad.Trans.Reader-import Control.Monad.Writer.Strict-import Data.Aeson (FromJSON, Value (..), (.!=), (.:?))-import qualified Data.Aeson as A-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.List as L-import Data.Maybe (catMaybes, mapMaybe)-import Data.String (fromString)-import qualified Data.Text as T-import qualified Data.Vector as V-import qualified Data.Yaml as Y-import System.FilePath.Lens (directory)-import qualified System.Log.Logger as LOG--import Puppet.Interpreter.Types-import Puppet.PP-import Puppet.Utils (strictifyEither)--hieraLoggerName :: String-hieraLoggerName = "Hiera.Server"--data HieraConfigFile = HieraConfigFile- { _backends :: [Backend]- , _hierarchy :: [InterpolableHieraString]- } deriving (Show)--data Backend = YamlBackend FilePath- | JsonBackend FilePath- deriving Show--newtype InterpolableHieraString = InterpolableHieraString { getInterpolableHieraString :: [HieraStringPart] }- deriving Show--data HieraStringPart = HPString T.Text- | HPVariable T.Text- deriving Show--instance Pretty HieraStringPart where- pretty (HPString t) = ttext t- pretty (HPVariable v) = dullred (string "%{" <> ttext v <> string "}")- prettyList = mconcat . map pretty--type Cache = F.FileCacheR String Value--data QRead- = QRead- { _qvars :: Container T.Text- , _qtype :: HieraQueryType- , _qhier :: [Value]- }--makeClassy ''HieraConfigFile-makeLenses ''QRead--instance FromJSON InterpolableHieraString where- parseJSON (String s) = case parseInterpolableString s of- Right x -> return (InterpolableHieraString x)- Left rr -> fail rr- parseJSON _ = fail "Invalid value type"--instance FromJSON HieraConfigFile where- parseJSON (Object v) = do- 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 name)- datadir <- case Object v ^? key skey . key ":datadir" of- Just (String dir) -> return dir- Just _ -> fail ":datadir should be a string"- Nothing -> return "/etc/puppet/hieradata"- return (backendConstructor (T.unpack datadir))- HieraConfigFile- <$> (v .:? ":backends" .!= ["yaml"] >>= mapM genBackend)- <*> (v .:? ":hierarchy" .!= [InterpolableHieraString [HPString "common"]])- parseJSON _ = fail "Not a valid Hiera configuration"---- | An attoparsec parser that turns text into parts that are ready for interpolation-interpolableString :: AT.Parser [HieraStringPart]-interpolableString = AT.many1 (fmap HPString rawPart <|> fmap HPVariable interpPart)- where- rawPart = AT.takeWhile1 (/= '%')- interpPart = AT.string "%{" *> AT.takeWhile1 (/= '}') <* AT.char '}'--parseInterpolableString :: T.Text -> Either String [HieraStringPart]-parseInterpolableString = AT.parseOnly interpolableString---- | The only method you'll ever need. It runs a Hiera server and gives you--- a querying function. The 'Nil' output is explicitely given as a Maybe--- type.-startHiera :: FilePath -> IO (Either String (HieraQueryFunc IO))-startHiera fp = Y.decodeFileEither fp >>= \case- Left (Y.InvalidYaml (Just (Y.YamlException "Yaml file not found: hiera.yaml"))) -> return (Right dummyHiera)- Left ex -> return (Left (show ex))- Right cfg -> do- cache <- F.newFileCache- 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 Nothing--resolveString :: Container T.Text -> InterpolableHieraString -> Maybe T.Text-resolveString vars = fmap T.concat . mapM resolve . getInterpolableHieraString- where- resolve (HPString x) = Just x- resolve (HPVariable v) = vars ^? ix v--query :: HieraConfigFile -> FilePath -> Cache -> HieraQueryFunc IO-query HieraConfigFile {_backends, _hierarchy} fp cache vars hquery qt = do- -- step 1, resolve hierarchies- let searchin = do- mhierarchy <- resolveString vars <$> _hierarchy- Just hier <- [mhierarchy]- backend <- _backends- let decodeInfo :: (FilePath -> IO (S.Either String Value), String, String)- decodeInfo- = case backend of- JsonBackend d -> (fmap (strictifyEither . A.eitherDecode') . BS.readFile , d, ".json")- YamlBackend d -> (fmap (strictifyEither . (_Left %~ show)) . Y.decodeFileEither, d, ".yaml")- return (decodeInfo, hier)- -- step 2, read all the files, returning a raw data structure- mvals <- forM searchin $ \((decodefunction, datadir, extension), hier) -> do- let filename = basedir <> datadir <> "/" <> T.unpack hier <> extension- basedir = case datadir of- '/' : _ -> mempty- _ -> fp ^. directory <> "/"- efilecontent <- F.query cache filename (decodefunction filename)- case efilecontent of- S.Left r -> do- let errs = "Hiera: error when reading file " <> string filename <+> string r- if "Yaml file not found: " `L.isInfixOf` r- then LOG.debugM hieraLoggerName (show errs)- else LOG.warningM hieraLoggerName (show errs)- return Nothing- S.Right val -> return (Just val)- let vals = catMaybes mvals- -- step 3, query through all the results- return (strictifyEither $ runReader (runExceptT (recursiveQuery hquery [])) (QRead vars qt vals))--type QM a = ExceptT PrettyError (Reader QRead) a--checkLoop :: T.Text -> [T.Text] -> QM ()-checkLoop x xs =- when (x `elem` xs) (throwError ("Loop in hiera: " <> fromString (T.unpack (T.intercalate ", " (x:xs)))))--recursiveQuery :: T.Text -> [T.Text] -> QM (Maybe PValue)-recursiveQuery curquery prevqueries = do- checkLoop curquery prevqueries- rawlookups <- mapMaybe (preview (key curquery)) <$> view qhier- lookups <- mapM (resolveValue (curquery : prevqueries)) rawlookups- case lookups of- [] -> return Nothing- (x:xs) -> do- qt <- view qtype- let evalue = foldM (mergeWith qt) x xs- case A.fromJSON <$> evalue of- Left _ -> return Nothing- Right (A.Success o) -> return o- Right (A.Error rr) -> throwError ("Something horrible happened in recursiveQuery: " <> fromString (show rr))--resolveValue :: [T.Text] -> Value -> QM Value-resolveValue prevqueries value =- case value of- String t -> String <$> resolveText prevqueries t- Array arr -> Array <$> mapM (resolveValue prevqueries) arr- Object hh -> Object <$> mapM (resolveValue prevqueries) hh- _ -> return value--resolveText :: [T.Text] -> T.Text -> QM T.Text-resolveText prevqueries t- = case parseInterpolableString t of- Right qparts -> T.concat <$> mapM (resolveStringPart prevqueries) qparts- Left _ -> return t--resolveStringPart :: [T.Text] -> HieraStringPart -> QM T.Text-resolveStringPart prevqueries sp- = case sp of- HPString s -> return s- HPVariable varname -> do- let varsolve = fmap PString . preview (ix varname) <$> view qvars- r <- case T.stripPrefix "lookup('" varname >>= T.stripSuffix "')" of- Just lk -> recursiveQuery lk prevqueries- Nothing -> varsolve- case r of- Just (PString v) -> return v- _ -> return mempty--mergeWith :: HieraQueryType -> Value -> Value -> Either PrettyError Value-mergeWith qt cur new- = case qt of- QFirst -> return cur- QUnique ->- let getArray x = case x of- Array array -> V.toList array- _ -> [x]- curarray = getArray cur- newarray = getArray new- in case new of- Object _ -> throwError "Tried to merge a hash"- _ -> return (Array (V.fromList (L.nub (curarray ++ newarray))))- QHash -> case (cur, new) of- (Object curh, Object newh) -> return (Object (curh <> newh))- _ -> throwError (PrettyError ("Tried to merge things that are not hashes: " <> text (show cur) <+> text (show new)))- QDeep{} -> throwError "deep queries not supported"
− Puppet/Daemon.hs
@@ -1,204 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-module Puppet.Daemon (- Daemon(..)- , initDaemon- -- * Utils- , checkError- -- * Re-exports- , module Puppet.Interpreter.Types- , module Puppet.PP-) where--import Control.Exception-import Control.Exception.Lens-import Control.Lens hiding (Strict)-import qualified Data.Either.Strict as S-import Data.FileCache as FileCache-import qualified Data.Text as T-import qualified Data.Text.IO as T-import Data.Tuple.Strict-import qualified Data.Vector as V-import Debug.Trace (traceEventIO)-import Foreign.Ruby.Safe-import System.Exit (exitFailure)-import System.IO (stdout)-import qualified System.Log.Formatter as LOG (simpleLogFormatter)-import System.Log.Handler (setFormatter)-import qualified System.Log.Handler.Simple as LOG (streamHandler)-import qualified System.Log.Logger as LOG-import qualified Text.Megaparsec as P--import Erb.Compute-import Hiera.Server-import Puppet.Interpreter-import Puppet.Interpreter.IO-import Puppet.Interpreter.Types-import Puppet.Lens (_PrettyError)-import Puppet.Manifests-import Puppet.OptionalTests-import Puppet.Parser-import Puppet.Parser.Types-import Puppet.PP-import Puppet.Preferences-import Puppet.Stats-import Puppet.Utils--{-| API for the Daemon.-The main method is `getCatalog`: given a node and a list of facts, it returns the result of the compilation.-This will be either an error, or a tuple containing:--- all the resources in this catalog-- the dependency map-- the exported resources-- a list of known resources, that might not be up to date, but are here for code coverage tests.--Notes :--* It might be buggy when top level statements that are not class\/define\/nodes are altered.--}-data Daemon = Daemon- { getCatalog :: NodeName -> Facts -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))- , parserStats :: MStats- , catalogStats :: MStats- , templateStats :: MStats- }--{-| Entry point to get a Daemon-It will initialize the parsing and interpretation infrastructure from the 'Preferences'.--Internally it initializes a thread for the Ruby interpreter.-It should cache the AST of every .pp file, and could use a bit of memory. As a comparison, it-fits in 60 MB with the author's manifests, but really breathes when given 300 MB-of heap space. In this configuration, even if it spawns a ruby process for every-template evaluation, it is way faster than the puppet stack.--It can optionally talk with PuppetDB, by setting an URL via the 'prefPDB'.-The recommended way to set it to http://localhost:8080 and set a SSH tunnel :--> ssh -L 8080:localhost:8080 puppet.host--}-initDaemon :: Preferences IO -> IO Daemon-initDaemon pref = do- setupLogger (pref ^. prefLogLevel)- logDebug "initDaemon"- traceEventIO "initDaemon"- hquery <- case pref ^. prefHieraPath of- Just p -> either error id <$> startHiera p- Nothing -> return dummyHiera- fcache <- newFileCache- intr <- startRubyInterpreter- templStats <- newStats- getTemplate <- initTemplateDaemon intr pref templStats- catStats <- newStats- parseStats <- newStats- return (Daemon- (getCatalog' pref (parseFunc (pref ^. prefPuppetPaths) fcache parseStats) getTemplate catStats hquery)- parseStats- catStats- templStats- )----- | In case of a Left value, print the error and exit immediately-checkError :: Show e => Doc -> Either e a -> IO a-checkError desc = either exit return- where- exit = \err -> putDoc (display err) >> exitFailure- display err = red desc <> ": " <+> (string . show) err----- Internal functions--getCatalog' :: Preferences IO- -> ( TopLevelType -> T.Text -> IO (S.Either PrettyError Statement) )- -> (Either T.Text T.Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError T.Text))- -> MStats- -> HieraQueryFunc IO- -> NodeName- -> Facts- -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))-getCatalog' pref parsingfunc getTemplate stats hquery node facts = do- logDebug ("Received query for node " <> node)- traceEventIO ("START getCatalog' " <> T.unpack node)- let catalogComputation = interpretCatalog (InterpreterReader- (pref ^. prefNatTypes)- parsingfunc- getTemplate- (pref ^. prefPDB)- (pref ^. prefExtFuncs)- node- hquery- defaultImpureMethods- (pref ^. prefIgnoredmodules)- (pref ^. prefExternalmodules)- (pref ^. prefStrictness == Strict)- (pref ^. prefPuppetPaths)- )- node- facts- (pref ^. prefPuppetSettings)- (stmts :!: warnings) <- measure stats node catalogComputation- mapM_ (\(p :!: m) -> LOG.logM daemonLoggerName p (displayS (renderCompact (ttext node <> ":" <+> m)) "")) warnings- traceEventIO ("STOP getCatalog' " <> T.unpack node)- if pref ^. prefExtraTests- then runOptionalTests stmts- else return stmts- where- runOptionalTests stm = case stm ^? S._Right._1 of- Nothing -> return stm- (Just c) -> catching _PrettyError- (do {testCatalog pref c; return stm})- (return . S.Left)---- | Return an HOF that would parse the file associated with a toplevel.--- The toplevel is defined by the tuple (type, name)--- The result of the parsing is a single Statement (which recursively contains others statements)-parseFunc :: PuppetDirPaths -> FileCache (V.Vector Statement) -> MStats -> TopLevelType -> T.Text -> IO (S.Either PrettyError Statement)-parseFunc ppath filecache stats = \toptype topname ->- let nameparts = T.splitOn "::" topname in- let topLevelFilePath :: TopLevelType -> T.Text -> Either PrettyError T.Text- topLevelFilePath TopNode _ = Right $ T.pack (ppath^.manifestPath <> "/site.pp")- topLevelFilePath _ name- | length nameparts == 1 = Right $ T.pack (ppath^.modulesPath) <> "/" <> name <> "/manifests/init.pp"- | null nameparts = Left $ PrettyError ("Invalid toplevel" <+> squotes (ttext name))- | otherwise = Right $ T.pack (ppath^.modulesPath) <> "/" <> head nameparts <> "/manifests/" <> T.intercalate "/" (tail nameparts) <> ".pp"- in- case topLevelFilePath toptype topname of- Left rr -> return (S.Left rr)- Right fname -> do- let sfname = T.unpack fname- handleFailure :: SomeException -> IO (S.Either String (V.Vector Statement))- handleFailure e = return (S.Left (show e))- x <- measure stats fname (FileCache.query filecache sfname (parseFile sfname `catch` handleFailure))- case x of- S.Right stmts -> filterStatements toptype topname stmts- S.Left rr -> return (S.Left (PrettyError (red (text rr))))---parseFile :: FilePath -> IO (S.Either String (V.Vector Statement))-parseFile fname = do- traceEventIO ("START parsing " ++ fname)- cnt <- T.readFile fname- o <- case runPParser fname cnt of- Right r -> traceEventIO ("Stopped parsing " ++ fname) >> return (S.Right r)- Left rr -> traceEventIO ("Stopped parsing " ++ fname ++ " (failure: " ++ P.parseErrorPretty rr ++ ")") >> return (S.Left (P.parseErrorPretty rr))- traceEventIO ("STOP parsing " ++ fname)- return o--daemonLoggerName :: String-daemonLoggerName = "Puppet.Daemon"--logDebug :: T.Text -> IO ()-logDebug = LOG.debugM daemonLoggerName . T.unpack--setupLogger :: LOG.Priority -> IO ()-setupLogger p = do- LOG.updateGlobalLogger daemonLoggerName (LOG.setLevel p)- LOG.updateGlobalLogger hieraLoggerName (LOG.setLevel p)- hs <- consoleLogHandler- LOG.updateGlobalLogger LOG.rootLoggerName $ LOG.setHandlers [hs]- where- consoleLogHandler = setFormatter- <$> LOG.streamHandler stdout LOG.DEBUG- <*> pure (LOG.simpleLogFormatter "$prio: $msg")
− Puppet/Interpreter.hs
@@ -1,945 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}-module Puppet.Interpreter- ( interpretCatalog- , evaluateStatement- , computeCatalog- ) where--import Control.Applicative-import Control.Lens hiding (ignored)-import Control.Monad.Except-import Control.Monad.Operational hiding (view)-import Control.Monad.Trans.Except-import Data.Char (isDigit)-import qualified Data.Either.Strict as S-import Data.Foldable (foldl', foldlM, toList)-import qualified Data.Graph as G-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import Data.List (nubBy, sortBy)-import Data.Maybe-import qualified Data.Maybe.Strict as S-import Data.Ord (comparing)-import Data.Semigroup (Max(..))-import Data.Text (Text)-import qualified Data.Text as T-import Data.Traversable (for)-import qualified Data.Tree as T-import Data.Tuple.Strict (Pair (..))-import qualified Data.Vector as V-import System.Log.Logger--import Puppet.Interpreter.PrettyPrinter (containerComma)-import Puppet.Interpreter.Resolve-import Puppet.Interpreter.Types-import Puppet.Interpreter.Utils-import Puppet.Interpreter.IO-import Puppet.Lens-import Puppet.NativeTypes-import Puppet.Parser.PrettyPrinter-import Puppet.Parser.Types-import Puppet.Parser.Utils-import Puppet.PP-import Puppet.Utils--{-| Call the operational 'interpretMonad' function to compute the catalog.- Returns either an error, or a tuple containing all the resources,- dependency map, exported resources, and defined resources alongside with- all messages that have been generated by the compilation process.-- The later 'definedResources' (eg. all class declarations) are pulled out of the- 'InterpreterState' and might not be up to date.- There are only useful for coverage testing (checking dependencies for instance).--}-interpretCatalog :: Monad m- => InterpreterReader m -- ^ The whole environment required for computing catalog.- -> NodeName- -> Facts- -> Container Text -- ^ Server settings- -> m (Pair (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Priority Doc])-interpretCatalog interpretReader node facts settings = do- (output, _, warnings) <- interpretMonad interpretReader (initialState facts settings) (computeCatalog node)- return (strictifyEither output :!: warnings)--isParent :: Text -> CurContainerDesc -> InterpreterMonad Bool-isParent cur (ContClass possibleparent) = preuse (scopes . ix cur . scopeParent) >>= \case- Nothing -> throwPosError ("Internal error: could not find scope" <+> ttext cur <+> "possible parent" <+> ttext possibleparent)- Just S.Nothing -> return False- Just (S.Just p) -> if p == possibleparent- then return True- else isParent p (ContClass possibleparent)-isParent _ _ = return False---- | Apply resource defaults, references overrides and expand defines-finalize :: [Resource] -> InterpreterMonad [Resource]-finalize rx = do- scp <- getScopeName- resdefaults <- use (scopes . ix scp . scopeResDefaults)- let getOver = use (scopes . ix scp . scopeOverrides) -- retrieves current overrides- addResDefaults r = ifoldlM (addAttribute CantReplace) r resdefval- where resdefval = resdefaults ^. ix (r ^. rid . itype) . resDefValues- addOverrides r = getOver >>= foldlM addOverrides' r . view (at (r ^. rid))- addOverrides' r (ResRefOverride _ prms p) = do- -- we used this override, so we discard it- scopes . ix scp . scopeOverrides . at (r ^. rid) .= Nothing- let forb msg = throwPosError ("Override of parameters ("- <> list (map (ttext . fst) $ itoList prms)- <> ") of the following resource is forbidden in the current context:"- </> pretty r- <+> showPPos p- </> ":"- <+> msg)- s <- getScope- overrideType <- case r ^. rscope of- [] -> forb "Could not find the current resource context" -- we could not get the current resource context- (x:_) -> if x == s- then return CantOverride -- we are in the same context : can't replace, but add stuff- else isParent (scopeName s) x >>= \i ->- if i || (r ^. rid . itype == "class")- then return Replace -- we can override what's defined in a parent- else forb "Can't override something that was not defined in the parent."- ifoldlM (addAttribute overrideType) r prms- -- step 1, apply resDefaults and resRefOverride- withDefaults <- mapM (addOverrides >=> addResDefaults) rx- -- There might be some overrides that could not be applied. The only- -- valid reason is that they override something in exported resources.- --- -- it probably do something unexpected on defines, but let's keep it that way for now.- let keepforlater (ResRefOverride resid resprms ropos) = resMod %= (appended : )- where- appended = ResourceModifier (resid ^. itype) ModifierMustMatch DontRealize (REqualitySearch "title" (PString (resid ^. iname))) overrider ropos- overrider r = do- -- we must define if we can override the value- let canOverride = CantOverride -- TODO check inheritance- ifoldlM (addAttribute canOverride) r resprms- void $ getOver >>= mapM keepforlater- let expandableDefine r = do- n <- isNativeType (r ^. rid . itype)- -- if we have a native type, or a virtual/exported resource it- -- should not be expanded !- if n || r ^. rvirtuality /= Normal- then return [r]- else expandDefine r- -- Now that all defaults / override have been applied, the defines can- -- finally be expanded.- -- The reason it has to be there is that parameters of the define could- -- be affected.- concat <$> mapM expandableDefine withDefaults- where- expandDefine :: Resource -> InterpreterMonad [Resource]- expandDefine r =- let modulename = getModulename (r ^. rid)- in isIgnoredModule modulename >>= \i ->- if i- then return mempty- else do- let deftype = dropInitialColons (r ^. rid . itype)- defname = r ^. rid . iname- curContType = ContDefine deftype defname (r ^. rpos)- p <- use curPos- -- we add the relations of this define to the global list of relations- -- before dropping it, so that they are stored for the final- -- relationship resolving- let extr = do- (dstid, linkset) <- itoList (r ^. rrelations)- link <- toList linkset- return (LinkInformation (r ^. rid) dstid link p)- extraRelations <>= extr- void $ enterScope SENormal curContType modulename p- (spurious, stmt) <- interpretTopLevel TopDefine deftype- DefineDecl _ defineParams stmts cp <- extractPrism "expandDefine" _DefineDecl stmt- let isImported (ContImported _) = True- isImported _ = False- isImportedDefine <- isImported <$> getScope- curPos .= r ^. rpos- curscp <- getScope- when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp ))- pushScope curContType- loadVariable "title" (PString defname)- loadVariable "name" (PString defname)- -- not done through loadvariable because of override errors- loadParameters (r ^. rattributes) defineParams cp S.Nothing- curPos .= cp- res <- evaluateStatementsFoldable stmts- out <- finalize (spurious ++ res)- when isImportedDefine popScope- popScope- return out---- | Given a toplevel (type, name),--- return the associated parsed statement together with its evaluated resources-interpretTopLevel :: TopLevelType -> Text -> InterpreterMonad ([Resource], Statement)-interpretTopLevel toptype topname =- -- check if this is a known toplevel- use (nestedDeclarations . at (toptype, topname)) >>= \case- Just x -> return ([], x) -- it is known !- Nothing -> singleton (GetStatement toptype topname) >>= evalTopLevel- where- evalTopLevel :: Statement -> InterpreterMonad ([Resource], Statement)- evalTopLevel (TopContainer tops s) = do- pushScope ContRoot- r <- mapM evaluateStatement tops >>= finalize . concat- -- popScope- (nr, ns) <- evalTopLevel s- popScope- return (r <> nr, ns)- evalTopLevel x = return ([], x)---- | Main internal entry point, this function completes the interpretation--- TODO: add some doc here-computeCatalog :: NodeName -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource])-computeCatalog nodename = do- (topres, stmt) <- interpretTopLevel TopNode nodename- nd <- extractPrism "computeCatalog" _NodeDecl stmt- let finalStep [] = return []- finalStep allres = do- -- collect stuff and apply thingies- (realized :!: modified) <- realize allres- -- we need to run it again against collected stuff, especially- -- for custom types (defines) that have been realized- refinalized <- finalize (toList modified) >>= finalStep- -- replace the modified stuff- let res = foldl' (\curm e -> curm & at (e ^. rid) ?~ e) realized refinalized- return (toList res)-- mainstage = Resource (RIdentifier "stage" "main") mempty mempty mempty [ContRoot] Normal mempty dummyppos nodename-- evaluateNode :: NodeDecl -> InterpreterMonad [Resource]- evaluateNode (NodeDecl _ sx inheritnode p) = do- curPos .= p- pushScope ContRoot- unless (S.isNothing inheritnode) $ throwPosError "Node inheritance is not handled. It is deprecated since puppet v4"- mapM evaluateStatement sx >>= finalize . concat-- noderes <- evaluateNode nd >>= finalStep . (++ (mainstage : topres))- let (real :!: exported) = foldl' classify (mempty :!: mempty) noderes- -- Classify sorts resources between exported and normal ones. It- -- drops virtual resources, and puts in both categories resources- -- that are at the same time exported and realized.- classify :: Pair (HM.HashMap RIdentifier Resource) (HM.HashMap RIdentifier Resource)- -> Resource- -> Pair (HM.HashMap RIdentifier Resource) (HM.HashMap RIdentifier Resource)- classify (curr :!: cure) r =- let i curm = curm & at (r ^. rid) ?~ r- in case r ^. rvirtuality of- Normal -> i curr :!: cure- Exported -> curr :!: i cure- ExportedRealized -> i curr :!: i cure- _ -> curr :!: cure- verified <- HM.fromList . map (\r -> (r ^. rid, r)) <$> mapM validateNativeType (HM.elems real)- withResourceDependentRelations <- traverse getResourceDependentRelations verified- edgemap <- makeEdgeMap withResourceDependentRelations- definedRes <- use definedResources- return (withResourceDependentRelations, edgemap, exported, HM.elems definedRes)---- | This extracts additional relationships between resources, that are--- dependent on whether some resources are defined. A canonical example is--- is the 'owner' field in a File, that can create problems if it's--- defined!------ For this reason, this function only adds dependencies when the resources--- are defined.-getResourceDependentRelations :: Resource -> InterpreterMonad Resource-getResourceDependentRelations res = extract $ case res ^. rid . itype of- "file" -> [depOn "user" "owner", depOn "group" "group"]- "cron" -> [depOn "user" "user"]- "exec" -> [depOn "user" "user", depOn "group" "group"]- _ -> []- where- extract actions = do- newrelations <- fmap (foldl' (HM.unionWith (<>)) (res ^. rrelations)) (sequence actions)- return (res & rrelations .~ newrelations)- depOn :: Text -> Text -> InterpreterMonad (HM.HashMap RIdentifier (HS.HashSet LinkType))- depOn resType attributeName = case res ^? rattributes . ix attributeName of- Just (PString usr) -> do- let targetResourceId = RIdentifier resType usr- existing <- has (ix targetResourceId) <$> use definedResources- return $ if existing- then HM.singleton targetResourceId (HS.singleton RRequire)- else HM.empty- _ -> return HM.empty--makeEdgeMap :: FinalCatalog -> InterpreterMonad EdgeMap-makeEdgeMap ct = do- -- merge the loaded classes and resources- defs' <- HM.map (view rpos) <$> use definedResources- clss' <- use loadedClasses- let defs = defs' <> classes' <> aliases' <> names'- names' = HM.map (view rpos) ct- -- generate fake resources for all extra aliases- aliases' = ifromList $ do- r <- ct ^.. traversed :: [Resource]- extraAliases <- r ^.. ralias . folded . filtered (/= r ^. rid . iname) :: [Text]- return (r ^. rid & iname .~ extraAliases, r ^. rpos)- classes' = ifromList $ do- (cn, _ :!: cp) <- itoList clss'- return (RIdentifier "class" cn, cp)- -- Preparation step : all relations to a container become relations to- -- the stuff that's contained. We build a map of resources, stored by- -- container.- -- step 1 - add relations that are stored in resources- let reorderlink :: (RIdentifier, RIdentifier, LinkType) -> (RIdentifier, RIdentifier, LinkType)- reorderlink (s, d, RRequire) = (d, s, RBefore)- reorderlink (s, d, RSubscribe) = (d, s, RNotify)- reorderlink x = x- addRR curmap r = iunionWith (<>) curmap newmap- where- -- compute the explicit resources, along with the container relationship- newmap = ifromListWith (<>) resresources- resid = r ^. rid- respos = r ^. rpos- resresources :: [(RIdentifier, [LinkInformation])]- resresources = do- (rawdst, lts) <- itoList (r ^. rrelations)- lt <- toList lts- let (nsrc, ndst, nlt) = reorderlink (resid, rawdst, lt)- return (nsrc, [LinkInformation nsrc ndst nlt respos])- step1 :: HM.HashMap RIdentifier [LinkInformation]- step1 = foldl' addRR mempty ct- -- step 2 - add other relations (mainly stuff made from the "->"- -- operator)- let realign (LinkInformation s d t p) =- let (ns, nd, nt) = reorderlink (s, d, t)- in (ns, [LinkInformation ns nd nt p])- rels <- map realign <$> use extraRelations- let step2 = iunionWith (<>) step1 (ifromList rels)- -- check that all resources are defined, and build graph- let checkResDef :: (RIdentifier, [LinkInformation]) -> InterpreterMonad (RIdentifier, RIdentifier, [RIdentifier])- checkResDef (ri, lifs) = do- let checkExists r msg = do- let modulename = getModulename r- ignored <- isIgnoredModule modulename- unless (has (ix r) defs || ignored) (throwPosError msg)- errmsg = "Unknown resource" <+> pretty ri <+> "used in the following relationships:" <+> vcat (map pretty lifs)- checkExists ri errmsg- let genlnk :: LinkInformation -> InterpreterMonad RIdentifier- genlnk lif = do- let d = lif ^. linkdst- checkExists d ("Unknown resource" <+> pretty d <+> "used in a relation at" <+> showPPos (lif ^. linkPos))- return d- ds <- mapM genlnk lifs- return (ri, ri, ds)- edgeList <- mapM checkResDef (itoList step2)- let (graph, gresolver) = G.graphFromEdges' edgeList- -- now check for scc- let sccs = filter ((>1) . length . T.flatten) (G.scc graph)- unless (null sccs) $ do- let trees = vcat (map showtree sccs)- showtree = indent 2 . vcat . map (mkp . gresolver) . T.flatten- mkp (a,_,links) = resdesc <+> lnks- where- resdesc = case ct ^. at a of- Just r -> pretty r- _ -> pretty a- lnks = pretty links- throwPosError $ "Dependency error, the following resources are strongly connected!" </> trees- -- let edgePairs = concatMap (\(_,k,ls) -> [(k,l) | l <- ls]) edgeList- -- throwPosError (vcat (map (\(RIdentifier st sn, RIdentifier dt dn) -> "\"" <> ttext st <> ttext sn <> "\" -> \"" <> ttext dt <> ttext dn <> "\"") edgePairs))- return step2---- | This functions performs all the actions triggered by calls to the--- realize function or other collectors. It returns a pair of--- "finalcatalogs", where the first part is the new catalog, and the second--- part the map of all modified resources. The second part is needed so--- that we know for example which resources we should test for expansion--- (custom types).-realize :: [Resource] -> InterpreterMonad (Pair FinalCatalog FinalCatalog)-realize rs = do- let -- rma is the initial map of resources, indexed by resource identifier- rma = ifromList (map (\r -> (r ^. rid, r)) rs)- -- mutate runs all the resource modifiers (ie. realize, overrides- -- and other collectors). It stores the modified resources on the- -- "right" of the resulting pair.- mutate :: Pair FinalCatalog FinalCatalog -> ResourceModifier -> InterpreterMonad (Pair FinalCatalog FinalCatalog)- mutate (curmap :!: modified) rmod = do- let filtrd = curmap ^.. folded . filtered fmod -- all the resources that match the selector/realize criteria- vcheck f r = f (r ^. rvirtuality)- (isGoodvirtuality, alterVirtuality) = case rmod ^. rmType of- RealizeVirtual -> (vcheck (/= Exported), \r -> return (r & rvirtuality .~ Normal))- RealizeCollected -> (vcheck (`elem` [Exported, ExportedRealized]), \r -> return (r & rvirtuality .~ ExportedRealized))- DontRealize -> (vcheck (`elem` [Normal, ExportedRealized]), return)- fmod r = (r ^. rid . itype == rmod ^. rmResType) && checkSearchExpression (rmod ^. rmSearch) r && isGoodvirtuality r- mutation = alterVirtuality >=> rmod ^. rmMutation- applyModification :: Pair FinalCatalog FinalCatalog -> Resource -> InterpreterMonad (Pair FinalCatalog FinalCatalog)- applyModification (cma :!: cmo) r = do- nr <- mutation r- let i m = m & at (nr ^. rid) ?~ nr- return $ if nr /= r- then i cma :!: i cmo- else cma :!: cmo- result <- foldM applyModification (curmap :!: modified) filtrd -- apply the modifiation to all the matching resources- when (rmod ^. rmModifierType == ModifierMustMatch && null filtrd) (throwError (PrettyError ("Could not apply this resource override :" <+> pretty rmod <> ",no matching resource was found.")))- return result- equalModifier (ResourceModifier a1 b1 c1 d1 _ e1) (ResourceModifier a2 b2 c2 d2 _ e2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2- result <- use resMod >>= foldM mutate (rma :!: mempty) . reverse . nubBy equalModifier- resMod .= []- return result---- | Fold all attribute declarations--- checking for duplicates key locally inside a same resource.-fromAttributeDecls :: V.Vector AttributeDecl -> InterpreterMonad (Container PValue)-fromAttributeDecls = foldM resolve mempty- where- resolve acc (AttributeDecl k _ v) =- case acc ^. at k of- Just _ -> throwPosError ("Parameter" <+> dullyellow (ttext k) <+> "already defined!")- Nothing -> do- pv <- resolveExpression v- return (acc & at k ?~ pv)--saveCaptureVariables :: InterpreterMonad (HM.HashMap T.Text (Pair (Pair PValue PPosition) CurContainerDesc))-saveCaptureVariables = do- scp <- getScopeName- vars <- use (scopes . ix scp . scopeVariables)- return $ HM.filterWithKey (\k _ -> T.all isDigit k) vars--restoreCaptureVariables :: HM.HashMap T.Text (Pair (Pair PValue PPosition) CurContainerDesc) -> InterpreterMonad ()-restoreCaptureVariables vars = do- scp <- getScopeName- scopes . ix scp . scopeVariables %= HM.union vars . HM.filterWithKey (\k _ -> not (T.all isDigit k))--evaluateStatement :: Statement -> InterpreterMonad [Resource]-evaluateStatement r@(ClassDeclaration (ClassDecl cname _ _ _ _)) =- if "::" `T.isInfixOf` cname- then nestedDeclarations . at (TopClass, cname) ?= r >> return []- else do- scp <- getScopeName- let rcname = if scp == "::"- then cname- else scp <> "::" <> cname- nestedDeclarations . at (TopClass, rcname) ?= r- return []-evaluateStatement r@(DefineDeclaration (DefineDecl dname _ _ _)) =- if "::" `T.isInfixOf` dname- then nestedDeclarations . at (TopDefine, dname) ?= r >> return []- else do- scp <- getScopeName- if scp == "::"- then nestedDeclarations . at (TopDefine, dname) ?= r >> return []- else nestedDeclarations . at (TopDefine, scp <> "::" <> dname) ?= r >> return []-evaluateStatement r@(ResourceCollectionDeclaration (ResCollDecl ct rtype searchexp mods p)) = do- curPos .= p- unless (isEmpty mods || ct == Collector) (throwPosError ("It doesn't seem possible to amend attributes with an exported resource collector:" </> pretty r))- when (rtype == "class") (throwPosError "Classes cannot be collected")- rsearch <- resolveSearchExpression searchexp- let et = case ct of- Collector -> RealizeVirtual- ExportedCollector -> RealizeCollected- resMod %= (ResourceModifier rtype ModifierCollector et rsearch (\r' -> foldM modifyCollectedAttribute r' mods) p : )- -- Now collected from the PuppetDB !- if et == RealizeCollected- then do- let q = searchExpressionToPuppetDB rtype rsearch- fqdn <- getNodeName- -- we must filter the resources that originated from this host- -- here ! They are also turned into "normal" resources- res <- toListOf (folded- . filtered ( hasn't (rnode . only fqdn) )- . to (rvirtuality .~ Normal)- ) <$> singleton (PDBGetResources q)- scpdesc <- ContImported <$> getScope- void $ enterScope SENormal scpdesc "importing" p- pushScope scpdesc- o <- finalize res- popScope- return o- else return []-evaluateStatement (DependencyDeclaration (DepDecl (t1 :!: n1) (t2 :!: n2) lt p)) = do- curPos .= p- rn1 <- map (fixResourceName t1) <$> resolveExpressionStrings n1- rn2 <- map (fixResourceName t2) <$> resolveExpressionStrings n2- extraRelations <>= [ LinkInformation (normalizeRIdentifier t1 an1) (normalizeRIdentifier t2 an2) lt p | an1 <- rn1, an2 <- rn2 ]- return []-evaluateStatement (ResourceDeclaration (ResDecl t ern eargs virt p)) = do- curPos .= p- resnames <- resolveExpressionStrings ern- args <- fromAttributeDecls eargs- concat <$> mapM (\n -> registerResource t n args virt p) resnames-evaluateStatement (MainFunctionDeclaration (MainFuncDecl funcname funcargs p)) = do- curPos .= p- mapM resolveExpression (toList funcargs) >>= mainFunctionCall funcname-evaluateStatement (VarAssignmentDeclaration (VarAssignDecl varname varexpr p)) = do- curPos .= p- varval <- resolveExpression varexpr- loadVariable varname varval- return []-evaluateStatement (ConditionalDeclaration (ConditionalDecl conds p)) = do- curPos .= p- let checkCond [] = return []- checkCond ((e :!: stmts) : xs) = do- sv <- saveCaptureVariables- result <- pValue2Bool <$> resolveExpression e- if result- then evaluateStatementsFoldable stmts <* restoreCaptureVariables sv- else restoreCaptureVariables sv *> checkCond xs- checkCond (toList conds)-evaluateStatement (ResourceDefaultDeclaration (ResDefaultDecl rtype decls p)) = do- curPos .= p- rdecls <- fromAttributeDecls decls- scp <- getScopeName- -- invariant that must be respected : the current scope must be created- -- in "scopes", or nothing gets saved- preuse (scopes . ix scp) >>= maybe (throwPosError ("INTERNAL ERROR in evaluateStatement ResourceDefaultDeclaration: scope wasn't created - " <> pretty scp)) (const (return ()))- let newDefaults = ResDefaults rtype scp rdecls p- addDefaults x = scopes . ix scp . scopeResDefaults . at rtype ?= x- -- default merging with parent- mergedDefaults curdef = newDefaults & resDefValues .~ (rdecls <> (curdef ^. resDefValues))- preuse (scopes . ix scp . scopeResDefaults . ix rtype) >>= \case- Nothing -> addDefaults newDefaults- Just d -> if d ^. resDefSrcScope == scp- then throwPosError ("Defaults for resource" <+> ttext rtype <+> "already declared at" <+> showPPos (d ^. resDefPos))- else addDefaults (mergedDefaults d)- return []-evaluateStatement (ResourceOverrideDeclaration (ResOverrideDecl t urn eargs p)) = do- curPos .= p- raassignements <- fromAttributeDecls eargs- rn <- resolveExpressionString urn- scp <- getScopeName- curoverrides <- use (scopes . ix scp . scopeOverrides)- let rident = normalizeRIdentifier t rn- -- check that we didn't already override those values- withAssignements <- case curoverrides ^. at rident of- Just (ResRefOverride _ prevass prevpos) -> do- let cm = prevass `HM.intersection` raassignements- unless (isEmpty cm) (throwPosError ("The following parameters were already overriden at" <+> showPPos prevpos <+> ":" <+> containerComma cm))- return (prevass <> raassignements)- Nothing -> return raassignements- scopes . ix scp . scopeOverrides . at rident ?= ResRefOverride rident withAssignements p- return []-evaluateStatement (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl c p)) = curPos .= p >> evaluateHFC c- where- evaluateHFC :: HOLambdaCall -> InterpreterMonad [Resource]- evaluateHFC hf = do- varassocs <- hfGenerateAssociations hf- let runblock :: [(Text, PValue)] -> InterpreterMonad [Resource]- runblock assocs = do- saved <- hfSetvars assocs- res <- evaluateStatementsFoldable (hf ^. hoLambdaStatements)- hfRestorevars saved- return res- results <- mapM runblock varassocs- return (concat results)-evaluateStatement r = throwError (PrettyError ("Do not know how to evaluate this statement:" </> pretty r))---------------------------------------------------------------- Class evaluation--------------------------------------------------------------loadVariable :: Text -> PValue -> InterpreterMonad ()-loadVariable varname varval = do- curcont <- getCurContainer- scp <- getScopeName- p <- use curPos- scopeDefined <- has (ix scp) <$> use scopes- variableDefined <- preuse (scopes . ix scp . scopeVariables . ix varname)- case (scopeDefined, variableDefined) of- (False, _) -> throwPosError ("Internal error: trying to save a variable in unknown scope" <+> ttext scp)- (_, Just (_ :!: pp :!: ctx)) -> isParent scp (curcont ^. cctype) >>= \case- True -> do- debug("The variable"- <+> pretty (UVariableReference varname)- <+> "had been overriden because of some arbitrary inheritance rule that was set up to emulate puppet behaviour. It was defined at"- <+> showPPos pp- )- scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype)- False -> throwPosError ("Variable" <+> pretty (UVariableReference varname) <+> "already defined at" <+> showPPos pp- </> "Context:" <+> pretty ctx- </> "Value:" <+> pretty varval- </> "Current scope:" <+> ttext scp- )- _ -> scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype)---- | This function loads class and define parameters into scope. It checks--- that all mandatory parameters are set, that no extra parameter is--- declared.------ It is able to fill unset parameters with values from Hiera (for classes--- only) or default values.-loadParameters :: Foldable f => Container PValue -> f (Pair (Pair Text (S.Maybe DataType)) (S.Maybe Expression)) -> PPosition -> S.Maybe T.Text -> InterpreterMonad ()-loadParameters params classParams defaultPos wHiera = do- p <- use curPos- curPos .= defaultPos- let classParamSet = HS.fromList (classParams ^.. folded . _1 . _1)- spuriousParams = ikeys params `HS.difference` classParamSet- mclassdesc = S.maybe mempty ((\x -> mempty <+> "when including class" <+> x) . ttext) wHiera-- -- the following functions `throwE (Max False)` when there is no value, and `throwE (Max True)` when this value- -- in PUndef.- checkUndef :: Maybe PValue -> ExceptT (Max Bool) InterpreterMonad PValue- checkUndef Nothing = throwE (Max False)- checkUndef (Just PUndef) = throwE (Max True)- checkUndef (Just v) = return v-- checkHiera :: T.Text -> ExceptT (Max Bool) InterpreterMonad PValue- checkHiera k = case wHiera of- S.Nothing -> throwE (Max False)- S.Just classname -> lift (runHiera (classname <> "::" <> k) QFirst) >>= checkUndef-- checkDef :: T.Text -> ExceptT (Max Bool) InterpreterMonad PValue- checkDef k = checkUndef (params ^. at k)-- checkDefault :: S.Maybe Expression -> ExceptT (Max Bool) InterpreterMonad PValue- checkDefault S.Nothing = throwE (Max False)- checkDefault (S.Just expr) = lift (resolveExpression expr)-- unless (isEmpty spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ttext) $ toList spuriousParams) <> mclassdesc)-- -- try to set a value to all parameters- -- The order of evaluation is defined / hiera / default- unsetParams <- fmap concat $ for (toList classParams) $ \(k :!: mtype :!: defValue) -> do- ev <- runExceptT (checkDef k <|> checkHiera k <|> checkDefault defValue)- case ev of- Right v -> do- forM_ mtype $ \dt -> unless (datatypeMatch dt v) (throwPosError ("Expected type" <+> pretty dt <+> "for parameter" <+> pretty k <+> "but its value was:" <+> pretty v))- loadVariable k v >> return []- Left (Max True) -> loadVariable k PUndef >> return []- Left (Max False) -> return [k]- curPos .= p- unless (isEmpty unsetParams) $ throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ttext $ toList unsetParams) <> mclassdesc)---- | Enters a new scope, checks it is not already defined, and inherits the--- defaults from the current scope------ Inheriting the defaults is necessary for non native types, because they--- will be expanded in "finalize", so if this was not done, we would be--- expanding the defines without the defaults applied-enterScope :: ScopeEnteringContext- -> CurContainerDesc- -> Text- -> PPosition- -> InterpreterMonad Text-enterScope secontext cont modulename p = do- let scopename = scopeName cont- -- This is a special hack for inheritance, because at this time we- -- have not properly stacked the scopes.- curcaller <- case secontext of- SEParent l -> return (PString $ T.takeWhile (/=':') l)- _ -> resolveVariable "module_name"- scopeAlreadyDefined <- has (ix scopename) <$> use scopes- let isImported = case cont of- ContImported _ -> True- _ -> False- -- it is OK to reuse a scope related to imported stuff- unless (scopeAlreadyDefined && isImported) $ do- when scopeAlreadyDefined (throwPosError ("Internal error: scope" <+> brackets (ttext scopename) <+> "already defined when loading scope for" <+> pretty cont))- scp <- getScopeName- -- TODO fill tags- basescope <- case secontext of- SEChild prt -> do- parentscope <- use (scopes . at prt)- when (isNothing parentscope) (throwPosError ("Internal error: could not find parent scope" <+> ttext prt))- let Just psc = parentscope- return (psc & scopeParent .~ S.Just prt)- _ -> do- curdefs <- use (scopes . ix scp . scopeResDefaults)- return $ ScopeInformation mempty curdefs mempty (CurContainer cont mempty) mempty S.Nothing- scopes . at scopename ?= basescope- scopes . ix scopename . scopeVariables . at "caller_module_name" ?= (curcaller :!: p :!: cont)- scopes . ix "::" . scopeVariables . at "calling_module" ?= (curcaller :!: p :!: cont)- scopes . ix scopename . scopeVariables . at "module_name" ?= (PString modulename :!: p :!: cont)- debug ("enterScope, scopename=" <> ttext scopename <+> "caller_module_name=" <> pretty curcaller <+> "module_name=" <> ttext modulename)- return scopename--loadClass :: Text- -> S.Maybe Text -- ^ Set if this is an inheritance load, so that we can set calling module properly- -> Container PValue- -> ClassIncludeType- -> InterpreterMonad [Resource]-loadClass name loadedfrom params incltype = do- let name' = dropInitialColons name- ndn <- getNodeName- singleton (TraceEvent ('[' : T.unpack ndn ++ "] loadClass " ++ T.unpack name'))- p <- use curPos- -- check if the class has already been loaded- -- http://docs.puppetlabs.com/puppet/3/reference/lang_classes.html#using-resource-like-declarations- preuse (loadedClasses . ix name' . _2) >>= \case- Just pp -> case incltype of- ClassIncludeLike -> return []- _ -> throwPosError ("Can't include class" <+> ttext name' <+> "twice when using the resource-like syntax (first occurence at"- <+> showPPos pp <> ")")- Nothing -> do- loadedClasses . at name' ?= (incltype :!: p)- let modulename = getModulename (RIdentifier "class" name')- ignored <- isIgnoredModule modulename- if ignored- then return mempty- else do- -- load the actual class, note we are not changing the current position right now- (spurious, stmt) <- interpretTopLevel TopClass name'- ClassDecl _ classParams inh stmts cp <- extractPrism "loadClass" _ClassDecl stmt- -- check if we need to define a resource representing the class- -- This will be the case for the first standard include- inhstmts <- case inh of- S.Nothing -> return []- S.Just ihname -> loadClass ihname (S.Just name') mempty ClassIncludeLike- let !scopedesc = ContClass name'- secontext = case (inh, loadedfrom) of- (S.Just x,_) -> SEChild (dropInitialColons x)- (_,S.Just x) -> SEParent (dropInitialColons x)- _ -> SENormal- void $ enterScope secontext scopedesc modulename p- classresource <- if incltype == ClassIncludeLike- then do- scp <- use curScope- fqdn <- getNodeName- return [Resource (RIdentifier "class" name') (HS.singleton name') mempty mempty scp Normal mempty p fqdn]- else return []- pushScope scopedesc- loadVariable "title" (PString name')- loadVariable "name" (PString name')- loadParameters params classParams cp (S.Just name')- curPos .= cp- res <- evaluateStatementsFoldable stmts- out <- finalize (classresource ++ spurious ++ inhstmts ++ res)- popScope- return out---------------------------------------------------------------- Resource stuff--------------------------------------------------------------addRelationship :: LinkType -> PValue -> Resource -> InterpreterMonad Resource-addRelationship lt (PResourceReference dt dn) r = return (r & rrelations %~ insertLt)- where- insertLt = iinsertWith (<>) (normalizeRIdentifier dt dn) (HS.singleton lt)-addRelationship lt (PArray vals) r = foldlM (flip (addRelationship lt)) r vals-addRelationship _ PUndef r = return r-addRelationship _ notrr _ = throwPosError ("Expected a resource reference, not:" <+> pretty notrr)--addTagResource :: Resource -> Text -> Resource-addTagResource r rv = r & rtags . contains rv .~ True--addAttribute :: OverrideType -> Text -> Resource -> PValue -> InterpreterMonad Resource-addAttribute _ "alias" r v = (\rv -> r & ralias . contains rv .~ True) <$> resolvePValueString v-addAttribute _ "audit" r _ = use curPos >>= \p -> warn ("Metaparameter audit ignored at" <+> showPPos p) >> return r-addAttribute _ "loglevel" r _ = use curPos >>= \p -> warn ("Metaparameter loglevel ignored at" <+> showPPos p) >> return r-addAttribute _ "schedule" r _ = use curPos >>= \p -> warn ("Metaparameter schedule ignored at" <+> showPPos p) >> return r-addAttribute _ "stage" r _ = use curPos >>= \p -> warn ("Metaparameter stage ignored at" <+> showPPos p) >> return r-addAttribute _ "tag" r (PArray v) = foldM (\cr cv -> addTagResource cr <$> resolvePValueString cv) r (toList v)-addAttribute _ "tag" r v = addTagResource r <$> resolvePValueString v-addAttribute _ "before" r d = addRelationship RBefore d r-addAttribute _ "notify" r d = addRelationship RNotify d r-addAttribute _ "require" r d = addRelationship RRequire d r-addAttribute _ "subscribe" r d = addRelationship RSubscribe d r-addAttribute b t r v = go t r v- where- go = case b of- CantOverride -> setAttribute- Replace -> overrideAttribute- CantReplace -> defaultAttribute- AppendAttribute -> appendAttribute--setAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource-setAttribute attributename res value = case res ^. rattributes . at attributename of- Nothing -> return (res & rattributes . at attributename ?~ value)- Just curval -> do- -- we must check if the resource scope is- -- a parent of the current scope- curscope <- getScopeName- i <- isParent curscope (rcurcontainer res)- if i- -- TODO check why this is set- then return (res & rattributes . at attributename ?~ value)- else do- -- We will not bark if the same attribute- -- is defined multiple times with identical- -- values.- let errmsg = "Attribute" <+> dullmagenta (ttext attributename) <+> "defined multiple times for" <+> pretty res- if curval == value- then checkStrict errmsg errmsg- else throwPosError errmsg- return res--overrideAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource-overrideAttribute attributename res value = return (res & rattributes . at attributename ?~ value)--appendAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource-appendAttribute attributename res value = do- nvalue <- case (res ^. rattributes . at attributename, value) of- (Nothing, _) -> return value- (Just (PArray a), PArray b) -> return (PArray (a <> b))- (Just (PArray a), b) -> return (PArray (V.snoc a b))- (Just a, PArray b) -> return (PArray (V.cons a b))- (Just a, b) -> return (PArray (V.fromList [a,b]))- return (res & rattributes . at attributename ?~ nvalue)--defaultAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource-defaultAttribute attributename res value = return $ case res ^. rattributes . at attributename of- Nothing -> res & rattributes . at attributename ?~ value- Just _ -> res--modifyCollectedAttribute :: Resource -> AttributeDecl -> InterpreterMonad Resource-modifyCollectedAttribute res (AttributeDecl attributename arrowop expr) = do- value <- resolveExpression expr- let optype = case arrowop of- AppendArrow -> AppendAttribute- AssignArrow -> Replace- addAttribute optype attributename res value--registerResource :: Text -> T.Text -> Container PValue -> Virtuality -> PPosition -> InterpreterMonad [Resource]-registerResource "class" _ _ Virtual p = curPos .= p >> throwPosError "Cannot declare a virtual class (or perhaps you can, but I do not know what this means)"-registerResource "class" _ _ Exported p = curPos .= p >> throwPosError "Cannot declare an exported class (or perhaps you can, but I do not know what this means)"-registerResource t rn arg vrt p = do- curPos .= p- CurContainer cnt tgs <- getCurContainer- -- default tags- -- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#automatic-tagging- -- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#containment- let !defaulttags = {-# SCC "rrGetTags" #-} HS.fromList (t : classtags) <> tgs- allsegs x = x : T.splitOn "::" x- (!classtags, !defaultLink) = getClassTags cnt- getClassTags (ContClass cn ) = (allsegs cn,RIdentifier "class" cn)- getClassTags (ContDefine dt dn _) = (allsegs dt,normalizeRIdentifier dt dn)- getClassTags ContRoot = ([],RIdentifier "class" "::")- getClassTags (ContImported _ ) = ([],RIdentifier "class" "::")- getClassTags (ContImport _ _ ) = ([],RIdentifier "class" "::")- defaultRelation = HM.singleton defaultLink (HS.singleton RRequire)- allScope <- use curScope- fqdn <- getNodeName- let baseresource = Resource (normalizeRIdentifier t rn) (HS.singleton rn) mempty defaultRelation allScope vrt defaulttags p fqdn- r <- ifoldlM (addAttribute CantOverride) baseresource arg- let resid = normalizeRIdentifier t rn- case t of- "class" -> {-# SCC "rrClass" #-} do- definedResources . at resid ?= r- let attrs = r ^. rattributes- (r:) <$> loadClass rn S.Nothing attrs ClassResourceLike- _ -> {-# SCC "rrGeneralCase" #-}- use (definedResources . at resid) >>= \case- Just otheres -> throwPosError ("Resource" <+> pretty resid <+> "already defined:" </>- pretty r </>- pretty otheres- )- Nothing -> do- definedResources . at resid ?= r- return [r]----- functions : this can't really be exported as it uses a lot of stuff from--- this module ...-mainFunctionCall :: Text -> [PValue] -> InterpreterMonad [Resource]-mainFunctionCall "showscope" _ = use curScope >>= warn . pretty >> return []--- The logging functions-mainFunctionCall "alert" a = logWithModifier ALERT red a-mainFunctionCall "crit" a = logWithModifier CRITICAL red a-mainFunctionCall "debug" a = logWithModifier DEBUG dullwhite a-mainFunctionCall "emerg" a = logWithModifier EMERGENCY red a-mainFunctionCall "err" a = logWithModifier ERROR dullred a-mainFunctionCall "info" a = logWithModifier INFO green a-mainFunctionCall "notice" a = logWithModifier NOTICE white a-mainFunctionCall "warning" a = logWithModifier WARNING dullyellow a-mainFunctionCall "contain" includes = concat <$> mapM doContain includes- where doContain e = do- classname <- resolvePValueString e- use (loadedClasses . at classname) >>= \case- Nothing -> loadClass classname S.Nothing mempty ClassIncludeLike- Just _ -> return [] -- TODO check that this happened after class declaration-mainFunctionCall "include" includes = concat <$> mapM doInclude includes- where doInclude e = do- classname <- resolvePValueString e- loadClass classname S.Nothing mempty ClassIncludeLike-mainFunctionCall "create_resources" [t, hs] = mainFunctionCall "create_resources" [t, hs, PHash mempty]-mainFunctionCall "create_resources" [PString t, PHash hs, PHash defparams] = do- let (ats, t') = T.span (== '@') t- virtuality <- case T.length ats of- 0 -> return Normal- 1 -> return Virtual- 2 -> return Exported- _ -> throwPosError "Too many @'s"- p <- use curPos- let genRes rname (PHash rargs) = registerResource t' rname (rargs <> defparams) virtuality p- genRes rname x = throwPosError ("create_resource(): the value corresponding to key" <+> ttext rname <+> "should be a hash, not" <+> pretty x)- concat . HM.elems <$> itraverse genRes hs-mainFunctionCall "create_resources" args = throwPosError ("create_resource(): expects between two and three arguments, of type [string,hash,hash], and not:" <+> pretty args)-mainFunctionCall "ensure_packages" args = ensurePackages args-mainFunctionCall "ensure_resource" args = ensureResource args-mainFunctionCall "realize" args = do- pos <- use curPos- let updateMod (PResourceReference t rn) = resMod %= (ResourceModifier t ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) return pos : )- updateMod x = throwPosError ("realize(): all arguments must be resource references, not" <+> pretty x)- mapM_ updateMod args- return []-mainFunctionCall "tag" args = do- scp <- getScopeName- let addTag x = scopes . ix scp . scopeExtraTags . contains x .= True- mapM_ (resolvePValueString >=> addTag) args- return []-mainFunctionCall "fail" [x] = ("fail:" <+>) . dullred . ttext <$> resolvePValueString x >>= throwPosError-mainFunctionCall "fail" _ = throwPosError "fail(): This function takes a single argument"-mainFunctionCall "hiera_include" [x] = do- ndname <- resolvePValueString x- classes <- toListOf (traverse . _PArray . traverse) <$> runHiera ndname QUnique- p <- use curPos- curPos . _1 . lSourceName <>= " [hiera_include call]"- o <- mainFunctionCall "include" classes- curPos .= p- return o-mainFunctionCall "hiera_include" _ = throwPosError "hiera_include(): This function takes a single argument"-mainFunctionCall "dumpinfos" _ = do- let prntline = logWriter ALERT- indentln = (<>) " "- prntline "Scope stack :"- scps <- use curScope- mapM_ (prntline . indentln . pretty) scps- prntline "Variables in local scope :"- scp <- getScopeName- vars <- use (scopes . ix scp . scopeVariables)- forM_ (sortBy (comparing fst) (itoList vars)) $ \(idx, pv :!: _ :!: _) -> prntline $ indentln $ ttext idx <> " -> " <> pretty pv- return []-mainFunctionCall fname args = do- p <- use curPos- let representation = MainFunctionDeclaration (MainFuncDecl 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 []--ensurePackages :: [PValue] -> InterpreterMonad [Resource]-ensurePackages [packages] = ensurePackages [packages, PHash mempty]-ensurePackages [PString p, x] = ensurePackages [ PArray (V.singleton (PString p)), x ]-ensurePackages [PArray packages, PHash defparams] = do- checkStrict "The use of the 'ensure_packages' function is a code smell."- "The 'ensure_packages' function is not allowed in strict mode."- concat <$> for packages (resolvePValueString >=> ensureResource' "package" (HM.singleton "ensure" "present" <> defparams))-ensurePackages [PArray _,_] = throwPosError "ensure_packages(): the second argument must be a hash."-ensurePackages [_,_] = throwPosError "ensure_packages(): the first argument must be a string or an array of strings."-ensurePackages _ = throwPosError "ensure_packages(): requires one or two arguments."---- | Takes a resource type, title, and a hash of attributes that describe the resource--- Create the resource if it does not exist alreadyTakes a resource type, title, and a hash of attributes that describe the resource(s).-ensureResource :: [PValue] -> InterpreterMonad [Resource]-ensureResource [PString t, PString title, PHash params] = do- checkStrict "The use of the 'ensure_resource' function is a code smell."- "The 'ensure_resource' function is not allowed in strict mode."- ensureResource' t params title-ensureResource [t, PArray arr, params] = concat <$> mapM (\r -> ensureResource [t, r, params]) (V.toList arr)-ensureResource [t,title] = ensureResource [t,title,PHash mempty]-ensureResource [_, PString _, PHash _] = throwPosError "ensureResource(): The first argument must be a string."-ensureResource [PString _, _, PHash _] = throwPosError "ensureResource(): The second argument must be a string."-ensureResource [PString _, PString _, _] = throwPosError "ensureResource(): The thrid argument must be a hash."-ensureResource _ = throwPosError "ensureResource(): expects 2 or 3 arguments."--ensureResource' :: Text -> HM.HashMap T.Text PValue -> T.Text -> InterpreterMonad [Resource]-ensureResource' t params title = do- isdefined <- has (ix (normalizeRIdentifier t title)) <$> use definedResources- if isdefined- then return []- else use curPos >>= registerResource t title params Normal----------------------------------------------------------------- Specific utils functions that depends on this modules--------------------------------------------------------------evaluateStatementsFoldable :: Foldable f => f Statement -> InterpreterMonad [Resource]-evaluateStatementsFoldable = fmap concat . mapM evaluateStatement . toList---- A helper function for the various loggers-logWithModifier :: Priority -> (Doc -> Doc) -> [PValue] -> InterpreterMonad [Resource]-logWithModifier prio m [v] = do- p <- use curPos- v' <- resolvePValueString v- logWriter prio (m (ttext v') <+> showPPos p)- return []-logWithModifier _ _ _ = throwPosError "This function takes a single argument"
− Puppet/Interpreter/IO.hs
@@ -1,103 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}---- | This is an internal module.-module Puppet.Interpreter.IO (- defaultImpureMethods- , interpretMonad- ) where--import Control.Exception-import Control.Lens-import Control.Monad.Operational-import Control.Monad.State.Strict-import Control.Monad.Trans.Except-import qualified Data.Either.Strict as S-import Data.Monoid-import qualified Data.Text as T-import qualified Data.Text.IO as T-import Debug.Trace (traceEventIO)-import GHC.Stack--import Puppet.Interpreter.PrettyPrinter ()-import Puppet.Interpreter.Types-import Puppet.PP--defaultImpureMethods :: MonadIO m => IoMethods m-defaultImpureMethods = IoMethods (liftIO currentCallStack)- (liftIO . file)- (liftIO . traceEventIO)- where- file [] = return $ Left ""- file (x:xs) = (Right <$> T.readFile (T.unpack x)) `catch` (\SomeException{} -> file xs)----- | The operational interpreter function-interpretMonad :: Monad m- => InterpreterReader m- -> InterpreterState- -> InterpreterMonad a- -> m (Either PrettyError a, InterpreterState, InterpreterWriter)-interpretMonad r s0 instr = let (!p, !s1) = runState (viewT instr) s0- in eval r s1 p---- The internal (not exposed) eval function-eval :: Monad m- => InterpreterReader m- -> InterpreterState- -> ProgramViewT InterpreterInstr (State InterpreterState) a- -> m (Either PrettyError a, InterpreterState, InterpreterWriter)-eval _ s (Return x) = return (Right x, s, mempty)-eval r s (a :>>= k) =- let runInstr = interpretMonad r s . k -- run one instruction- thpe = interpretMonad r s . throwPosError . getError- pdb = r^.readerPdbApi- strFail iof errf = iof >>= \case- Left rr -> thpe (errf (string rr))- Right x -> runInstr x- canFail iof = iof >>= \case- S.Left err -> thpe err- S.Right x -> runInstr x- canFailX iof = runExceptT iof >>= \case- Left err -> thpe err- Right x -> runInstr x- logStuff x c = (_3 %~ (x <>)) <$> c- in case a of- IsStrict -> runInstr (r ^. readerIsStrict)- ExternalFunction fname args -> case r ^. readerExternalFunc . at fname of- Just fn -> interpretMonad r s ( fn args >>= k)- Nothing -> thpe (PrettyError ("Unknown function: " <> ttext fname))- GetStatement topleveltype toplevelname- -> canFail ((r ^. readerGetStatement) topleveltype toplevelname)- ComputeTemplate fn stt -> canFail ((r ^. readerGetTemplate) fn stt r)- WriterTell t -> logStuff t (runInstr ())- WriterPass _ -> thpe "WriterPass"- WriterListen _ -> thpe "WriterListen"- PuppetPaths -> runInstr (r ^. readerPuppetPaths)- GetNativeTypes -> runInstr (r ^. readerNativeTypes)- ErrorThrow d -> return (Left d, s, mempty)- GetNodeName -> runInstr (r ^. readerNodename)- HieraQuery scps q t -> canFail ((r ^. readerHieraQuery) scps q t)- PDBInformation -> pdbInformation pdb >>= runInstr- PDBReplaceCatalog w -> canFailX (replaceCatalog pdb w)- PDBReplaceFacts fcts -> canFailX (replaceFacts pdb fcts)- PDBDeactivateNode nn -> canFailX (deactivateNode pdb nn)- PDBGetFacts q -> canFailX (getFacts pdb q)- PDBGetResources q -> canFailX (getResources pdb q)- PDBGetNodes q -> canFailX (getNodes pdb q)- PDBCommitDB -> canFailX (commitDB pdb)- PDBGetResourcesOfNode nn q -> canFailX (getResourcesOfNode pdb nn q)- GetCurrentCallStack -> (r ^. readerIoMethods . ioGetCurrentCallStack) >>= runInstr- ReadFile fls -> strFail ((r ^. readerIoMethods . ioReadFile) fls) (const $ PrettyError ("No file found in " <> list (map ttext fls)))- TraceEvent e -> (r ^. readerIoMethods . ioTraceEvent) e >>= runInstr- IsIgnoredModule m -> runInstr (r ^. readerIgnoredModules . contains m)- IsExternalModule m -> runInstr (r ^. readerExternalModules . contains m)- -- on error, the program state is RESET and the logged messages are dropped- ErrorCatch atry ahandle -> do- (eres, s', w) <- interpretMonad r s atry- case eres of- Left rr -> interpretMonad r s (ahandle rr >>= k)- Right x -> logStuff w (interpretMonad r s' (k x))
− Puppet/Interpreter/PrettyPrinter.hs
@@ -1,166 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE GADTs #-}-module Puppet.Interpreter.PrettyPrinter(containerComma) where--import Puppet.Interpreter.Types-import Puppet.Parser.PrettyPrinter-import Puppet.Parser.Types-import Puppet.PP-import Puppet.Utils--import Control.Arrow (first, second)-import Control.Lens-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import Data.List-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Vector as V-import GHC.Exts--import Data.Aeson (ToJSON, encode)-import Prelude hiding ((<$>))-import Text.PrettyPrint.ANSI.Leijen ((<$>))--containerComma'' :: Pretty a => [(Doc, a)] -> Doc-containerComma'' x = indent 2 ins- where- ins = mconcat $ intersperse (comma <$> empty) (map showC x)- showC (a,b) = a <+> text "=>" <+> pretty b--containerComma' :: Pretty a => [(Doc, a)] -> Doc-containerComma' = braces . containerComma''--containerComma :: Pretty a => Container a -> Doc-containerComma hm = containerComma' (map (\(a,b) -> (fill maxalign (pretty a), b)) hml)- where- hml = HM.toList hm- maxalign = maximum (map (T.length . fst) hml)--instance Pretty Text where- pretty = ttext--instance Pretty PValue where- pretty (PBoolean True) = dullmagenta $ text "true"- pretty (PBoolean False) = dullmagenta $ text "false"- pretty (PString s) = dullcyan (ttext (stringEscape s))- pretty (PNumber n) = cyan (ttext (scientific2text n))- pretty PUndef = dullmagenta (text "undef")- pretty (PResourceReference t n) = capitalize t <> brackets (text (T.unpack n))- pretty (PArray v) = list (map pretty (V.toList v))- pretty (PHash g) = containerComma g- pretty (PType dt) = pretty dt--instance Pretty TopLevelType where- pretty TopNode = dullyellow (text "node")- pretty TopDefine = dullyellow (text "define")- pretty TopClass = dullyellow (text "class")--instance Pretty RIdentifier where- pretty (RIdentifier t n) = pretty (PResourceReference t n)--meta :: Resource -> Doc-meta r = showPPos (r ^. rpos) <+> green (node <+> brackets scp)- where- node = red (ttext (r ^. rnode))- scp = "Scope" <+> pretty (r ^.. rscope . folded . filtered (/=ContRoot) . to pretty)--resourceBody :: Resource -> Doc-resourceBody r = virtuality <> blue (ttext (r ^. rid . iname)) <> ":" <+> meta r <$> containerComma'' insde <> ";"- where- virtuality = case r ^. rvirtuality of- Normal -> empty- Virtual -> dullred "@"- Exported -> dullred "@@"- ExportedRealized -> dullred "<@@>"- insde = alignlst dullblue attriblist1 ++ alignlst dullmagenta attriblist2- alignlst col = map (first (fill maxalign . col . ttext))- attriblist1 = sortWith fst $ HM.toList (r ^. rattributes) ++ aliasdiff- aliasWithoutTitle = r ^. ralias & contains (r ^. rid . iname) .~ False- aliasPValue = aliasWithoutTitle & PArray . V.fromList . map PString . HS.toList- aliasdiff | HS.null aliasWithoutTitle = []- | otherwise = [("alias", aliasPValue)]- attriblist2 = map totext (resourceRelations r)- totext (RIdentifier t n, lt) = (rel2text lt , PResourceReference t n)- maxalign = max (maxalign' attriblist1) (maxalign' attriblist2)- maxalign' [] = 0- maxalign' x = maximum . map (T.length . fst) $ x--resourceRelations :: Resource -> [(RIdentifier, LinkType)]-resourceRelations = concatMap expandSet . HM.toList . view rrelations- where- expandSet (ri, lts) = [(ri, lt) | lt <- HS.toList lts]--instance Pretty Resource where- prettyList lst =- let grouped = HM.toList $ HM.fromListWith (++) [ (r ^. rid . itype, [r]) | r <- lst ] :: [ (Text, [Resource]) ]- sorted = sortWith fst (map (second (sortWith (view (rid.iname)))) grouped)- showGroup :: (Text, [Resource]) -> Doc- showGroup (rt, res) = dullyellow (ttext rt) <+> lbrace <$> indent 2 (vcat (map resourceBody res)) <$> rbrace- in vcat (map showGroup sorted)- pretty r = dullyellow (ttext (r ^. rid . itype)) <+> lbrace <$> indent 2 (resourceBody r) <$> rbrace--instance Pretty CurContainerDesc where- pretty (ContImport p x) = magenta "import" <> braces (ttext p) <> braces (pretty x)- pretty (ContImported x) = magenta "imported" <> braces (pretty x)- pretty ContRoot = dullyellow (text "::")- pretty (ContClass cname) = dullyellow (text "class") <+> dullgreen (text (T.unpack cname))- pretty (ContDefine dtype dname _) = pretty (PResourceReference dtype dname)--instance Pretty ResDefaults where- pretty (ResDefaults t _ v p) = capitalize t <+> showPPos p <$> containerComma v--instance Pretty ResourceModifier where- pretty (ResourceModifier rt ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString x)) _ p) = "realize" <> parens (pretty (PResourceReference rt x)) <+> showPPos p- -- pretty (ResourceModifier rt ModifierCollector ct (REqualitySearch _ (PString x)) _ p) = "collect" <> parens (pretty (PResourceReference rt x)) <+> showPPos p- pretty _ = "TODO pretty ResourceModifier"--instance Pretty RSearchExpression where- pretty (REqualitySearch a v) = ttext a <+> "==" <+> pretty v- pretty (RNonEqualitySearch a v) = ttext a <+> "!=" <+> pretty v- pretty (RAndSearch a b) = parens (pretty a) <+> "&&" <+> parens (pretty b)- pretty (ROrSearch a b) = parens (pretty a) <+> "||" <+> parens (pretty b)- pretty RAlwaysTrue = mempty--pf :: Doc -> [Doc] -> Doc-pf fn args = bold (red fn) <> tupled (map pretty args)--showQuery :: ToJSON a => Query a -> Doc-showQuery = string . BSL.unpack . encode--instance Pretty (InterpreterInstr a) where- pretty PuppetPaths = pf "PuppetPathes" []- pretty IsStrict = pf "IsStrict" []- pretty GetNativeTypes = pf "GetNativeTypes" []- pretty (GetStatement tlt nm) = pf "GetStatement" [pretty tlt,ttext nm]- pretty (ComputeTemplate fn _) = pf "ComputeTemplate" [fn']- where- fn' = case fn of- Left content -> pretty (PString content)- Right filena -> ttext filena- pretty (ExternalFunction fn args) = pf (ttext fn) (map pretty args)- pretty GetNodeName = pf "GetNodeName" []- pretty (HieraQuery _ q _) = pf "HieraQuery" [ttext q]- pretty GetCurrentCallStack = pf "GetCurrentCallStack" []- pretty (ErrorThrow rr) = pf "ErrorThrow" [getError rr]- pretty (ErrorCatch _ _) = pf "ErrorCatch" []- pretty (WriterTell t) = pf "WriterTell" (map (pretty . view _2) t)- pretty (WriterPass _) = pf "WriterPass" []- pretty (WriterListen _) = pf "WriterListen" []- pretty PDBInformation = pf "PDBInformation" []- pretty (PDBReplaceCatalog _) = pf "PDBReplaceCatalog" ["..."]- pretty (PDBReplaceFacts _) = pf "PDBReplaceFacts" ["..."]- pretty (PDBDeactivateNode n) = pf "PDBDeactivateNode" [ttext n]- pretty (PDBGetFacts q) = pf "PDBGetFacts" [showQuery q]- pretty (PDBGetResources q) = pf "PDBGetResources" [showQuery q]- pretty (PDBGetNodes q) = pf "PDBGetNodes" [showQuery q]- pretty PDBCommitDB = pf "PDBCommitDB" []- pretty (PDBGetResourcesOfNode n q) = pf "PDBGetResourcesOfNode" [ttext n, showQuery q]- pretty (ReadFile f) = pf "ReadFile" (map ttext f)- pretty (TraceEvent e) = pf "TraceEvent" [string e]- pretty (IsIgnoredModule m) = pf "IsIgnoredModule" [ttext m]- pretty (IsExternalModule m) = pf "IsExternalModule" [ttext m]--instance Pretty LinkInformation where- pretty (LinkInformation lsrc ldst ltype lpos) = pretty lsrc <+> pretty ltype <+> pretty ldst <+> showPPos lpos
− Puppet/Interpreter/Pure.hs
@@ -1,157 +0,0 @@--- | This is a set of pure helpers for evaluation the 'InterpreterMonad'--- function that can be found in "Puppet.Interpreter" and--- "Puppet.Interpreter.Resolve". They are used to power some prisms from--- "Puppet.Lens".------ > > dummyEval (resolveExpression (Addition "1" "2"))--- > Right (PString "3")-module Puppet.Interpreter.Pure where--import Control.Lens-import qualified Data.Either.Strict as S-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T--import Erb.Evaluate-import Erb.Parser-import Puppet.Interpreter.IO-import Puppet.Interpreter.Types-import Puppet.Interpreter.Utils-import Puppet.NativeTypes-import Puppet.Parser.Types-import Puppet.Paths-import Puppet.PP-import PuppetDB.Dummy----- | Worst name ever, this is a set of pure stub for the 'ImpureMethods'--- type.-impurePure :: IoMethods Identity-impurePure = IoMethods (return []) (const (return (Left "Can't read file"))) (\_ -> return ())---- | A pure 'InterpreterReader', that can only evaluate a subset of the--- templates, and that can include only the supplied top level statements.-pureReader :: HM.HashMap (TopLevelType, T.Text) Statement -- ^ A top-level statement map- -> InterpreterReader Identity-pureReader sttmap = InterpreterReader- baseNativeTypes- getstatementdummy- templatedummy- dummyPuppetDB- mempty- "dummy"- hieradummy- impurePure- mempty- mempty- True- (puppetPaths "/etc/puppet")- where- templatedummy (Right _) _ _ = return (S.Left "Can't interpret files")- templatedummy (Left cnt) stt _ = return $ case extractFromState stt of- Nothing -> S.Left "Context retrieval error (pureReader)"- Just (ctx, scope) -> case parseErbString (T.unpack cnt) of- Left rr -> S.Left (PrettyError (text (show rr)))- Right stmts -> case rubyEvaluate scope ctx stmts of- Right x -> S.Right x- Left rr -> S.Left (PrettyError rr)- hieradummy _ _ _ = return (S.Right Nothing)- getstatementdummy tlt n = return $ case HM.lookup (tlt,n) sttmap of- Just x -> S.Right x- Nothing -> S.Left "Can't get statement"---- | Evaluates an interpreter expression in a pure context.-pureEval :: Facts -- ^ A list of facts that will be used during evaluation- -> HM.HashMap (TopLevelType, T.Text) Statement -- ^ A top-level map- -> InterpreterMonad a -- ^ The action to evaluate- -> (Either PrettyError a, InterpreterState, InterpreterWriter)-pureEval facts sttmap action = runIdentity (interpretMonad (pureReader sttmap) startingState action)- where- startingState = initialState facts $ HM.fromList [ ("confdir", "/etc/puppet")- ]---- | A bunch of facts that can be used for pure evaluation.-dummyFacts :: Facts-dummyFacts = HM.fromList- [ ("architecture", "amd64")- , ("augeasversion", "0.10.0")- , ("bios_release_date", "07/06/2010")- , ("bios_vendor", "Dell Inc.")- , ("bios_version", "2.2.0")- , ("boardmanufacturer", "Dell Inc.")- , ("domain", "dummy.domain")- , ("facterversion", "1.7.5")- , ("filesystems", "ext2,ext3,ext4,vfat")- , ("fqdn", "dummy.dummy.domain")- , ("hardwareisa", "x86_64")- , ("hardwaremodel", "x86_64")- , ("hostname", "dummy")- , ("id", "root")- , ("interfaces", "eth0,lo")- , ("ipaddress", "172.17.42.1")- , ("ipaddress_eth0", "172.17.42.1")- , ("ipaddress_lo", "127.0.0.1")- , ("is_virtual", "false")- , ("kernel", "Linux")- , ("kernelmajversion", "3.8")- , ("kernelrelease", "3.8.0-37-generic")- , ("kernelversion", "3.8.0")- , ("lsbdistcodename", "precise")- , ("lsbdistdescription", "Ubuntu 12.04.4 LTS")- , ("lsbdistid", "Ubuntu")- , ("lsbdistrelease", "12.04")- , ("lsbmajdistrelease", "12")- , ("macaddress", "a5:cb:10:b0:9a:4b")- , ("macaddress_eth0", "72:53:10:c1:eb:70")- , ("manufacturer", "Dell Inc.")- , ("memoryfree", "12.57 GB")- , ("memoryfree_mb", "12869.89")- , ("memorysize", "15.63 GB")- , ("memorysize_mb", "16009.07")- , ("memorytotal", "15.63 GB")- , ("mtu_eth0", "1500")- , ("mtu_lo", "65536")- , ("netmask", "255.255.0.0")- , ("netmask_eth0", "255.255.255.0")- , ("netmask_lo", "255.0.0.0")- , ("network_eth0", "172.17.42.0")- , ("network_lo", "127.0.0.0")- , ("operatingsystem", "Ubuntu")- , ("operatingsystemrelease", "12.04")- , ("osfamily", "Debian")- , ("path", "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin")- , ("physicalprocessorcount", "1")- , ("processor0", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")- , ("processor1", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")- , ("processor2", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")- , ("processor3", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")- , ("processor4", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")- , ("processor5", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")- , ("processor6", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")- , ("processor7", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")- , ("processorcount", "8")- , ("productname", "Vostro 430")- , ("ps", "ps -ef")- , ("puppetversion", "3.4.3")- , ("rubysitedir", "/usr/local/lib/site_ruby/1.8")- , ("rubyversion", "1.8.7")- , ("selinux", "false")- , ("serialnumber", "9L3FW4J")- , ("swapfree", "15.96 GB")- , ("swapfree_mb", "16340.00")- , ("swapsize", "15.96 GB")- , ("swapsize_mb", "16340.00")- , ("timezone", "CEST")- , ("type", "Desktop")- , ("uniqueid", "007f0101")- , ("uptime", "5:48 hours")- , ("uptime_days", "0")- , ("uptime_hours", "5")- , ("uptime_seconds", "20932")- , ("uuid", "97b75940-be55-11e3-b1b6-0800200c9a66")- , ("virtual", "physical")- ]---- | A default evaluation function for arbitrary interpreter actions.-dummyEval :: InterpreterMonad a -> Either PrettyError a-dummyEval action = pureEval dummyFacts mempty action ^. _1
− Puppet/Interpreter/Resolve.hs
@@ -1,763 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE PackageImports #-}--- | This module is all about converting and resolving foreign data into--- the fully exploitable corresponding data type. The main use case is the--- conversion of 'Expression' to 'PValue'.-module Puppet.Interpreter.Resolve- ( -- * Pure resolution functions- getVariable,- pValue2Bool,- -- * Monadic resolution functions- resolveVariable,- resolveExpression,- resolveValue,- resolvePValueString,- resolvePValueNumber,- resolveExpressionString,- resolveExpressionStrings,- resolveFunction',- runHiera,- isNativeType,- -- * Search expression management- resolveSearchExpression,- checkSearchExpression,- searchExpressionToPuppetDB,- -- * Higher order puppet functions handling- hfGenerateAssociations,- hfSetvars,- hfRestorevars,- toNumbers,- fixResourceName,- datatypeMatch,- -- * Synonym- NumberPair- ) where--import Control.Lens-import Control.Monad-import Control.Monad.Operational (singleton)-import "cryptonite" Crypto.Hash-import Data.Aeson hiding ((.=))-import Data.Aeson.Lens hiding (key)-import Data.Bits-import Data.ByteArray (convert)-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Base16 as B16-import Data.CaseInsensitive (mk)-import Data.Char (isAlphaNum)-import qualified Data.Foldable as F-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import Data.List.NonEmpty (NonEmpty(..))-import Data.Maybe (fromMaybe, mapMaybe, catMaybes)-import qualified Data.Maybe.Strict as S-import Data.Scientific-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Tuple.Strict as S-import qualified Data.Vector as V-import Data.Version (Version (..), parseVersion)-import Text.ParserCombinators.ReadP (readP_to_S)-import qualified Text.PrettyPrint.ANSI.Leijen as PP-import Text.Regex.PCRE.ByteString.Utils--import Puppet.Interpreter.PrettyPrinter ()-import Puppet.Interpreter.RubyRandom-import Puppet.Interpreter.Types-import Puppet.Interpreter.Utils-import Puppet.Interpreter.Resolve.Sprintf (sprintf)-import Puppet.Parser.Types-import Puppet.Paths-import Puppet.PP-import Puppet.Utils--sha1 :: ByteString -> ByteString-sha1 = convert . (hash :: ByteString -> Digest SHA1)--md5 :: ByteString -> ByteString-md5 = convert . (hash :: ByteString -> Digest MD5)---- | A useful type that is used when trying to perform arithmetic on Puppet numbers.-type NumberPair = Pair Scientific Scientific---- | Converts class resource names to lowercase (fix for the jenkins plugin).-fixResourceName :: T.Text -- ^ Resource type- -> T.Text -- ^ Resource name- -> T.Text-fixResourceName "class" x = T.toLower $ fromMaybe x $ T.stripPrefix "::" x-fixResourceName _ x = x---- | A hiera helper function, that will throw all Hiera errors and log--- messages to the main monad.-runHiera :: T.Text -> HieraQueryType -> InterpreterMonad (Maybe PValue)-runHiera q t = do- -- We need to merge the current scope with the top level scope- scps <- use scopes- ctx <- getScopeName- let getV scp = mapMaybe toStr $ HM.toList $ fmap (view (_1 . _1)) (scps ^. ix scp . scopeVariables)- -- we can't use _PString, because of dependency cycles- toStr (k,v) = case v of- PString x -> Just (k,x)- _ -> Nothing- toplevels = map (_1 %~ ("::" <>)) $ getV "::"- locals = getV ctx- vars = HM.fromList (toplevels <> locals)- singleton (HieraQuery vars q t)---- | The implementation of all hiera_* functions-hieraCall :: HieraQueryType -> PValue -> Maybe PValue -> Maybe PValue -> InterpreterMonad PValue-hieraCall _ _ _ (Just _) = throwPosError "Overriding the hierarchy is not yet supported"-hieraCall qt q df _ = do- qs <- resolvePValueString q- o <- runHiera qs qt- case o of- Just p -> return p- Nothing -> case df of- Just d -> return d- Nothing -> throwPosError ("Lookup for " <> ttext qs <> " failed")---- | Tries to convert a pair of 'PValue's into a 'NumberPair', as defined in--- attoparsec. If the two values can be converted, it will convert them so--- that they are of the same type-toNumbers :: PValue -> PValue -> S.Maybe NumberPair-toNumbers (PString a) b = case text2Scientific a of- Just na -> toNumbers (PNumber na) b- Nothing -> S.Nothing-toNumbers a (PString b) = toNumbers (PString b) a-toNumbers (PNumber a) (PNumber b) = S.Just (a :!: b)-toNumbers _ _ = S.Nothing---- | This tries to run a numerical binary operation on two puppet--- expressions. It will try to resolve them, then convert them to numbers--- (using 'toNumbers'), and will finally apply the correct operation.-binaryOperation :: Expression -- ^ left operand- -> Expression -- ^ right operand- -> (Scientific -> Scientific -> Scientific) -- ^ operation- -> InterpreterMonad PValue-binaryOperation a b opr = ((PNumber .) . opr) `fmap` resolveExpressionNumber a <*> resolveExpressionNumber b---- 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- rb <- resolveExpressionNumber b- case (preview _Integer ra, preview _Integer rb) of- (Just na, Just nb) -> return (PNumber $ fromIntegral (opr na nb))- _ -> throwPosError ("Expected integer values, not" <+> string (show ra) <+> "or" <+> string (show rb))---- | Resolves a variable, or throws an error if it can't.-resolveVariable :: T.Text -> InterpreterMonad PValue-resolveVariable fullvar = do- scps <- use scopes- scp <- getScopeName- case getVariable scps scp fullvar of- Left rr -> throwPosError rr- Right x -> return x---- | A simple helper that checks if a given type is native or a define.-isNativeType :: T.Text -> InterpreterMonad Bool-isNativeType t = has (ix t) `fmap` singleton GetNativeTypes---- | A pure function for resolving variables.-getVariable :: Container ScopeInformation -- ^ The whole scope data.- -> T.Text -- ^ Current scope name.- -> T.Text -- ^ Full variable name.- -> Either Doc PValue-getVariable scps scp fullvar = do- (varscope, varname) <- case T.splitOn "::" fullvar of- [] -> Left "This doesn't make any sense in resolveVariable"- [vn] -> return (scp, vn) -- Non qualified variables- rst -> return (T.intercalate "::" (filter (not . T.null) (init rst)), last rst) -- qualified variables- let extractVariable (varval :!: _ :!: _) = return varval- case scps ^? ix varscope . scopeVariables . ix varname of- Just pp -> extractVariable pp- Nothing -> -- check top level scope- case scps ^? ix "::" . scopeVariables . ix varname of- Just pp -> extractVariable pp- Nothing -> Left ("Could not resolve variable" <+> pretty (UVariableReference fullvar) <+> "in context" <+> ttext varscope <+> "or root")---- | A helper for numerical comparison functions.-numberCompare :: Expression -> Expression -> (Scientific -> Scientific -> Bool) -> InterpreterMonad PValue-numberCompare a b comp = ((PBoolean .) . comp) `fmap` resolveExpressionNumber a <*> resolveExpressionNumber b---- | Handles the wonders of puppet equality checks.-puppetEquality :: PValue -> PValue -> Bool-puppetEquality ra rb =- case toNumbers ra rb of- (S.Just (na :!: nb)) -> na == nb- _ -> case (ra, rb) of- (PUndef , PBoolean x) -> not x- (PString "true", PBoolean x) -> x- (PString "false", PBoolean x) -> not x- (PBoolean x, PString "true") -> x- (PBoolean x, PString "false") -> not x- (PString sa, PString sb) -> mk sa == mk sb- -- TODO, check if array / hash equality should be recursed- -- for case insensitive matching- _ -> ra == rb---- | The main resolution function : turns an 'Expression' into a 'PValue',--- if possible.-resolveExpression :: Expression -> InterpreterMonad PValue-resolveExpression (Terminal v) = resolveValue v-resolveExpression (Not e) = fmap (PBoolean . not . pValue2Bool) (resolveExpression e)-resolveExpression (And a b) = do- ra <- fmap pValue2Bool (resolveExpression a)- if ra- then do- rb <- fmap pValue2Bool (resolveExpression b)- return (PBoolean (ra && rb))- else return (PBoolean False)-resolveExpression (Or a b) = do- ra <- fmap pValue2Bool (resolveExpression a)- if ra- then return (PBoolean True)- else do- rb <- fmap pValue2Bool (resolveExpression b)- return (PBoolean (ra || rb))-resolveExpression (LessThan a b) = numberCompare a b (<)-resolveExpression (MoreThan a b) = numberCompare a b (>)-resolveExpression (LessEqualThan a b) = numberCompare a b (<=)-resolveExpression (MoreEqualThan a b) = numberCompare a b (>=)-resolveExpression (RegexMatch a 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)- Right Nothing -> return $ PBoolean False- Right (Just matches) -> do- -- A bit of logic to save the capture variables.- -- Note that this will pollute the namespace, as it should only- -- happen in conditional expressions ...- p <- use curPos- ctype <- view cctype <$> getCurContainer- let captures = Prelude.zip (map (T.pack . show) [(0 :: Int)..]) (map mkMatch (F.toList matches))- mkMatch (offset, len) = PString (T.decodeUtf8 (BS.take len (BS.drop offset ra))) :!: p :!: ctype- scp <- getScopeName- scopes . ix scp . scopeVariables %= HM.union (HM.fromList captures)- return $ PBoolean True-resolveExpression (RegexMatch _ t) = throwPosError ("The regexp matching operator expects a regular expression, not" <+> pretty t)-resolveExpression (NotRegexMatch a v) = resolveExpression (Not (RegexMatch a v))-resolveExpression (Equal a b) = do- ra <- resolveExpression a- rb <- resolveExpression b- return $ PBoolean $ puppetEquality ra rb-resolveExpression (Different a b) = resolveExpression (Not (Equal a b))-resolveExpression (Contains idx a) =- resolveExpression a >>= \case- PHash h -> do- ridx <- resolveExpressionString idx- case h ^. at ridx of- Just _ -> return (PBoolean True)- Nothing -> return (PBoolean False)- PArray ar -> do- ridx <- resolveExpression idx- return (PBoolean (ridx `V.elem` ar))- PString st -> do- ridx <- resolveExpressionString idx- return (PBoolean (ridx `T.isInfixOf` st))- src -> throwPosError ("Can't use the 'in' operator with" <+> pretty src)-resolveExpression (Lookup a idx) =- resolveExpression a >>= \case- PHash h -> do- ridx <- resolveExpressionString idx- case h ^. at ridx of- Just v -> return v- Nothing -> do- checkStrict- ("Look up for an hash with the unknown key '" <> ttext ridx <> "' for" <+> pretty (PHash h))- ("Can't find index '" <> ttext ridx <> "' in" <+> pretty (PHash h))- return PUndef- PArray ar -> do- ridx <- resolveExpression idx- i <- case ridx ^? _Integer of- Just n -> return (fromIntegral n)- _ -> throwPosError ("Need an integral number for indexing an array, not" <+> pretty ridx)- let arl = V.length ar- if arl <= i- then throwPosError ("Out of bound indexing, array size is" <+> int arl <+> "index is" <+> int i)- else return (ar V.! i)- src -> throwPosError ("This data can't be indexed:" <+> pretty src)-resolveExpression stmt@(ConditionalValue e conds) = do- rese <- resolveExpression e- let checkCond [] = throwPosError ("The selector didn't match anything for input" <+> pretty rese </> pretty stmt)- checkCond ((SelectorDefault :!: ce) : _) = resolveExpression ce- checkCond ((SelectorValue 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)- Right Nothing -> checkCond xs- Right (Just _) -> resolveExpression ce- checkCond ((SelectorType dt :!: ce) : xs) = if datatypeMatch dt rese- then resolveExpression ce- else checkCond xs- checkCond ((SelectorValue uv :!: ce) : xs) = do- rv <- resolveValue uv- if puppetEquality rese rv- then resolveExpression ce- else checkCond xs- checkCond (V.toList conds)-resolveExpression (Addition a b) = do- ra <- resolveExpression a- rb <- resolveExpression b- case (ra, rb) of- (PHash ha, PHash hb) -> return (PHash (ha <> hb))- (PArray ha, PArray hb) -> return (PArray (ha <> hb))- _ -> binaryOperation a b (+)-resolveExpression (Substraction a b) = binaryOperation a b (-)-resolveExpression (Division a b) = do- ra <- resolveExpressionNumber a- rb <- resolveExpressionNumber b- case rb of- 0 -> throwPosError "Division by 0"- _ -> case (,) `fmap` preview _Integer ra <*> preview _Integer rb of- Just (ia, ib) -> return $ PNumber $ fromIntegral (ia `div` ib)- _ -> return $ PNumber $ ra / rb-resolveExpression (Multiplication a b) = binaryOperation a b (*)-resolveExpression (Modulo a b) = integerOperation a b mod-resolveExpression (RightShift a b) = integerOperation a b (\x -> shiftR x . fromIntegral)-resolveExpression (LeftShift a b) = do- ra <- resolveExpression a- rb <- resolveExpression b- case (ra, rb) of- (PArray ha, v) -> return (PArray (V.snoc ha v))- _ -> integerOperation a b (\x -> shiftL x . fromIntegral)-resolveExpression a@(FunctionApplication e (Terminal (UHOLambdaCall hol))) = do- unless (S.isNothing (hol ^. hoLambdaExpr)) (throwPosError ("You can't combine chains of higher order functions (with .) and giving them parameters, in:" <+> pretty a))- resolveValue (UHOLambdaCall (hol & hoLambdaExpr .~ S.Just e))-resolveExpression (FunctionApplication _ x) = throwPosError ("Expected function application here, not" <+> pretty x)-resolveExpression (Negate x) = PNumber . negate <$> resolveExpressionNumber x---- | Resolves an 'UnresolvedValue' (terminal for the 'Expression' data type) into--- a 'PValue'-resolveValue :: UnresolvedValue -> InterpreterMonad PValue-resolveValue (UNumber n) = return (PNumber 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 resolveExpressionString (V.toList vals))-resolveValue (UResourceReference t e) = do- r <- resolveExpressionStrings e- case r of- [s] -> return (PResourceReference t (fixResourceName t s))- _ -> return (PArray (V.fromList (map (PResourceReference t . fixResourceName t) r)))-resolveValue (UArray a) = fmap PArray (V.mapM resolveExpression a)-resolveValue (UHash a) = fmap (PHash . HM.fromList) (mapM resPair (V.toList a))- where- resPair (k :!: v) = (,) `fmap` resolveExpressionString k <*> resolveExpression v-resolveValue (UVariableReference v) = resolveVariable v-resolveValue (UFunctionCall fname args) = resolveFunction fname args-resolveValue (UHOLambdaCall hol) = evaluateHFCPure hol---- | Turns strings, numbers and booleans into 'T.Text', or throws an error.-resolvePValueString :: PValue -> InterpreterMonad T.Text-resolvePValueString (PString x) = return x-resolvePValueString (PBoolean True) = return "true"-resolvePValueString (PBoolean False) = return "false"-resolvePValueString (PNumber x) = return (scientific2text x)-resolvePValueString PUndef = do- checkStrict- "Resolving the keyword `undef` to the string \"undef\""- "Strict mode won't convert the keyword `undef` to the string \"undef\""- return "undef"-resolvePValueString x = throwPosError ("Don't know how to convert this to a string:" PP.<$> pretty x)---- | Turns everything it can into a number, or throws an error-resolvePValueNumber :: PValue -> InterpreterMonad Scientific-resolvePValueNumber x = case x ^? _Number of- Just n -> return n- Nothing -> throwPosError ("Don't know how to convert this to a number:" PP.<$> pretty x)---- | > resolveExpressionString = resolveExpression >=> resolvePValueString-resolveExpressionString :: Expression -> InterpreterMonad T.Text-resolveExpressionString = resolveExpression >=> resolvePValueString---- | > resolveExpressionNumber = resolveExpression >=> resolvePValueNumber-resolveExpressionNumber :: Expression -> InterpreterMonad Scientific-resolveExpressionNumber = resolveExpression >=> resolvePValueNumber---- | Just like 'resolveExpressionString', but accepts arrays.-resolveExpressionStrings :: Expression -> InterpreterMonad [T.Text]-resolveExpressionStrings x =- resolveExpression x >>= \case- PArray a -> mapM resolvePValueString (V.toList a)- y -> fmap return (resolvePValueString y)---- | Turns a 'PValue' into a 'Bool', as explained in the reference--- documentation.-pValue2Bool :: PValue -> Bool-pValue2Bool PUndef = False-pValue2Bool (PString "") = False-pValue2Bool (PBoolean x) = x-pValue2Bool _ = True---- | This resolve function calls at the expression level.-resolveFunction :: T.Text -> V.Vector Expression -> InterpreterMonad PValue-resolveFunction "fqdn_rand" args = do- let nbargs = V.length args- when (nbargs < 1 || nbargs > 2) (throwPosError "fqdn_rand(): Expects one or two arguments")- fqdn <- resolveVariable "::fqdn" >>= resolvePValueString- (mx:targs) <- mapM resolveExpressionString (V.toList args)- curmax <- case PString mx ^? _Integer of- Just x -> return x- _ -> throwPosError ("fqdn_rand(): the first argument must be an integer, not" <+> ttext mx)- let rargs = if null targs- then [fqdn, ""]- else fqdn : targs- val = fromIntegral (Prelude.fst (limitedRand (randInit myhash) (fromIntegral curmax)))- myhash = toint (md5 (T.encodeUtf8 fullstring)) :: Integer- toint = BS.foldl' (\c nx -> c*256 + fromIntegral nx) 0- fullstring = T.intercalate ":" rargs- return (_Integer # val)-resolveFunction fname args = mapM resolveExpression (V.toList args) >>= resolveFunction' fname . map undefEmptyString- where- undefEmptyString PUndef = PString ""- undefEmptyString x = x--resolveFunction' :: T.Text -> [PValue] -> InterpreterMonad PValue-resolveFunction' "defined" [PResourceReference "class" cn] = do- checkStrict "The use of the 'defined' function is a code smell"- "The 'defined' function is not allowed in strict mode."- fmap (PBoolean . has (ix cn)) (use loadedClasses)-resolveFunction' "defined" [PResourceReference rt rn] = do- checkStrict "The use of the 'defined' function is a code smell"- "The 'defined' function is not allowed in strict mode."- fmap (PBoolean . has (ix (RIdentifier rt rn))) (use definedResources)-resolveFunction' "defined" [ut] = do- checkStrict "The use of the 'defined' function is a code smell."- "The 'defined' function is not allowed in strict mode."- t <- resolvePValueString ut- if not (T.null t) && T.head t == '$' -- variable test- then do- scps <- use scopes- scp <- getScopeName- return $ PBoolean $ case getVariable scps scp (T.tail t) of- Left _ -> False- Right _ -> True- else do -- resource test- -- case 1, nested thingie- nestedStuff <- use nestedDeclarations- if has (ix (TopDefine, t)) nestedStuff || has (ix (TopClass, t)) nestedStuff- then return (PBoolean True)- else do -- case 2, loaded class- lc <- use loadedClasses- if has (ix t) lc- then return (PBoolean True)- else fmap PBoolean (isNativeType t)--resolveFunction' "defined" x = throwPosError ("defined(): expects a single resource reference, type or class name, and not" <+> pretty x)-resolveFunction' "fail" x = throwPosError ("fail:" <+> pretty x)-resolveFunction' "inline_template" [] = throwPosError "inline_template(): Expects at least one argument"-resolveFunction' "inline_template" templates = PString . mconcat <$> mapM (calcTemplate Left) templates-resolveFunction' "md5" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . md5 . T.encodeUtf8) (resolvePValueString pstr)-resolveFunction' "md5" _ = throwPosError "md5(): Expects a single argument"-resolveFunction' "regsubst" [ptarget, pregexp, preplacement] = resolveFunction' "regsubst" [ptarget, pregexp, preplacement, PString "G"]-resolveFunction' "regsubst" [ptarget, pregexp, preplacement, pflags] = do- -- TODO handle all the flags- -- http://docs.puppetlabs.com/references/latest/function.html#regsubst- when (pflags /= "G") (use curPos >>= \p -> warn ("regsubst(): Currently only supports a single flag (G) " <> showPos (S.fst p)))- regexp <- fmap T.encodeUtf8 (resolvePValueString pregexp)- replacement <- fmap T.encodeUtf8 (resolvePValueString preplacement)- let sub t = do- t' <- fmap T.encodeUtf8 (resolvePValueString t)- case substituteCompile' regexp t' replacement of- Left rr -> throwPosError ("regsubst():" <+> string rr)- Right x -> fmap PString (safeDecodeUtf8 x)- case ptarget of- PArray a -> fmap PArray (traverse sub a)- s -> sub s-resolveFunction' "regsubst" _ = throwPosError "regsubst(): Expects 3 or 4 arguments"-resolveFunction' "split" [psrc, psplt] = do- src <- fmap T.encodeUtf8 (resolvePValueString psrc)- splt <- fmap T.encodeUtf8 (resolvePValueString psplt)- case splitCompile' splt src of- Left rr -> throwPosError ("splitCompile():" <+> string rr)- Right x -> fmap (PArray . V.fromList) (mapM (fmap PString . safeDecodeUtf8) x)-resolveFunction' "sha1" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . sha1 . T.encodeUtf8) (resolvePValueString pstr)-resolveFunction' "sha1" _ = throwPosError "sha1(): Expects a single argument"-resolveFunction' "shellquote" args = do- sargs <- forM args $ \arg -> case arg of- PArray vals -> mapM resolvePValueString vals- _ -> V.singleton <$> resolvePValueString arg- let escape str | T.all isSafe str = str- | not (T.any isDangerous str) = between "\"" str- | T.any (== '\'') str = between "\"" (T.concatMap escapeDangerous str)- | otherwise = between "'" str- isSafe x = isAlphaNum x || x `elem` ("@%_+=:,./-" :: String)- isDangerous x = x `elem` ("!\"`$\\" :: String)- escapeDangerous x | isDangerous x = T.snoc "\\" x- | otherwise = T.singleton x- between c s = c <> s <> c- return $ PString $ T.unwords $ V.toList (escape <$> mconcat sargs)--resolveFunction' "mysql_password" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . sha1 . sha1 . T.encodeUtf8) (resolvePValueString pstr)-resolveFunction' "mysql_password" _ = throwPosError "mysql_password(): Expects a single argument"-resolveFunction' "file" args = mapM (resolvePValueString >=> fixFilePath) args >>= fmap PString . singleton . ReadFile- where- fixFilePath s | T.null s = let rr = "Empty file path passed to the 'file' function" in checkStrict rr rr >> return s- | T.head s == '/' = return s- | otherwise = case T.splitOn "/" s of- (md:x:rst) -> do- moduledir <- view modulesPath <$> getPuppetPaths- return (T.intercalate "/" (T.pack moduledir : md : "files" : x : rst))- _ -> throwPosError ("file() argument invalid: " <> ttext s)-resolveFunction' "tagged" ptags = do- tags <- fmap HS.fromList (mapM resolvePValueString ptags)- scp <- getScopeName- scpset <- use (scopes . ix scp . scopeExtraTags)- return (PBoolean (scpset `HS.intersection` tags == tags))-resolveFunction' "template" [] = throwPosError "template(): Expects at least one argument"-resolveFunction' "template" templates = PString . mconcat <$> mapM (calcTemplate Right) templates-resolveFunction' "versioncmp" [pa,pb] = do- a <- resolvePValueString pa- b <- resolvePValueString pb- let parser x = case filter (null . Prelude.snd) (readP_to_S parseVersion (T.unpack x)) of- ( (v, _) : _ ) -> v- _ -> Version [] [] -- fallback :(- va = parser a- vb = parser b- return $ PString $ case compare va vb of- EQ -> "0"- LT -> "-1"- GT -> "1"-resolveFunction' "versioncmp" _ = throwPosError "versioncmp(): Expects two arguments"--- | Simplified implementation of sprintf-resolveFunction' "sprintf" (PString str:args) = sprintf str args-resolveFunction' "sprintf" _ = throwPosError "sprintf(): Expects a string as its first argument"--- some custom functions-resolveFunction' "pdbresourcequery" [q] = pdbresourcequery q Nothing-resolveFunction' "pdbresourcequery" [q,k] = fmap Just (resolvePValueString k) >>= pdbresourcequery q-resolveFunction' "pdbresourcequery" _ = throwPosError "pdbresourcequery(): Expects one or two arguments"-resolveFunction' "hiera" [q] = hieraCall QFirst q Nothing Nothing-resolveFunction' "hiera" [q,d] = hieraCall QFirst q (Just d) Nothing-resolveFunction' "hiera" [q,d,o] = hieraCall QFirst q (Just d) (Just o)-resolveFunction' "hiera_array" [q] = hieraCall QUnique q Nothing Nothing-resolveFunction' "hiera_array" [q,d] = hieraCall QUnique q (Just d) Nothing-resolveFunction' "hiera_array" [q,d,o] = hieraCall QUnique q (Just d) (Just o)-resolveFunction' "hiera_hash" [q] = hieraCall QHash q Nothing Nothing-resolveFunction' "hiera_hash" [q,d] = hieraCall QHash q (Just d) Nothing-resolveFunction' "hiera_hash" [q,d,o] = hieraCall QHash q (Just d) (Just o)-resolveFunction' "hiera" _ = throwPosError "hiera(): Expects one, two or three arguments"---- user functions-resolveFunction' fname args = singleton (ExternalFunction fname args)--pdbresourcequery :: PValue -> Maybe T.Text -> InterpreterMonad PValue-pdbresourcequery q mkey = do- rrv <- case fromJSON (toJSON q) of- Success rq -> singleton (PDBGetResources rq)- Error rr -> throwPosError ("Invalid resource query:" <+> Puppet.PP.string rr)- rv <- case fromJSON (toJSON rrv) of- Success x -> return x- Error rr -> throwPosError ("For some reason we could not convert a resource list to Puppet internal values!!" <+> Puppet.PP.string rr <+> pretty rrv)- let extractSubHash :: T.Text -> PValue -> InterpreterMonad PValue- extractSubHash ky (PHash h) = case h ^. at ky of- Just val -> return val- Nothing -> throwPosError ("pdbresourcequery strange error, could not find key" <+> ttext ky <+> "in" <+> pretty (PHash h))- extractSubHash _ x = throwPosError ("pdbresourcequery strange error, expected a hash, had" <+> pretty x)- case mkey of- Nothing -> return (PArray rv)- (Just k) -> fmap PArray (V.mapM (extractSubHash k) rv)--calcTemplate :: (T.Text -> Either T.Text T.Text) -> PValue -> InterpreterMonad T.Text-calcTemplate templatetype templatename = do- fname <- resolvePValueString templatename- stt <- use id- singleton (ComputeTemplate (templatetype fname) stt)--resolveExpressionSE :: Expression -> InterpreterMonad PValue-resolveExpressionSE e = resolveExpression e >>=- \case- PArray _ -> throwPosError "The use of an array in a search expression is undefined"- PHash _ -> throwPosError "The use of an array in a search expression is undefined"- resolved -> return resolved---- | Turns an unresolved 'SearchExpression' from the parser into a fully--- resolved 'RSearchExpression'.-resolveSearchExpression :: SearchExpression -> InterpreterMonad RSearchExpression-resolveSearchExpression AlwaysTrue = return RAlwaysTrue-resolveSearchExpression (EqualitySearch a e) = REqualitySearch `fmap` pure a <*> resolveExpressionSE e-resolveSearchExpression (NonEqualitySearch a e) = RNonEqualitySearch `fmap` pure a <*> resolveExpressionSE e-resolveSearchExpression (AndSearch e1 e2) = RAndSearch `fmap` resolveSearchExpression e1 <*> resolveSearchExpression e2-resolveSearchExpression (OrSearch e1 e2) = ROrSearch `fmap` resolveSearchExpression e1 <*> resolveSearchExpression e2---- | Turns a resource type and 'RSearchExpression' into something that can--- be used in a PuppetDB query.-searchExpressionToPuppetDB :: T.Text -> RSearchExpression -> Query ResourceField-searchExpressionToPuppetDB rtype res = QAnd ( QEqual RType (capitalizeRT rtype) : mkSE res )- where- mkSE (RAndSearch a b) = [QAnd (mkSE a ++ mkSE b)]- mkSE (ROrSearch a b) = [QOr (mkSE a ++ mkSE b)]- mkSE (RNonEqualitySearch a b) = fmap QNot (mkSE (REqualitySearch a b))- mkSE (REqualitySearch a (PString b)) = [QEqual (mkFld a) b]- mkSE _ = []- mkFld "tag" = RTag- mkFld "title" = RTitle- mkFld z = RParameter z---- | Checks whether a given 'Resource' matches a 'RSearchExpression'. Note--- that the expression doesn't check for type, so you must filter the--- resources by type beforehand, if needs be.-checkSearchExpression :: RSearchExpression -> Resource -> Bool-checkSearchExpression RAlwaysTrue _ = True-checkSearchExpression (RAndSearch a b) r = checkSearchExpression a r && checkSearchExpression b r-checkSearchExpression (ROrSearch a b) r = checkSearchExpression a r || checkSearchExpression b r-checkSearchExpression (REqualitySearch "tag" (PString s)) r = r ^. rtags . contains s-checkSearchExpression (REqualitySearch "tag" _) _ = False-checkSearchExpression (REqualitySearch "title" v) r =- let nameequal = puppetEquality v (PString (r ^. rid . iname))- aliasequal = case r ^. rattributes . at "alias" of- Just a -> puppetEquality v a- Nothing -> False- in nameequal || aliasequal-checkSearchExpression (REqualitySearch attributename v) r =- case r ^. rattributes . at attributename of- Nothing -> False- Just (PArray x) -> F.any (`puppetEquality` v) x- Just x -> puppetEquality x v-checkSearchExpression (RNonEqualitySearch attributename v) r- | attributename == "tag" = True- | attributename == "title" = not (checkSearchExpression (REqualitySearch attributename v) r)- | otherwise = case r ^. rattributes . at attributename of- Nothing -> True- Just (PArray x) -> not (F.all (`puppetEquality` v) x)- Just x -> not (puppetEquality x v)---- | Generates variable associations for evaluation of blocks. Each item--- corresponds to an iteration in the calling block.-hfGenerateAssociations :: HOLambdaCall -> InterpreterMonad [[(T.Text, PValue)]]-hfGenerateAssociations hol = do- sourceexpression <- case hol ^. hoLambdaExpr of- S.Just x -> return x- S.Nothing -> throwPosError ("No expression to run the function on" <+> pretty hol)- sourcevalue <- resolveExpression sourceexpression- let check Nothing = const (return ())- check (Just dtype) = mapM_ (\v -> unless (datatypeMatch dtype v) (throwPosError (pretty v <+> "isn't of type" <+> pretty dtype)))- case (sourcevalue, hol ^. hoLambdaParams) of- (PArray pr, BPSingle (LParam mvtype varname)) -> do- check mvtype pr- return (map (\x -> [(varname, x)]) (V.toList pr))- (PArray pr, BPPair (LParam _ idx) (LParam mvtype var)) -> do- check mvtype pr- return [ [(idx,PString (T.pack (show i))),(var,v)] | (i,v) <- Prelude.zip ([0..] :: [Int]) (V.toList pr) ]- (PHash hh, BPSingle (LParam mvtype varname)) -> do- check mvtype hh- return [ [(varname, PArray (V.fromList [PString k,v]))] | (k,v) <- HM.toList hh]- (PHash hh, BPPair (LParam midxtype idx) (LParam mvtype var)) -> do- check mvtype hh- check midxtype (PString <$> HM.keys hh)- return [ [(idx,PString k),(var,v)] | (k,v) <- HM.toList hh]- (invalid, _) -> throwPosError ("Can't iterate on this data type:" <+> pretty invalid)---- | Sets the proper variables, and returns the scope variables the way--- they were before being modified. This is a hack that ensures that--- variables are local to the new scope.------ It doesn't work at all like other Puppet parts, but consistency isn't--- really expected here ...-hfSetvars :: [(T.Text, PValue)] -> InterpreterMonad (Container (Pair (Pair PValue PPosition) CurContainerDesc))-hfSetvars vals =- do- scp <- getScopeName- p <- use curPos- container <- getCurContainer- save <- use (scopes . ix scp . scopeVariables)- let hfSetvar (varname, varval) = scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: (container ^. cctype))- mapM_ hfSetvar vals- return save---- | Restores what needs restoring. This will erase all allocations.-hfRestorevars :: Container (Pair (Pair PValue PPosition) CurContainerDesc) -> InterpreterMonad ()-hfRestorevars save =- do- scp <- getScopeName- scopes . ix scp . scopeVariables .= save---- | Evaluates a statement in "pure" mode. TODO-evalPureStatement :: Statement -> InterpreterMonad ()-evalPureStatement _ = throwPosError "So called 'pure' statements are not yet supported"---- | This extracts the final expression from an HOLambdaCall.--- When it does not exists, it checks if the last statement is in fact--- a function call-transformPureHf :: HOLambdaCall -> InterpreterMonad (HOLambdaCall, Expression)-transformPureHf hol =- case hol ^. hoLambdaLastExpr of- S.Just x -> return (hol, x)- S.Nothing -> do- let statements = hol ^. hoLambdaStatements- if V.null statements- then throwPosError ("The statement block must not be empty" <+> pretty hol)- else case V.last statements of- (MainFunctionDeclaration (MainFuncDecl fn args _)) ->- let expr = Terminal (UFunctionCall fn args)- in return (hol & hoLambdaStatements %~ V.init- & hoLambdaLastExpr .~ S.Just expr- , expr)- _ -> throwPosError ("The statement block must end with an expression" <+> pretty hol)---- | All the "higher order function" stuff, for "value" mode. In this case--- we are in "pure" mode, and only a few statements are allowed.-evaluateHFCPure :: HOLambdaCall -> InterpreterMonad PValue-evaluateHFCPure hol' = do- (hol, finalexpression) <- transformPureHf hol'- varassocs <- hfGenerateAssociations hol- let runblock :: [(T.Text, PValue)] -> InterpreterMonad PValue- runblock assocs = do- saved <- hfSetvars assocs- V.mapM_ evalPureStatement (hol ^. hoLambdaStatements)- r <- resolveExpression finalexpression- hfRestorevars saved- return r- case hol ^. hoLambdaFunc of- LambEach -> throwPosError "The 'each' function can't be used at the value level in language-puppet. Please use map."- LambMap -> fmap (PArray . V.fromList) (mapM runblock varassocs)- LambFilter -> do- res <- mapM (fmap pValue2Bool . runblock) varassocs- sourcevalue <- case hol ^. hoLambdaExpr of- S.Just x -> resolveExpression x- S.Nothing -> throwPosError "Internal error evaluateHFCPure 1"- case sourcevalue of- PArray ar -> return $ PArray $ V.map Prelude.fst $ V.filter Prelude.snd $ V.zip ar (V.fromList res)- PHash hh -> return $ PHash $ HM.fromList $ map Prelude.fst $ filter Prelude.snd $ Prelude.zip (HM.toList hh) res- x -> throwPosError ("Can't iterate on this data type:" <+> pretty x)- x -> throwPosError ("This type of function is not supported yet by language-puppet!" <+> pretty x)---- | Checks that a value matches a puppet datatype-datatypeMatch :: DataType -> PValue -> Bool-datatypeMatch dt v- = case dt of- DTType -> has _PType v- DTUndef -> v == PUndef- NotUndef -> v /= PUndef- DTString mmin mmax -> boundedBy _PString T.length mmin mmax- DTInteger mmin mmax -> boundedBy (_PNumber . to toBoundedInteger . _Just) id mmin mmax- DTFloat mmin mmax -> boundedBy _PNumber toRealFloat mmin mmax- DTBoolean -> has _PBoolean v- DTArray sdt mi mmx -> container (_PArray . to V.toList) (datatypeMatch sdt) mi mmx- DTHash kt sdt mi mmx -> container (_PHash . to itoList) (\(k,a) -> datatypeMatch kt (PString k) && datatypeMatch sdt a) mi mmx- DTScalar -> datatypeMatch (DTVariant (DTInteger Nothing Nothing :| [DTString Nothing Nothing, DTBoolean])) v- DTData -> datatypeMatch (DTVariant (DTScalar :| [DTArray DTData 0 Nothing, DTHash DTScalar DTData 0 Nothing])) v- DTOptional sdt -> datatypeMatch (DTVariant (DTUndef :| [sdt])) v- DTVariant sdts -> any (`datatypeMatch` v) sdts- DTEnum lst -> maybe False (`elem` lst) (v ^? _PString)- DTAny -> True- DTCollection -> datatypeMatch (DTVariant (DTArray DTData 0 Nothing :| [DTHash DTScalar DTData 0 Nothing])) v- DTPattern patterns -> maybe False (\str -> any (checkPattern (T.encodeUtf8 str)) patterns) (v ^? _PString)- where- checkPattern str (CompRegex _ ptrn)- = case execute' ptrn str of- Right (Just _) -> True- _ -> False- container :: Fold PValue [a] -> (a -> Bool) -> Int -> Maybe Int -> Bool- container f c mi mmx =- let lst = v ^. f- ln = length lst- in ln >= mi && (fmap (ln <=) mmx /= Just False) && all c lst- boundedBy :: Ord b => Fold PValue a -> (a -> b) -> Maybe b -> Maybe b -> Bool- boundedBy prm f mmin mmax- = fromMaybe False $ do- vr <- f <$> v ^? prm- return $ and $ catMaybes [fmap (vr >=) mmin, fmap (vr <=) mmax]
− Puppet/Interpreter/Resolve/Sprintf.hs
@@ -1,145 +0,0 @@-module Puppet.Interpreter.Resolve.Sprintf (- sprintf-) where--import Control.Applicative-import Control.Monad.Except-import Data.Attoparsec.Text-import Data.Scientific (Scientific)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TB-import qualified Data.Text.Lazy.Builder.Int as TB-import qualified Data.Text.Lazy.Builder.Scientific as TB---import Puppet.Interpreter.Types-import Puppet.Interpreter.Utils-import Puppet.Utils-import Puppet.PP (pretty)-import Puppet.Interpreter.PrettyPrinter()--data Flag = Minus | Plus | Space | Zero | Hash- deriving (Show, Eq)--data FLen = Lhh | Lh | Ll | Lll | LL | Lz | Lj | Lt- deriving (Show, Eq)--data FType = TPct | Td | Tu | Tf | TF | Te | TE | Tg | TG | Tx | TX | To | Ts | Tc | Tp | Ta | TA- deriving (Show, Eq)--data PrintfFormat = PrintfFormat { _pfFlags :: [Flag]- , _pfWidth :: Maybe Int- , _pfPrec :: Maybe Int- , _pfLen :: Maybe FLen- , _pfType :: FType- } deriving (Show, Eq)--data FormatStringPart = Raw T.Text- | Format PrintfFormat- deriving (Show, Eq)--parseFormat :: T.Text -> [FormatStringPart]-parseFormat t | T.null t = []- | T.null nxt = [Raw raw]- | otherwise = Raw raw : rformat- where- (raw, nxt) = T.break (== '%') t- tryNext = case parseFormat (T.tail nxt) of- (Raw nt : nxt') -> Raw (T.cons '%' nt) : nxt'- nxt' -> Raw (T.singleton '%') : nxt'- rformat = case parse format nxt of- Fail _ _ _ -> tryNext- Partial _ -> tryNext- Done remaining f -> Format f : parseFormat remaining--flag :: Parser Flag-flag = (Minus <$ char '-')- <|> (Plus <$ char '+')- <|> (Space <$ char ' ')- <|> (Zero <$ char '0')- <|> (Hash <$ char '#')--lenModifier :: Parser FLen-lenModifier = (Lhh <$ string "hh")- <|> (Lh <$ char 'h')- <|> (Lll <$ string "ll")- <|> (Ll <$ char 'l')- <|> (LL <$ char 'L')- <|> (Lz <$ char 'z')- <|> (Lj <$ char 'j')- <|> (Lt <$ char 't')--ftype :: Parser FType-ftype = (TPct <$ char '%')- <|> (Td <$ char 'd')- <|> (Td <$ char 'i')- <|> (Tu <$ char 'u')- <|> (Tf <$ char 'f')- <|> (TF <$ char 'F')- <|> (Te <$ char 'e')- <|> (TE <$ char 'E')- <|> (Tg <$ char 'g')- <|> (TG <$ char 'G')- <|> (Tx <$ char 'x')- <|> (TX <$ char 'X')- <|> (To <$ char 'o')- <|> (Ts <$ char 's')- <|> (Tc <$ char 'c')- <|> (Ta <$ char 'a')- <|> (Tp <$ char 'p')- <|> (TA <$ char 'A')--format :: Parser PrintfFormat-format = do- void $ char '%'- flags <- many flag- width <- optional decimal- prec <- optional $ do- void $ char '.'- decimal- len <- optional lenModifier- ft <- ftype- return (PrintfFormat flags width prec len ft)--sprintf :: T.Text -> [PValue] -> InterpreterMonad PValue-sprintf str oargs = PString . TL.toStrict . TB.toLazyText . mconcat <$> go (parseFormat str) oargs- where- go (Raw x : xs) args = (TB.fromText x :) <$> go xs args- go (Format f : _) _ | Hash `elem` _pfFlags f = throwPosError "sprintf: the # modifier is not supported"- go (Format f : xs) (arg : args) = do- let numeric = case arg of- PNumber n -> pure n- PString s -> maybe (throwError "sprintf: Don't know how to convert this to a number") return (text2Scientific s)- _ -> throwError "sprintf: Don't know how to convert this to a number"- flags = _pfFlags f- sh mkBuilder n | has Minus = TL.justifyLeft padlen ' ' (sprefix <> content)- | has Plus && has Zero = sprefix <> TL.justifyRight mpadlen '0' content- | has Plus = TL.justifyRight padlen ' ' (sprefix <> content)- | has Zero = TL.justifyRight padlen '0' content- | otherwise = TL.justifyRight padlen ' ' content- where- (mpadlen, sprefix) | Plus `elem` flags && n >= 0 = (padlen - 1, "+")- | Space `elem` flags && n >= 0 = (padlen - 1, " ")- | otherwise = (padlen, mempty)- padlen = maybe 0 fromIntegral (_pfWidth f)- has flg = flg `elem` flags- content = TB.toLazyText (mkBuilder n)- baseString <- case _pfType f of- Td -> sh (TB.formatScientificBuilder TB.Fixed (Just 0)) <$> numeric- Tf -> sh (TB.formatScientificBuilder TB.Fixed (_pfPrec f)) <$> numeric- TF -> sh (TB.formatScientificBuilder TB.Fixed (_pfPrec f)) <$> numeric- Tg -> sh (TB.formatScientificBuilder TB.Generic (_pfPrec f)) <$> numeric- TG -> sh (TB.formatScientificBuilder TB.Generic (_pfPrec f)) <$> numeric- Te -> sh (TB.formatScientificBuilder TB.Exponent (_pfPrec f)) <$> numeric- TE -> sh (TB.formatScientificBuilder TB.Exponent (_pfPrec f)) <$> numeric- Tx -> sh (TB.hexadecimal . (truncate :: Scientific -> Integer)) <$> numeric- TX -> sh (TB.hexadecimal . (truncate :: Scientific -> Integer)) <$> numeric- Ts -> return $ case arg of- PString s -> TL.fromStrict s- _ -> TL.pack (show (pretty arg))- _ -> throwPosError "sprintf: not yet supported"- (TB.fromLazyText baseString :) <$> go xs args- go [] [] = return []- go _ [] = throwPosError "sprintf: not enough arguments"- go [] _ = [] <$ let msg = "sprintf: too many arguments" in checkStrict msg msg
− Puppet/Interpreter/RubyRandom.hs
@@ -1,118 +0,0 @@-module Puppet.Interpreter.RubyRandom (rbGenrandInt32, randInit, limitedRand) where--import qualified Data.Vector.Unboxed as V-import qualified Data.Vector.Unboxed.Mutable as VM-import Data.Bits-import Data.List (unfoldr,foldl')--data RandState = RandState { _array :: V.Vector Int- , _left :: Int- , _initf :: Int- , _next :: Int- } deriving (Show)--mixbits :: Int -> Int -> Int-mixbits u v = (u .&. 0x80000000) .|. (v .&. 0x7fffffff)--twist :: Int -> Int -> Int-twist u v = (mixbits u v `shiftR` 1) `xor` ma- where- ma = if (v .&. 1) == 1- then 0x9908b0df- else 0--valN :: Int-valN = 624-valM :: Int-valM = 397--initGenrand :: Integer -> RandState-initGenrand rseed = RandState (V.fromList (scanl genfunc seed [1..(valN - 1)])) 1 1 0- where- seed = fromIntegral rseed .&. 0xffffffff- genfunc :: Int -> Int -> Int- genfunc curval x = (1812433253 * (curval `xor` (curval `shiftR` 30)) + x) .&. 0xffffffff--nextState :: RandState -> RandState-nextState (RandState array _ initf _) = RandState narray valN 1 0- where- rarray = if initf == 0- then _array (initGenrand 5489)- else array- narray = V.modify (\v -> twist1 v >> twist2 v >> final v) rarray- twist1 v = mapM_ (twist' valM v) [0..(valN - valM - 1)]- twist2 v = mapM_ (twist' (valM - valN) v) [(valN - valM) .. (valN - 2)]- final v = do- a <- VM.read v (valN - 1)- b <- VM.read v 0- pm <- VM.read v (valM - 1)- let res = pm `xor` twist a b- VM.write v (valN - 1) res- twist' idx v n = do- a <- VM.read v n- b <- VM.read v (n+1)- pm <- VM.read v (idx + n)- let res = pm `xor` twist a b- VM.write v n res---- needs refactoring, too tedious for me-initGenrandBigint :: Integer -> RandState-initGenrandBigint seed =- let intarray = unfoldr reduce seed- reduce :: Integer -> Maybe (Integer, Integer)- reduce 0 = Nothing- reduce x = Just (x .&. 0xffffffff, x `shiftR` 32)- initstate = _array (initGenrand 19650218)- keylist = concat (repeat intarray)- jlist = concat (repeat [0..(length intarray - 1)])- kmax = max (length intarray) valN- state1 = foldl' apply1 initstate (zip3 keylist jlist [1..kmax])- apply1 :: V.Vector Int -> (Integer, Int, Int) -> V.Vector Int- apply1 ra (initKey, j, ri) =- let (a, i, sti, stim) = rollover ra ri- nsti = ((sti `xor` ((stim `xor` (stim `shiftR` 30)) * 1664525)) + fromIntegral initKey + j) .&. 0xffffffff- in a V.// [(i,nsti)]- state2 = foldl' apply2 state1 [2..valN]- rollover :: V.Vector Int -> Int -> (V.Vector Int, Int, Int, Int)- rollover ra ri =- let (a,i) = if ri >= valN- then (ra V.// [(0, ra V.! (valN-1))],1)- else (ra,ri)- in (a,i,a V.! i, a V.! (i-1))- apply2 :: V.Vector Int -> Int -> V.Vector Int- apply2 ra ri =- let (a, i, sti, stim) = rollover ra ri- nsti = ((sti `xor` ((stim `xor` (stim `shiftR` 30)) * 1566083941)) - i) .&. 0xffffffff- in a V.// [(i,nsti)]- in RandState (state2 V.// [(0,0x80000000)]) 1 1 0---randInit :: Integer -> RandState-randInit x = if x <= 0xffffffff- then initGenrand x- else initGenrandBigint x--rbGenrandInt32 :: RandState -> (Int, RandState)-rbGenrandInt32 st =- let rst = if _left st == 1- then nextState st- else st { _left = _left st - 1 }- next = _next rst- cv = _array rst V.! next- nst = rst { _next = next + 1 }- y1 = cv `xor` (cv `shiftR` 11)- y2 = y1 `xor` ((y1 `shiftL` 7) .&. 0x9d2c5680)- y3 = y2 `xor` ((y2 `shiftL` 15) .&. 0xefc60000)- y4 = y3 `xor` (y3 `shiftR` 18)- in (y4,nst)--limitedRand :: RandState -> Int -> (Int, RandState)-limitedRand s n = limitedRand' s- where- mask = foldl' (\x pow -> x .|. (x `shiftR` pow)) (n - 1) [1,2,4,8,16,32]- limitedRand' s' =- let (rval, ns) = rbGenrandInt32 s'- val = rval .&. mask- in if n <= val- then limitedRand' ns- else (val, ns)
− Puppet/Interpreter/Types.hs
@@ -1,754 +0,0 @@-{-# LANGUAGE AutoDeriveTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}--module Puppet.Interpreter.Types (- -- * Record & lenses- HasResource(..)- , Resource(Resource)- , HasResDefaults(..)- , ResDefaults(ResDefaults)- , HasLinkInformation(..)- , LinkInformation(LinkInformation)- , HasRIdentifier(..)- , RIdentifier(RIdentifier)- , HasScopeInformation(..)- , ScopeInformation(ScopeInformation)- , ScopeEnteringContext(..)- , HasResourceModifier(..)- , ResourceModifier(ResourceModifier)- , HasIoMethods(..)- , IoMethods(IoMethods)- , HasCurContainer(..)- , CurContainer(CurContainer)- , HasNativeTypeMethods(..)- , NativeTypeMethods(NativeTypeMethods)- , NodeInfo(NodeInfo)- , HasNodeInfo(..)- , FactInfo(FactInfo)- , HasFactInfo(..)- , HasWireCatalog(..)- -- ** Operational instructions- , InterpreterInstr(..)- , HasInterpreterReader(..)- , InterpreterReader(InterpreterReader)- , HasInterpreterState(..)- , InterpreterState(InterpreterState)- -- * Sum types- -- ** PValue- , PValue(..)- , _PType- , _PBoolean- , _PString- , _PResourceReference- , _PArray- , _PHash- , _PNumber- , _PUndef- -- ** Misc- , CurContainerDesc(..)- , ResourceCollectorType(..)- , RSearchExpression(..)- , Query(..)- , ModifierType(..)- , NodeField- , Strictness(..)- , HieraQueryType(..)- , WireCatalog(..)- , TopLevelType(..)- , FactField(..)- , ResRefOverride(..)- , ResourceField(..)- , OverrideType(..)- , ClassIncludeType(..)- -- ** PuppetDB- , PuppetEdge(PuppetEdge)- , PuppetDBAPI(..)- -- * newtype & synonym- , PrettyError(..)- , InterpreterMonad- , InterpreterWriter- , FinalCatalog- , NativeTypeValidate- , NodeName- , Container- , HieraQueryFunc- , Scope- , Facts- , EdgeMap- -- * Classes- , MonadThrowPos(..)- -- * Definitions- , metaparameters- , showPos-) where--import Control.Exception-import Control.Lens hiding (Strict)-import Control.Monad.Except-import Control.Monad.Operational-import Control.Monad.State.Strict-import Control.Monad.Writer.Class-import Data.Aeson as A-import Data.Aeson.Lens-import qualified Data.Either.Strict as S-import Data.Hashable-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import qualified Data.Maybe.Strict as S-import Data.Monoid-import Data.Scientific-import Data.String (IsString (..))-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8)-import Data.Time.Clock-import qualified Data.Traversable as TR-import Data.Tuple.Strict-import qualified Data.Vector as V-import Foreign.Ruby.Helpers-import GHC.Generics hiding (to)-import GHC.Stack-import qualified System.Log.Logger as LOG-import Text.Megaparsec.Pos-import Web.HttpApiData (ToHttpApiData(..))--import Puppet.Parser.PrettyPrinter-import Puppet.Parser.Types-import Puppet.Paths-import Puppet.PP hiding (rational)-import Puppet.Utils--metaparameters :: HS.HashSet Text-metaparameters = HS.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"]--type NodeName = Text-type Container = HM.HashMap Text-type Scope = Text-type Facts = Container PValue--newtype PrettyError = PrettyError { getError :: Doc }--instance Show PrettyError where- show = show . getError--instance Monoid PrettyError where- mempty = PrettyError mempty- mappend a b = PrettyError $ getError a <+> getError b--instance IsString PrettyError where- fromString = PrettyError . string--instance Exception PrettyError--instance Pretty PrettyError where- pretty = getError--data PValue = PBoolean !Bool- | PUndef- | PString !Text -- integers and doubles are internally serialized as strings by puppet- | PResourceReference !Text !T.Text- | PArray !(V.Vector PValue)- | PHash !(Container PValue)- | PNumber !Scientific- | PType DataType- deriving (Eq, Show)--instance IsString PValue where- fromString = PString . T.pack--instance AsNumber PValue where- _Number = prism num2PValue toNumber- where- num2PValue :: Scientific -> PValue- num2PValue = PNumber- toNumber :: PValue -> Either PValue Scientific- toNumber (PNumber n) = Right n- toNumber p@(PString x) = case text2Scientific x of- Just o -> Right o- _ -> Left p- toNumber p = Left p---- | The different kind of hiera queries.-data HieraQueryType- = QFirst -- ^ standard hiera query- | QUnique -- ^ hiera_array- | QHash -- ^ hiera_hash- | QDeep- { _knockoutPrefix :: Maybe Text- , _sortMerged :: Bool- , _mergeHashArray :: Bool- } deriving (Show)---- | The type of the Hiera API function.-type HieraQueryFunc m = Container Text -- ^ All the variables that Hiera can interpolate, the top level ones being prefixed with ::- -> Text -- ^ The query- -> HieraQueryType- -> m (S.Either PrettyError (Maybe PValue))---- | The intepreter can run in two modes : a strict mode (recommended), and--- a permissive mode.-data Strictness = Strict | Permissive- deriving (Show, Eq)--instance FromJSON Strictness where- parseJSON (Bool True) = pure Strict- parseJSON (Bool False) = pure Permissive- parseJSON _ = mzero--data RSearchExpression = REqualitySearch !Text !PValue- | RNonEqualitySearch !Text !PValue- | RAndSearch !RSearchExpression !RSearchExpression- | ROrSearch !RSearchExpression !RSearchExpression- | RAlwaysTrue- deriving (Show, Eq)---- | Puppet has two main ways to declare classes: include-like and resource-like--- See <https://docs.puppetlabs.com/puppet/latest/reference/lang_classes.html#include-like-vs-resource-like puppet reference>-data ClassIncludeType = ClassIncludeLike -- ^ using the include or contain function- | ClassResourceLike -- ^ resource like declaration- deriving (Eq)---- | This type is used to differenciate the distinct top level types that are exposed by the DSL.-data TopLevelType- -- |This is for node entries.- = TopNode- -- |This is for defines.- | TopDefine- -- |This is for classes.- | TopClass- deriving (Generic,Eq)--instance Hashable TopLevelType---- | From the evaluation of Resource Default Declaration-data ResDefaults = ResDefaults- { _resDefType :: !Text- , _resDefSrcScope :: !Text- , _resDefValues :: !(Container PValue)- , _resDefPos :: !PPosition- }---- | From the evaluation of Resource Override Declaration-data ResRefOverride = ResRefOverride- { _rrid :: !RIdentifier- , _rrparams :: !(Container PValue)- , _rrpos :: !PPosition- } deriving (Eq)--data CurContainerDesc = ContRoot -- ^ Contained at node or root level- | ContClass !Text -- ^ Contained in a class- | ContDefine !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, Show)--data ScopeEnteringContext = SENormal- | SEChild !Text -- ^ We enter the scope as the child of another class- | SEParent !Text -- ^ We enter the scope as the parent of another class---- TODO related to Scope: explain ...-data CurContainer = CurContainer- { _cctype :: !CurContainerDesc- , _cctags :: !(HS.HashSet Text)- } deriving (Eq)--data ScopeInformation = ScopeInformation- { _scopeVariables :: !(Container (Pair (Pair PValue PPosition) CurContainerDesc))- , _scopeResDefaults :: !(Container ResDefaults)- , _scopeExtraTags :: !(HS.HashSet Text)- , _scopeContainer :: !CurContainer- , _scopeOverrides :: !(HM.HashMap RIdentifier ResRefOverride)- , _scopeParent :: !(S.Maybe 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,Text) Statement)- , _extraRelations :: ![LinkInformation]- , _resMod :: ![ResourceModifier]- }--data InterpreterReader m = InterpreterReader- { _readerNativeTypes :: !(Container NativeTypeMethods)- , _readerGetStatement :: TopLevelType -> Text -> m (S.Either PrettyError Statement)- , _readerGetTemplate :: Either Text T.Text -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError T.Text)- , _readerPdbApi :: PuppetDBAPI m- , _readerExternalFunc :: Container ([PValue] -> InterpreterMonad PValue) -- ^ external func such as stdlib or puppetlabs- , _readerNodename :: Text- , _readerHieraQuery :: HieraQueryFunc m- , _readerIoMethods :: IoMethods m- , _readerIgnoredModules :: HS.HashSet Text- , _readerExternalModules :: HS.HashSet Text- , _readerIsStrict :: Bool- , _readerPuppetPaths :: PuppetDirPaths- }--data IoMethods m = IoMethods- { _ioGetCurrentCallStack :: m [String]- , _ioReadFile :: [Text] -> m (Either String T.Text)- , _ioTraceEvent :: String -> m ()- }--data InterpreterInstr a where- -- Utility for using what's in "InterpreterReader"- GetNativeTypes :: InterpreterInstr (Container NativeTypeMethods)- GetStatement :: TopLevelType -> Text -> InterpreterInstr Statement- ComputeTemplate :: Either Text T.Text -> InterpreterState -> InterpreterInstr T.Text- ExternalFunction :: Text -> [PValue] -> InterpreterInstr PValue- GetNodeName :: InterpreterInstr Text- HieraQuery :: Container Text -> T.Text -> HieraQueryType -> InterpreterInstr (Maybe PValue)- GetCurrentCallStack :: InterpreterInstr [String]- IsIgnoredModule :: Text -> InterpreterInstr Bool- IsExternalModule :: Text -> InterpreterInstr Bool- IsStrict :: InterpreterInstr Bool- PuppetPaths :: InterpreterInstr PuppetDirPaths- -- error- ErrorThrow :: PrettyError -> InterpreterInstr a- ErrorCatch :: InterpreterMonad a -> (PrettyError -> InterpreterMonad a) -> InterpreterInstr a- -- writer- WriterTell :: InterpreterWriter -> InterpreterInstr ()- WriterPass :: InterpreterMonad (a, InterpreterWriter -> InterpreterWriter) -> InterpreterInstr a- WriterListen :: InterpreterMonad a -> InterpreterInstr (a, InterpreterWriter)- -- puppetdb wrappers, see 'PuppetDBAPI' for details- PDBInformation :: InterpreterInstr Doc- PDBReplaceCatalog :: WireCatalog -> InterpreterInstr ()- PDBReplaceFacts :: [(NodeName, Facts)] -> InterpreterInstr ()- PDBDeactivateNode :: NodeName -> InterpreterInstr ()- PDBGetFacts :: Query FactField -> InterpreterInstr [FactInfo]- PDBGetResources :: Query ResourceField -> InterpreterInstr [Resource]- PDBGetNodes :: Query NodeField -> InterpreterInstr [NodeInfo]- PDBCommitDB :: InterpreterInstr ()- PDBGetResourcesOfNode :: NodeName -> Query ResourceField -> InterpreterInstr [Resource]- -- Reading the first file that can be read in a list- ReadFile :: [Text] -> InterpreterInstr T.Text- -- Tracing events- TraceEvent :: String -> InterpreterInstr ()---- | The main monad-type InterpreterMonad = ProgramT InterpreterInstr (State InterpreterState)--instance MonadError PrettyError InterpreterMonad where- throwError = singleton . ErrorThrow- catchError a c = singleton (ErrorCatch a c)---- | Log-type InterpreterWriter = [Pair LOG.Priority Doc]-instance MonadWriter InterpreterWriter InterpreterMonad where- tell = singleton . WriterTell- pass = singleton . WriterPass- listen = singleton . WriterListen--data RIdentifier = RIdentifier- { _itype :: !Text- , _iname :: !Text- } deriving (Show,Eq,Generic,Ord)--instance Hashable RIdentifier--data ResourceModifier = ResourceModifier- { _rmResType :: !Text- , _rmModifierType :: !ModifierType- , _rmType :: !ResourceCollectorType- , _rmSearch :: !RSearchExpression- , _rmMutation :: !(Resource -> InterpreterMonad Resource)- , _rmDeclaration :: !PPosition- }--instance Show ResourceModifier where- show (ResourceModifier rt mt ct se _ p) = unwords ["ResourceModifier", show rt, show mt, show ct, "(" ++ show se ++ ")", "???", show p]--data ModifierType = ModifierCollector -- ^ For collectors, optional resources- | ModifierMustMatch -- ^ For stuff like realize- deriving (Show, Eq)--data OverrideType = CantOverride -- ^ Overriding forbidden, will throw an error- | Replace -- ^ Can silently replace- | CantReplace -- ^ Silently ignore errors- | AppendAttribute -- ^ Can append values- deriving (Show, Eq)--data ResourceCollectorType = RealizeVirtual- | RealizeCollected- | DontRealize- deriving (Show, Eq)--data LinkInformation = LinkInformation- { _linksrc :: !RIdentifier- , _linkdst :: !RIdentifier- , _linkType :: !LinkType- , _linkPos :: !PPosition- } deriving Show--type EdgeMap = HM.HashMap RIdentifier [LinkInformation]--{-| A fully resolved puppet resource that will be used in the 'FinalCatalog'. -}-data Resource = Resource- { _rid :: !RIdentifier -- ^ Resource name.- , _ralias :: !(HS.HashSet Text) -- ^ All the resource aliases- , _rattributes :: !(Container PValue) -- ^ Resource parameters.- , _rrelations :: !(HM.HashMap RIdentifier (HS.HashSet LinkType)) -- ^ Resource relations.- , _rscope :: ![CurContainerDesc] -- ^ Resource scope when it was defined, the real container will be the first item- , _rvirtuality :: !Virtuality- , _rtags :: !(HS.HashSet Text)- , _rpos :: !PPosition -- ^ Source code position of the resource definition.- , _rnode :: !NodeName -- ^ The node were this resource was created, if remote- }- deriving (Eq, Show)--type NativeTypeValidate = Resource -> Either PrettyError Resource---- | Attributes (and providers) of a puppet resource type bundled with validation rules-data NativeTypeMethods = NativeTypeMethods- { _puppetValidate :: NativeTypeValidate- , _puppetFields :: HS.HashSet Text- }--type FinalCatalog = HM.HashMap RIdentifier Resource---- | Used to represent a relationship between two resources within the wired format (json).--- See <http://docs.puppetlabs.com/puppetdb/2.3/api/wire_format/catalog_format_v5.html#data-type-edge>-data PuppetEdge = PuppetEdge RIdentifier RIdentifier LinkType deriving Show---- | Wire format------ See <http://docs.puppetlabs.com/puppetdb/1.5/api/wire_format/catalog_format.html puppet reference>.-data WireCatalog = WireCatalog- { _wireCatalogNodename :: !NodeName- , _wireCatalogVersion :: !Text- , _wireCatalogEdges :: !(V.Vector PuppetEdge)- , _wireCatalogResources :: !(V.Vector Resource)- , _wireCatalogTransactionUUID :: !Text- } deriving Show--data FactInfo = FactInfo- { _factInfoNodename :: !NodeName- , _factInfoName :: !Text- , _factInfoVal :: !PValue- }--data NodeInfo = NodeInfo- { _nodeInfoName :: !NodeName- , _nodeInfoDeactivated :: !Bool- , _nodeInfoCatalogT :: !(S.Maybe UTCTime)- , _nodeInfoFactsT :: !(S.Maybe UTCTime)- , _nodeInfoReportT :: !(S.Maybe UTCTime)- }--data PuppetDBAPI m = PuppetDBAPI- { pdbInformation :: m Doc- , replaceCatalog :: WireCatalog -> ExceptT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>- , replaceFacts :: [(NodeName, Facts)] -> ExceptT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>- , deactivateNode :: NodeName -> ExceptT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>- , getFacts :: Query FactField -> ExceptT PrettyError m [FactInfo] -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>- , getResources :: Query ResourceField -> ExceptT PrettyError m [Resource] -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>- , getNodes :: Query NodeField -> ExceptT PrettyError m [NodeInfo]- , commitDB :: ExceptT PrettyError m () -- ^ This is only here to tell the test PuppetDB to save its content to disk.- , getResourcesOfNode :: NodeName -> Query ResourceField -> ExceptT PrettyError m [Resource]- }---- | Pretty straightforward way to define the various PuppetDB queries-data Query a = QEqual a Text- | QG a Integer- | QL a Integer- | QGE a Integer- | QLE a Integer- | QMatch Text T.Text- | QAnd [Query a]- | QOr [Query a]- | QNot (Query a)- | QEmpty---- | Fields for the fact endpoint-data FactField = FName- | FValue- | FCertname---- | Fields for the node endpoint-data NodeField = NName | NFact Text---- | Fields for the resource endpoint-data ResourceField = RTag- | RCertname- | RParameter Text- | RType- | RTitle- | RExported- | RFile- | RLine--makeClassy ''RIdentifier-makeClassy ''ResRefOverride-makeClassy ''LinkInformation-makeClassy ''ResDefaults-makeClassy ''ResourceModifier-makeClassy ''NativeTypeMethods-makeClassy ''ScopeInformation-makeClassy ''Resource-makeClassy ''InterpreterState-makeClassy ''InterpreterReader-makeClassy ''IoMethods-makeClassy ''CurContainer-makeClassy ''NodeInfo-makeClassy ''WireCatalog-makeClassy ''FactInfo-makePrisms ''PValue--class Monad m => MonadThrowPos m where- throwPosError :: Doc -> m a---- Useful for mocking for instance in a REPL-instance MonadThrowPos (Either Doc) where- throwPosError = Left--class MonadStack m where- getCurrentCallStack :: m [String]--instance MonadStack InterpreterMonad where- getCurrentCallStack = singleton GetCurrentCallStack--instance MonadThrowPos InterpreterMonad where- throwPosError s = do- p <- use (curPos . _1)- stack <- getCurrentCallStack- let dstack = if null stack- then mempty- else mempty </> string (renderStack stack)- throwError (PrettyError (s <+> "at" <+> showPos p <> dstack))--instance ToRuby PValue where- toRuby = toRuby . toJSON-instance FromRuby PValue where- fromRuby = fmap chk . fromRuby- where- chk (Left x) = Left x- chk (Right x) = case fromJSON x of- Error rr -> Left rr-- Success suc -> Right suc---- JSON INSTANCES ----instance FromJSON PValue where- parseJSON Null = return PUndef- parseJSON (Number n) = return $ PNumber n- parseJSON (String s) = return (PString s)- parseJSON (Bool b) = return (PBoolean b)- parseJSON (Array v) = fmap PArray (V.mapM parseJSON v)- parseJSON (Object o) = fmap PHash (TR.mapM parseJSON o)--instance ToJSON PValue where- toJSON (PType t) = toJSON t- toJSON (PBoolean b) = Bool b- toJSON PUndef = Null- toJSON (PString s) = String s- toJSON (PResourceReference _ _) = Null -- TODO- toJSON (PArray r) = Array (V.map toJSON r)- toJSON (PHash x) = Object (HM.map toJSON x)- toJSON (PNumber n) = Number n--instance ToJSON Resource where- toJSON r = object [ ("type", String $ r ^. rid . itype)- , ("title", String $ r ^. rid . iname)- , ("aliases", toJSON $ r ^. ralias)- , ("exported", Bool $ r ^. rvirtuality == Exported)- , ("tags", toJSON $ r ^. rtags)- , ("parameters", Object ( HM.map toJSON (r ^. rattributes) `HM.union` relations ))- , ("sourceline", r ^. rpos . _1 . lSourceLine . to (toJSON . unPos))- , ("sourcefile", r ^. rpos . _1 . lSourceName . to toJSON)- ]- where- relations = r ^. rrelations & HM.fromListWith (V.++) . concatMap changeRelations . HM.toList & HM.map toValue- toValue v | V.length v == 1 = V.head v- | otherwise = Array v- changeRelations :: (RIdentifier, HS.HashSet LinkType) -> [(Text, V.Vector Value)]- changeRelations (k,v) = do- c <- HS.toList v- return (rel2text c, V.singleton (String (rid2text k)))- rid2text :: RIdentifier -> Text- rid2text (RIdentifier t n) = capitalizeRT t `T.append` "[" `T.append` capn `T.append` "]"- where- capn = if t == "classe"- then capitalizeRT n- else n--instance FromJSON Resource where- parseJSON (Object v) = do- isExported <- v .: "exported"- let virtuality = if isExported- then Exported- else Normal- getResourceIdentifier :: PValue -> Maybe RIdentifier- getResourceIdentifier (PString x) =- let (restype, brckts) = T.breakOn "[" x- rna | T.null brckts = Nothing- | T.null restype = Nothing- | T.last brckts == ']' = Just (T.tail (T.init brckts))- | otherwise = Nothing- in case rna of- Just resname -> Just (RIdentifier (T.toLower restype) (T.toLower resname))- _ -> Nothing- getResourceIdentifier _ = Nothing- -- TODO : properly handle metaparameters- separate :: (Container PValue, HM.HashMap RIdentifier (HS.HashSet LinkType)) -> Text -> PValue -> (Container PValue, HM.HashMap RIdentifier (HS.HashSet LinkType))- separate (curAttribs, curRelations) k val = case (fromJSON (String k), getResourceIdentifier val) of- (Success rel, Just ri) -> (curAttribs, curRelations & at ri . non mempty . contains rel .~ True)- _ -> (curAttribs & at k ?~ val, curRelations)- (attribs,relations) <- HM.foldlWithKey' separate (mempty,mempty) <$> v .: "parameters"- contimport <- v .:? "certname" .!= "unknown"- Resource- <$> (RIdentifier <$> fmap T.toLower (v .: "type") <*> v .: "title")- <*> v .:? "aliases" .!= mempty- <*> pure attribs- <*> pure relations- <*> pure [ContImport contimport ContRoot]- <*> pure virtuality- <*> v .: "tags"- <*> (toPPos <$> v .:? "sourcefile" .!= "null" <*> v .:? "sourceline" .!= 1)- <*> pure contimport-- parseJSON _ = mempty--instance ToJSON a => ToJSON (Query a) where- toJSON (QOr qs) = toJSON ("or" : map toJSON qs)- toJSON (QAnd qs) = toJSON ("and" : map toJSON qs)- toJSON (QNot q) = toJSON [ "not" , toJSON q ]- toJSON (QEqual flds val) = toJSON [ "=", toJSON flds, toJSON val ]- toJSON (QMatch flds val) = toJSON [ "~", toJSON flds, toJSON val ]- toJSON (QL flds val) = toJSON [ "<", toJSON flds, toJSON val ]- toJSON (QG flds val) = toJSON [ ">", toJSON flds, toJSON val ]- toJSON (QLE flds val) = toJSON [ "<=", toJSON flds, toJSON val ]- toJSON (QGE flds val) = toJSON [ ">=", toJSON flds, toJSON val ]- toJSON QEmpty = Null--instance ToJSON a => ToHttpApiData (Query a) where- toHeader = Control.Lens.view strict . encode- toUrlPiece = decodeUtf8 . toHeader--instance FromJSON a => FromJSON (Query a) where- parseJSON Null = pure QEmpty- parseJSON (Array elems) = case V.toList elems of- ("or":xs) -> QOr <$> mapM parseJSON xs- ("and":xs) -> QAnd <$> mapM parseJSON xs- ["not",x] -> QNot <$> parseJSON x- [ "=", flds, val ] -> QEqual <$> parseJSON flds <*> parseJSON val- [ "~", flds, val ] -> QEqual <$> parseJSON flds <*> parseJSON val- [ ">", flds, val ] -> QG <$> parseJSON flds <*> parseJSON val- [ "<", flds, val ] -> QL <$> parseJSON flds <*> parseJSON val- [">=", flds, val ] -> QGE <$> parseJSON flds <*> parseJSON val- ["<=", flds, val ] -> QLE <$> parseJSON flds <*> parseJSON val- x -> fail ("unknown query" ++ show x)- parseJSON _ = fail "Expected an array"--instance ToJSON FactField where- toJSON FName = "name"- toJSON FValue = "value"- toJSON FCertname = "certname"--instance FromJSON FactField where- parseJSON "name" = pure FName- parseJSON "value" = pure FValue- parseJSON "certname" = pure FCertname- parseJSON _ = fail "Can't parse fact field"--instance ToJSON NodeField where- toJSON NName = "name"- toJSON (NFact t) = toJSON [ "fact", t ]--instance FromJSON NodeField where- parseJSON (Array xs) = case V.toList xs of- ["fact", x] -> NFact <$> parseJSON x- _ -> fail "Invalid field syntax"- parseJSON (String "name") = pure NName- parseJSON _ = fail "invalid field"--instance ToJSON ResourceField where- toJSON RTag = "tag"- toJSON RCertname = "certname"- toJSON (RParameter t) = toJSON ["parameter", t]- toJSON RType = "type"- toJSON RTitle = "title"- toJSON RExported = "exported"- toJSON RFile = "file"- toJSON RLine = "line"--instance FromJSON ResourceField where- parseJSON (Array xs) = case V.toList xs of- ["parameter", x] -> RParameter <$> parseJSON x- _ -> fail "Invalid field syntax"- parseJSON (String "tag" ) = pure RTag- parseJSON (String "certname") = pure RCertname- parseJSON (String "type" ) = pure RType- parseJSON (String "title" ) = pure RTitle- parseJSON (String "exported") = pure RExported- parseJSON (String "file" ) = pure RFile- parseJSON (String "line" ) = pure RLine- parseJSON _ = fail "invalid field"--instance FromJSON RIdentifier where- parseJSON (Object v) = RIdentifier <$> v .: "type" <*> v .: "title"- parseJSON _ = fail "invalid resource"--instance ToJSON RIdentifier where- toJSON (RIdentifier t n) = object [("type", String t), ("title", String n)]--instance FromJSON PuppetEdge where- parseJSON (Object v) = PuppetEdge <$> v .: "source" <*> v .: "target" <*> v .: "relationship"- parseJSON _ = fail "invalid puppet edge"--instance ToJSON PuppetEdge where- toJSON (PuppetEdge s t r) = object [("source", toJSON s), ("target", toJSON t), ("relationship", toJSON r)]--instance FromJSON WireCatalog where- parseJSON (Object d) = d .: "data" >>= \case- (Object v) -> WireCatalog- <$> v .: "name"- <*> v .: "version"- <*> v .: "edges"- <*> v .: "resources"- <*> v .: "transaction-uuid"- _ -> fail "Data is not an object"- parseJSON _ = fail "invalid wire catalog"--instance ToJSON WireCatalog where- toJSON (WireCatalog n v e r t) = object [("metadata", object [("api_version", Number 1)]), ("data", object d)]- where d = [ ("name", String n)- , ("version", String v)- , ("edges", toJSON e)- , ("resources", toJSON r)- , ("transaction-uuid", String t)- ]--instance ToJSON FactInfo where- toJSON (FactInfo n f v) = object [("certname", String n), ("name", String f), ("value", toJSON v)]--instance FromJSON FactInfo where- parseJSON (Object v) = FactInfo <$> v .: "certname" <*> v .: "name" <*> v .: "value"- parseJSON _ = fail "invalid fact info"--instance ToJSON NodeInfo where- toJSON p = object [ ("name" , toJSON (p ^. nodeInfoName))- , ("deactivated" , toJSON (p ^. nodeInfoDeactivated))- , ("catalog_timestamp", toJSON (p ^. nodeInfoCatalogT))- , ("facts_timestamp" , toJSON (p ^. nodeInfoFactsT))- , ("report_timestamp" , toJSON (p ^. nodeInfoReportT))- ]--instance FromJSON NodeInfo where- parseJSON (Object v) = NodeInfo <$> v .: "name"- <*> v .:? "deactivated" .!= False- <*> v .: "catalog_timestamp"- <*> v .: "facts_timestamp"- <*> v .: "report_timestamp"- parseJSON _ = fail "invalide node info"
− Puppet/Interpreter/Utils.hs
@@ -1,160 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}---- | The module should not depend on the Interpreter module. It is an--- internal module and should not be used if expecting a stable API.-module Puppet.Interpreter.Utils where--import Control.Lens hiding (Strict)-import Control.Monad.Operational-import Control.Monad.Writer.Class-import qualified Data.ByteString as BS-import qualified Data.HashMap.Strict as HM-import Data.Maybe (fromMaybe)-import qualified Data.Maybe.Strict as S-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Tuple.Strict-import qualified System.Log.Logger as LOG--import Puppet.Interpreter.Types-import Puppet.Parser.Types-import Puppet.Parser.Utils-import Puppet.Paths-import Puppet.PP--initialState :: Facts- -> Container Text -- ^ Server settings- -> InterpreterState-initialState facts settings = InterpreterState baseVars initialclass mempty [ContRoot] dummyppos mempty [] []- where- callervars = HM.fromList [("caller_module_name", PString "::" :!: dummyppos :!: ContRoot), ("module_name", PString "::" :!: dummyppos :!: ContRoot)]- factvars =- -- add the `facts` key: https://docs.puppet.com/puppet/4.10/lang_facts_and_builtin_vars.html#accessing-facts-from-puppet-code- let facts' = HM.insert "facts" (PHash facts) facts- in fmap (\x -> x :!: initialPPos "facts" :!: ContRoot) facts'- settingvars = fmap (\x -> PString x :!: initialPPos "settings" :!: ContClass "settings") settings- baseVars = HM.fromList [ ("::", ScopeInformation (factvars `mappend` callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing)- , ("settings", ScopeInformation settingvars mempty mempty (CurContainer (ContClass "settings") mempty) mempty S.Nothing)- ]- initialclass = mempty & at "::" ?~ (ClassIncludeLike :!: dummyppos)---getModulename :: RIdentifier -> Text-getModulename (RIdentifier t n) =- let gm x = case T.splitOn "::" x of- [] -> x- (y:_) -> y- in case t of- "class" -> gm n- _ -> gm t---extractPrism :: Doc -> Prism' a b -> a -> InterpreterMonad b-extractPrism msg p a = case preview p a of- Just b -> return b- Nothing -> throwPosError ("Could not extract prism in" <+> msg)---- Scope-popScope :: InterpreterMonad ()-popScope = curScope %= tail--pushScope :: CurContainerDesc -> InterpreterMonad ()-pushScope s = curScope %= (s :)--getScopeName :: InterpreterMonad Text-getScopeName = scopeName <$> getScope--scopeName :: CurContainerDesc -> Text-scopeName (ContRoot ) = "::"-scopeName (ContImported x ) = "::imported::" `T.append` scopeName x-scopeName (ContClass x ) = x-scopeName (ContDefine dt dn _) = "#define/" `T.append` dt `T.append` "/" `T.append` dn-scopeName (ContImport _ x ) = "::import::" `T.append` scopeName x--moduleName :: CurContainerDesc -> Text-moduleName (ContRoot ) = "::"-moduleName (ContImported x ) = moduleName x-moduleName (ContClass x ) = x-moduleName (ContDefine dt _ _) = dt-moduleName (ContImport _ x ) = moduleName x---getScope :: InterpreterMonad CurContainerDesc-{-# INLINABLE getScope #-}-getScope = use curScope >>= \s -> if null s- then throwPosError "Internal error: empty scope!"- else return (head s)---getCurContainer :: InterpreterMonad CurContainer-{-# INLINABLE getCurContainer #-}-getCurContainer = do- scp <- getScopeName- preuse (scopes . ix scp . scopeContainer) >>= \case- Just x -> return x- Nothing -> throwPosError ("Internal error: can't find the current container for" <+> green (string (T.unpack scp)))--rcurcontainer :: Resource -> CurContainerDesc-rcurcontainer r = fromMaybe ContRoot (r ^? rscope . _head)---- Singleton getters available in the InterpreterMonad ---getPuppetPaths :: InterpreterMonad PuppetDirPaths-getPuppetPaths = singleton PuppetPaths--getNodeName:: InterpreterMonad NodeName-getNodeName = singleton GetNodeName--isIgnoredModule :: Text -> InterpreterMonad Bool-isIgnoredModule m = singleton (IsIgnoredModule m)---- | Throws an error if we are in strict mode--- A warning in permissive mode-checkStrict :: Doc -- ^ The warning message.- -> Doc -- ^ The error message.- -> InterpreterMonad ()-checkStrict wrn err = do- extMod <- isExternalModule- let priority = if extMod then LOG.NOTICE else LOG.WARNING- str <- singleton IsStrict- if str && not extMod- then throwPosError err- else do- srcname <- use (curPos._1.lSourceName)- logWriter priority (wrn <+> "at" <+> string srcname)--isExternalModule :: InterpreterMonad Bool-isExternalModule =- getScope >>= \case- ContClass n -> isExternal n- ContDefine n _ _ -> isExternal n- _ -> return False- where- isExternal = singleton . IsExternalModule . head . T.splitOn "::"----- Logging ---warn :: MonadWriter InterpreterWriter m => Doc -> m ()-warn d = tell [LOG.WARNING :!: d]--debug :: MonadWriter InterpreterWriter m => Doc -> m ()-debug d = tell [LOG.DEBUG :!: d]--logWriter :: MonadWriter InterpreterWriter m => LOG.Priority -> Doc -> m ()-logWriter prio d = tell [prio :!: d]---- General ---isEmpty :: (Eq x, Monoid x) => x -> Bool-isEmpty = (== mempty)--safeDecodeUtf8 :: BS.ByteString -> InterpreterMonad Text-{-# INLINABLE safeDecodeUtf8 #-}-safeDecodeUtf8 i = return (T.decodeUtf8 i)--dropInitialColons :: Text -> T.Text-dropInitialColons t = fromMaybe t (T.stripPrefix "::" t)--normalizeRIdentifier :: Text -> T.Text -> RIdentifier-normalizeRIdentifier = RIdentifier . dropInitialColons
− Puppet/Lens.hs
@@ -1,180 +0,0 @@-{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}-module Puppet.Lens- ( -- * Pure resolution prisms- _PResolveExpression- , _PResolveValue- -- * Prisms for PValues (reexport from "Puppet.Interpreter.Types")- , _PHash- , _PBoolean- , _PString- , _PNumber- , _PResourceReference- , _PUndef- , _PArray- -- * Lenses and prims for 'Statement's- , _Statements- , _ResDecl- , _ResDefaultDecl- , _ResOverrDecl- , _ResCollDecl- , _ConditionalDecl- , _ClassDecl- , _DefineDecl- , _NodeDecl- , _VarAssignDecl- , _MainFuncDecl- , _HigherOrderLambdaDecl- , _DepDecl- -- * Prim for 'Expression's- , _Equal- , _Different- , _Not- , _And- , _Or- , _LessThan- , _MoreThan- , _LessEqualThan- , _MoreEqualThan- , _RegexMatch- , _NotRegexMatch- , _Contains- , _Addition- , _Substraction- , _Division- , _Multiplication- , _Modulo- , _RightShift- , _LeftShift- , _Lookup- , _Negate- , _ConditionalValue- , _FunctionApplication- , _Terminal- -- * Prisms for exceptions- , _PrettyError- ) where--import Control.Lens--import Puppet.Parser (puppetParser)-import Puppet.Parser.Types-import Puppet.Interpreter.Types-import Puppet.Interpreter.Pure-import Puppet.Interpreter.Resolve-import qualified Puppet.Parser.PrettyPrinter()--import qualified Data.Vector as V-import qualified Data.HashMap.Strict as HM-import Data.Tuple.Strict hiding (uncurry)-import Control.Exception (SomeException, toException, fromException)-import qualified Data.Text as T-import Text.PrettyPrint.ANSI.Leijen (pretty)--import Text.Megaparsec (parse)--makePrisms ''Expression--_PuppetParser :: Prism' T.Text (V.Vector Statement)-_PuppetParser = prism' (T.pack . unlines . V.toList . fmap (show . pretty)) $ \t -> case parse puppetParser "dummy" t of- Left _ -> Nothing- Right r -> Just r--_PrettyError :: Prism' SomeException PrettyError-_PrettyError = prism' toException fromException--_ResDecl :: Prism' Statement ResDecl-_ResDecl = prism ResourceDeclaration $ \x -> case x of- ResourceDeclaration a -> Right a- _ -> Left x-_ResDefaultDecl :: Prism' Statement ResDefaultDecl-_ResDefaultDecl = prism ResourceDefaultDeclaration $ \x -> case x of- ResourceDefaultDeclaration a -> Right a- _ -> Left x-_ResOverrDecl :: Prism' Statement ResOverrideDecl-_ResOverrDecl = prism ResourceOverrideDeclaration $ \x -> case x of- ResourceOverrideDeclaration a -> Right a- _ -> Left x-_ResCollDecl :: Prism' Statement ResCollDecl-_ResCollDecl = prism ResourceCollectionDeclaration $ \x -> case x of- ResourceCollectionDeclaration a -> Right a- _ -> Left x-_ConditionalDecl :: Prism' Statement ConditionalDecl-_ConditionalDecl = prism ConditionalDeclaration $ \x -> case x of- ConditionalDeclaration a -> Right a- _ -> Left x-_ClassDecl :: Prism' Statement ClassDecl-_ClassDecl = prism ClassDeclaration $ \x -> case x of- ClassDeclaration a -> Right a- _ -> Left x-_DefineDecl :: Prism' Statement DefineDecl-_DefineDecl = prism DefineDeclaration $ \x -> case x of- DefineDeclaration a -> Right a- _ -> Left x-_NodeDecl :: Prism' Statement NodeDecl-_NodeDecl = prism NodeDeclaration $ \x -> case x of- NodeDeclaration a -> Right a- _ -> Left x--_VarAssignDecl :: Prism' Statement VarAssignDecl-_VarAssignDecl = prism VarAssignmentDeclaration $ \x -> case x of- VarAssignmentDeclaration a -> Right a- _ -> Left x-_MainFuncDecl :: Prism' Statement MainFuncDecl-_MainFuncDecl = prism MainFunctionDeclaration $ \x -> case x of- MainFunctionDeclaration a -> Right a- _ -> Left x-_HigherOrderLambdaDecl :: Prism' Statement HigherOrderLambdaDecl-_HigherOrderLambdaDecl = prism HigherOrderLambdaDeclaration $ \x -> case x of- HigherOrderLambdaDeclaration a -> Right a- _ -> Left x-_DepDecl :: Prism' Statement DepDecl-_DepDecl = prism DependencyDeclaration $ \x -> case x of- DependencyDeclaration 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---- | Incomplete-_PResolveExpression :: Prism' Expression PValue-_PResolveExpression = prism reinject extract- where- extract e = case dummyEval (resolveExpression e) of- Right x -> Right x- Left _ -> Left e- reinject = Terminal . review _PResolveValue--_PResolveValue :: Prism' UnresolvedValue PValue-_PResolveValue = prism toU toP- where- toP uv = case dummyEval (resolveValue uv) of- Right x -> Right x- Left _ -> Left uv- toU (PBoolean x) = UBoolean x- toU (PNumber x) = UNumber x- toU PUndef = UUndef- toU (PString s) = UString s- 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)- toU (PType _) = error "TODO, _PResolveValue PType undefined"--_Statements :: Lens' Statement [Statement]-_Statements = lens (V.toList . sget) (\s v -> sset s (V.fromList v))- where- sget :: Statement -> V.Vector Statement- sget (ClassDeclaration (ClassDecl _ _ _ s _)) = s- sget (DefineDeclaration (DefineDecl _ _ s _)) = s- sget (NodeDeclaration (NodeDecl _ s _ _)) = s- sget (TopContainer s _) = s- sget (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall _ _ _ s _) _)) = s- sget _ = V.empty- sset :: Statement -> V.Vector Statement -> Statement- sset (ClassDeclaration (ClassDecl n args inh _ p)) s = ClassDeclaration (ClassDecl n args inh s p)- sset (NodeDeclaration (NodeDecl ns _ nd' p)) s = NodeDeclaration (NodeDecl ns s nd' p)- sset (DefineDeclaration (DefineDecl n args _ p)) s = DefineDeclaration (DefineDecl n args s p)- sset (TopContainer _ p) s = TopContainer s p- sset (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall t e pr _ e2) p)) s = HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall t e pr s e2) p)- sset x _ = x
− Puppet/Manifests.hs
@@ -1,63 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-module Puppet.Manifests (filterStatements) where--import Control.Applicative-import Control.Lens-import Control.Monad.Except-import qualified Data.Either.Strict as S-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Tuple.Strict-import qualified Data.Vector as V-import Text.Regex.PCRE.ByteString.Utils--import Puppet.Interpreter.Types-import Puppet.Parser.Types-import Puppet.PP---- TODO pre-triage stuff-filterStatements :: TopLevelType -> T.Text -> V.Vector Statement -> IO (S.Either PrettyError Statement)--- the most complicated case, node matching-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@(NodeDeclaration (NodeDecl (NodeName !nm) _ _ _)) = curstuff & _2 . at nm ?~ n- triage curstuff n@(NodeDeclaration (NodeDecl (NodeMatch (CompRegex _ !rg)) _ _ _)) = curstuff & _3 %~ (|> (rg :!: n))- triage curstuff n@(NodeDeclaration (NodeDecl NodeDefault _ _ _)) = curstuff & _4 ?~ n- triage curstuff x = curstuff & _1 %~ (|> x)- bsnodename = T.encodeUtf8 ndename- checkRegexp :: [Pair Regex Statement] -> ExceptT PrettyError IO (Maybe Statement)- checkRegexp [] = return Nothing- checkRegexp ((regexp :!: s):xs) =- case execute' regexp bsnodename of- Left rr -> throwError (PrettyError ("Regexp match error:" <+> text (show rr)))- Right Nothing -> checkRegexp xs- Right (Just _) -> return (Just s)- strictEither (Left x) = S.Left x- strictEither (Right x) = S.Right x- in case directnodes ^. at ndename of -- check if there is a node specifically called after my name- Just r -> return (S.Right (TopContainer spurious r))- Nothing -> fmap strictEither $ runExceptT $ do- regexpMatchM <- checkRegexp (V.toList regexpmatches) -- match regexps- case regexpMatchM <|> defaultnode of -- check for regexp matches or use the default node- Just r -> return (TopContainer spurious r)- Nothing -> throwError (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 (ClassDecl cname _ _ _ _)) = curstuff & _3 . at cname ?~ n- triage curstuff n@(DefineDeclaration (DefineDecl cname _ _ _)) = curstuff & _2 . at cname ?~ n- triage curstuff n = curstuff & _1 %~ (|> n)- tc n = if V.null spurious- then n- else TopContainer spurious n- in case x of- TopNode -> return (S.Left "Case already covered, shoudln't happen in Puppet.Manifests")- TopDefine -> case defines ^. at ndename of- Just n -> return (S.Right (tc n))- Nothing -> return (S.Left (PrettyError ("Couldn't find define " <+> ttext ndename)))- TopClass -> case classes ^. at ndename of- Just n -> return (S.Right (tc n))- Nothing -> return (S.Left (PrettyError ("Couldn't find class " <+> ttext ndename)))
− Puppet/NativeTypes.hs
@@ -1,58 +0,0 @@-{-| This module holds the /native/ Puppet resource types. -}-module Puppet.NativeTypes (- baseNativeTypes- , validateNativeType-) where--import Control.Lens-import Control.Monad.Operational-import qualified Data.HashMap.Strict as HM--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.Notify-import Puppet.NativeTypes.Package-import Puppet.NativeTypes.SshSecure-import Puppet.NativeTypes.User-import Puppet.NativeTypes.ZoneRecord--fakeTypes :: [(NativeTypeName, NativeTypeMethods)]-fakeTypes = map faketype ["class"]--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","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 NativeTypeMethods-baseNativeTypes = HM.fromList- ( nativeConcat- : nativeConcatFragment- : nativeCron- : nativeExec- : nativeFile- : nativeGroup- : nativeHost- : nativeMount- : nativeNotify- : nativePackage- : nativeSshSecure- : nativeUser- : nativeZoneRecord- : fakeTypes ++ defaultTypes)---- | Contrary to the previous iteration, this will let non native types pass.-validateNativeType :: Resource -> InterpreterMonad Resource-validateNativeType r = do- tps <- singleton GetNativeTypes- case tps ^. at (r ^. rid . itype) of- Just x -> case (x ^. puppetValidate) r of- Right nr -> return nr- Left err -> throwPosError ("Invalid resource" <+> pretty r </> getError err)- Nothing -> return r
− Puppet/NativeTypes/Concat.hs
@@ -1,48 +0,0 @@-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
@@ -1,66 +0,0 @@-module Puppet.NativeTypes.Cron- (nativeCron)-where--import Control.Lens-import Data.Scientific-import qualified Data.Text as T-import qualified Data.Vector as V-import Puppet.Interpreter.Types-import Puppet.NativeTypes.Helpers-import Puppet.Utils-import qualified Text.PrettyPrint.ANSI.Leijen as P--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.-parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])]-parameterfunctions =- [("ensure" , [defaultvalue "present", string, values ["present","absent"]])- ,("command" , [string, mandatoryIfNotAbsent])- ,("environment" , [])- ,("hour" , [vrange 0 23 [] ])- ,("minute" , [vrange 0 59 [] ])- ,("month" , [vrange 1 12 ["January","February","March","April","May","June","July","August","September","October","November","December"] ])- ,("monthday" , [vrange 1 31 [] ])- ,("name" , [nameval])- ,("provider" , [defaultvalue "crontab", string, values ["crontab"]])- ,("special" , [string])- ,("target" , [string])- ,("user" , [defaultvalue "root", string])- ,("weekday" , [vrange 0 7 ["Monday","Tuesday","Wednesday","Thursday","Friday","Saturday","Sunday"]])- ]---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- Nothing -> defaultvalue "*" param res--vrange' :: Integer -> Integer -> [T.Text] -> T.Text -> Resource -> PValue -> Either PrettyError Resource-vrange' mi ma valuelist param res y = case y of- PString "*" -> Right res- PString "absent" -> Right res- PNumber n -> checkint' n mi ma param res- PString x -> if x `elem` valuelist- then Right res- 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 -> 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 -> 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 -> NativeTypeValidate-checkint' i mi ma param res =- if (i >= fromIntegral mi) && (i <= fromIntegral ma)- then Right res- else perror $ "Parameter" <+> paramname param <+> "value is out of bound, should satisfy" <+> P.integer mi <+> "<=" <+> P.string (show i) <+> "<=" <+> P.integer ma
− Puppet/NativeTypes/Exec.hs
@@ -1,38 +0,0 @@-module Puppet.NativeTypes.Exec (nativeExec) where--import Puppet.NativeTypes.Helpers-import Puppet.Interpreter.Types-import qualified Data.Text as T-import Control.Lens--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.-parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])]-parameterfunctions =- [("command" , [nameval])- ,("creates" , [rarray, strings, fullyQualifieds])- ,("cwd" , [string, fullyQualified])- ,("environment" , [rarray, strings])- ,("group" , [string])- ,("logoutput" , [defaultvalue "false", string, values ["true","false","on_failure"]])- ,("onlyif" , [string])- ,("path" , [rarray, strings, fullyQualifieds])- ,("provider" , [string, values ["posix","shell","windows"]])- ,("refresh" , [string])- ,("refreshonly" , [defaultvalue "false", string, values ["true","false"]])- ,("returns" , [defaultvalue "0", rarray, integers])- ,("timeout" , [defaultvalue "300", integer])- ,("tries" , [defaultvalue "1", integer])- ,("try_sleep" , [defaultvalue "0", integer])- ,("unless" , [string])- ,("user" , [string])- ]--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- else Left "Command must be fully qualified if path is not defined"- _ -> Right res
− Puppet/NativeTypes/File.hs
@@ -1,108 +0,0 @@-module Puppet.NativeTypes.File (nativeFile) where--import Puppet.Interpreter.Types-import Puppet.NativeTypes.Helpers--import Control.Applicative-import Control.Lens-import Control.Monad.Except-import Control.Monad.Trans.Except-import qualified Data.Attoparsec.Text as AT-import Data.Char (isDigit)-import qualified Data.Map.Strict as M-import Data.Monoid-import qualified Data.Set as S-import qualified Data.Text as T--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.--parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])]-parameterfunctions =- [("backup" , [string])- ,("checksum" , [values ["md5", "md5lite", "mtime", "ctime", "none"]])- ,("content" , [string])- --,("ensure" , [defaultvalue "present", string, values ["directory","file","present","absent","link"]])- ,("ensure" , [defaultvalue "present", string])- ,("force" , [string, values ["true","false"]])- ,("group" , [defaultvalue "root", string])- ,("ignore" , [strings])- ,("links" , [string])- ,("mode" , [defaultvalue "0644", string])- ,("owner" , [string])- ,("path" , [nameval, fullyQualified, noTrailingSlash])- ,("provider" , [values ["posix","windows"]])- ,("purge" , [string, values ["true","false"]])- ,("recurse" , [string, values ["inf","true","false","remote"]])- ,("recurselimit" , [integer])- ,("replace" , [string, values ["true","false"]])- ,("sourceselect" , [values ["first","all"]])- ,("seltype" , [string])- ,("selrange" , [string])- ,("selinux_ignore_defaults", [string, values ["true","false"]])- ,("selrole" , [string])- ,("target" , [string])- ,("source" , [rarray, strings, flip runarray checkSource])- ,("seluser" , [string])- ,("validate_cmd" , [string])- ,("validate_replacement" , [string])- ]--validateMode :: NativeTypeValidate-validateMode res = do- modestr <- case res ^. rattributes . at "mode" of- Just (PString s) -> return s- Just x -> throwError $ PrettyError ("Invalide mode type, should be a string " <+> pretty x)- Nothing -> throwError "Could not find mode!"- (numeric modestr <|> except (ugo modestr)) & runExcept & _Right %~ ($ res)--numeric :: T.Text -> Except PrettyError (Resource -> Resource)-numeric modestr = do- when ((T.length modestr /= 3) && (T.length modestr /= 4)) (throwError "Invalid mode size")- unless (T.all isDigit modestr) (throwError "The mode should only be made of digits")- return $ if T.length modestr == 3- then rattributes . at "mode" ?~ PString (T.cons '0' modestr)- else id--checkSource :: T.Text -> PValue -> NativeTypeValidate-checkSource _ (PString x) res | any (`T.isPrefixOf` x) ["puppet://", "file://", "/"] = Right res- | otherwise = throwError "A source should start with either puppet:// or file:// or an absolute path"-checkSource _ x _ = throwError $ PrettyError ("Expected a string, not" <+> pretty x)--data PermParts = Special | User | Group | Other- deriving (Eq, Ord)--data PermSet = R | W | X- deriving (Ord, Eq)--ugo :: T.Text -> Either PrettyError (Resource -> Resource)-ugo t = AT.parseOnly (modestring <* AT.endOfInput) t- & _Left %~ (\rr -> PrettyError $ "Could not parse the mode string: " <> text rr)- & _Right %~ (\s -> rattributes . at "mode" ?~ PString (mkmode Special s <> mkmode User s <> mkmode Group s <> mkmode Other s))--mkmode :: PermParts -> M.Map PermParts (S.Set PermSet) -> T.Text-mkmode p m = let s = m ^. at p . non mempty- in T.pack $ show $ fromEnum (S.member R s) * 4- + fromEnum (S.member W s) * 2- + fromEnum (S.member X s)--modestring :: AT.Parser (M.Map PermParts (S.Set PermSet))-modestring = M.fromList . mconcat <$> (modepart `AT.sepBy` AT.char ',')---- TODO suid, sticky and other funky things are not yet supported-modepart :: AT.Parser [(PermParts, S.Set PermSet)]-modepart = do- let permpart = (AT.char 'u' *> pure [User])- <|> (AT.char 'g' *> pure [Group])- <|> (AT.char 'o' *> pure [Other])- <|> (AT.char 'a' *> pure [User,Group,Other])- permission = (AT.char 'r' *> pure R)- <|> (AT.char 'w' *> pure W)- <|> (AT.char 'x' *> pure X)- pp <- mconcat <$> some permpart- void $ AT.char '='- pr <- S.fromList <$> some permission- return (map (\p -> (p, pr)) pp)
− Puppet/NativeTypes/Group.hs
@@ -1,24 +0,0 @@-module Puppet.NativeTypes.Group (nativeGroup) where--import Puppet.NativeTypes.Helpers-import Puppet.Interpreter.Types-import qualified Data.Text as T--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.-parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])]-parameterfunctions =- [("allowdupe" , [string, defaultvalue "false", values ["true","false"]])- ,("attribute_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]])- ,("attributes" , [strings])- ,("auth_membership" , [defaultvalue "minimum", string, values ["inclusive","minimum"]])- ,("ensure" , [defaultvalue "present", string, values ["present","absent"]])- ,("gid" , [integer])- ,("ia_load_module" , [string])- ,("members" , [strings])- ,("name" , [nameval])- ,("provider" , [string, values ["aix","directoryservice","groupadd","ldap","pw","window_adsi"]])- ,("system" , [string, defaultvalue "false", values ["true","false"]])- ]
− Puppet/NativeTypes/Helpers.hs
@@ -1,266 +0,0 @@-{-| These are the function and data types that are used to define the Puppet-native types.--}-module Puppet.NativeTypes.Helpers- ( module Puppet.PP- , ipaddr- , nativetypemethods- , paramname- , rarray- , string- , strings- , string_s- , noTrailingSlash- , fullyQualified- , fullyQualifieds- , values- , defaultvalue- , concattype- , nameval- , defaultValidate- , NativeTypeName- , parameterFunctions- , integer- , integers- , mandatory- , mandatoryIfNotAbsent- , inrange- , faketype- , defaulttype- , runarray- , perror- , validateSourceOrContent- ) where--import Control.Lens-import Control.Monad-import Data.Aeson.Lens (_Integer, _Number)-import Data.Char (isDigit)-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import Data.Maybe (fromMaybe)-import qualified Data.Text as T-import qualified Data.Vector as V-import Puppet.Interpreter.PrettyPrinter ()-import Puppet.Interpreter.Types-import Puppet.PP hiding (integer, string)-import Puppet.Utils-import qualified Text.PrettyPrint.ANSI.Leijen as P--type NativeTypeName = T.Text--paramname :: T.Text -> Doc-paramname = red . ttext---- | Useful helper for buiding error messages-perror :: Doc -> Either PrettyError Resource-perror = Left . PrettyError---- | Smart constructor for 'NativeTypeMethods'.-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--faketype :: NativeTypeName -> (NativeTypeName, NativeTypeMethods)-faketype tname = (tname, NativeTypeMethods Right HS.empty)--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--checkParameterList :: HS.HashSet T.Text -> NativeTypeValidate-checkParameterList validparameters res | HS.null validparameters = Right res- | otherwise = if HS.null setdiff- then Right res- else perror $ "Unknown parameters: " <+> list (map paramname $ HS.toList setdiff)- where- keyset = HS.fromList $ HM.keys (res ^. rattributes)- setdiff = HS.difference keyset (metaparameters `HS.union` validparameters)---- | This validator always accept the resources, but add the default parameters (to be defined :)-addDefaults :: NativeTypeValidate-addDefaults res = Right (res & rattributes %~ newparams)- where- def PUndef = False- def _ = True- newparams p = HM.filter def $ HM.union p defaults- defaults = HM.empty---- | Helper function that runs a validor on a 'PArray'-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- Nothing -> Right res--{-| This checks that a given parameter is a string. If it is a 'ResolvedInt' or-'ResolvedBool' it will convert them to strings.--}-string :: T.Text -> NativeTypeValidate-string param res = case res ^. rattributes . at param of- Just x -> string' param x res- Nothing -> Right res--strings :: T.Text -> NativeTypeValidate-strings param = runarray param string'---- | Validates a string or an array of strings-string_s :: T.Text -> NativeTypeValidate-string_s param res = case res ^. rattributes . at param of- Nothing -> Right res- Just (PArray _) -> strings param res- Just _ -> string param res--string' :: T.Text -> PValue -> NativeTypeValidate-string' param rev res = case rev of- PString _ -> Right res- PBoolean True -> Right (res & rattributes . at param ?~ PString "true")- PBoolean False -> Right (res & rattributes . at param ?~ PString "false")- 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 -> NativeTypeValidate-values valuelist param res = case res ^. rattributes . at param of- Just (PString x) -> if x `elem` valuelist- then Right res- else perror $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ttext valuelist) <+> "and not" <+> ttext x- Just x -> perror $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ttext valuelist) <+> "and not" <+> pretty x- Nothing -> Right res---- | This fills the default values of unset parameters.-defaultvalue :: T.Text -> T.Text -> 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 -> 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 -> NativeTypeValidate-integers param = runarray param integer''--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 -> NativeTypeValidate-nameval prm res = string prm res- >>= \r -> case r ^. rattributes . at prm of- Just (PString al) -> Right (res & rid . iname .~ al)- Just x -> perror ("The alias must be a string, not" <+> pretty x)- Nothing -> Right (r & rattributes . at prm ?~ PString (r ^. rid . iname))---- | Checks that a given parameter is set unless the resources "ensure" is set to absent-mandatoryIfNotAbsent :: T.Text -> NativeTypeValidate-mandatoryIfNotAbsent param res = case res ^. rattributes . at param of- Just _ -> Right res- Nothing -> case res ^. rattributes . at "ensure" of- Just "absent" -> Right res- _ -> perror $ "Parameter" <+> paramname param <+> "should be set."---- | Checks that a given parameter is set.-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 -> NativeTypeValidate])] -> NativeTypeValidate-parameterFunctions argrules rs = foldM parameterFunctions' rs argrules- where- 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 -> NativeTypeValidate) -> Either PrettyError Resource- parameterFunctions'' param r validationfunction = validationfunction param r---- checks that a parameter is fully qualified-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 -> 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 -> NativeTypeValidate-fullyQualifieds param = runarray param fullyQualified'--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 == '/'- then Right res- 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 -> 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 -> NativeTypeValidate-ipaddr param res = case res ^. rattributes . at param of- Nothing -> Right res- Just (PString ip) ->- if checkipv4 ip 0- then Right res- else perror $ "Invalid IP address for parameter" <+> paramname param- Just x -> perror $ "Parameter" <+> paramname param <+> "should be an IP address string, not" <+> pretty x--checkipv4 :: T.Text -> Int -> Bool-checkipv4 _ 4 = False -- means that there are more than 4 groups-checkipv4 "" _ = False -- should never get an empty string-checkipv4 ip v =- let (cur, nxt) = T.break (=='.') ip- nextfunc = if T.null nxt- then v == 3- else checkipv4 (T.tail nxt) (v+1)- goodcur = not (T.null cur) && T.all isDigit cur && (let rcur = read (T.unpack cur) :: Int in (rcur >= 0) && (rcur <= 255))- in goodcur && nextfunc--inrange :: Integer -> Integer -> T.Text -> NativeTypeValidate-inrange mi ma param res =- let va = res ^. rattributes . at param- na = va ^? traverse . _Number- in case (va,na) of- (Nothing, _) -> Right res- (_,Just v) -> if (v >= fromIntegral mi) && (v <= fromIntegral ma)- then Right res- 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
@@ -1,46 +0,0 @@-module Puppet.NativeTypes.Host (nativeHost) where--import Puppet.NativeTypes.Helpers-import Puppet.Interpreter.Types-import Data.Char (isAlphaNum)-import qualified Data.Text as T-import Control.Lens-import qualified Data.Vector as V--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.-parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])]-parameterfunctions =- [("comment" , [string, values ["true","false"]])- ,("ensure" , [defaultvalue "present", string, values ["present","absent"]])- ,("host_aliases" , [rarray, strings, checkhostname])- ,("ip" , [string, mandatory, ipaddr])- ,("name" , [nameval, checkhostname])- ,("provider" , [string, values ["parsed"]])- ,("target" , [string, fullyQualified])- ]--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- Just x@(PString _) -> checkhostname' param res x- Just x -> perror $ paramname param <+> "should be an array or a single string, not" <+> pretty x--checkhostname' :: T.Text -> Resource -> PValue -> Either PrettyError Resource-checkhostname' prm _ (PString "") = perror $ "Empty hostname for parameter" <+> paramname prm-checkhostname' prm res (PString x ) = checkhostname'' prm res x-checkhostname' prm _ x = perror $ "Parameter " <+> paramname prm <+> "should be an string or an array of strings, but this was found :" <+> pretty x--checkhostname'' :: T.Text -> Resource -> T.Text -> Either PrettyError Resource-checkhostname'' prm _ "" = perror $ "Empty hostname part in parameter" <+> paramname prm-checkhostname'' prm res prt =- let (cur,nxt) = T.break (=='.') prt- nextfunc = if T.null nxt- then Right res- else checkhostname'' prm res (T.tail nxt)- in if T.null cur || (T.head cur == '-') || not (T.all (\x -> isAlphaNum x || (x=='-')) cur)- then perror $ "Invalid hostname part for parameter" <+> paramname prm- else nextfunc
− Puppet/NativeTypes/Mount.hs
@@ -1,24 +0,0 @@-module Puppet.NativeTypes.Mount (nativeMount) where--import Puppet.NativeTypes.Helpers-import Puppet.Interpreter.Types-import qualified Data.Text as T--nativeMount :: (NativeTypeName, NativeTypeMethods)-nativeMount = ("mount", nativetypemethods parameterfunctions return)--parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])]-parameterfunctions =- [("atboot" , [string, values ["true","false"]])- ,("blockdevice" , [string])- ,("device" , [string, mandatoryIfNotAbsent])- ,("dump" , [integer, inrange 0 2])- ,("ensure" , [defaultvalue "present", string, values ["present","absent","mounted"]])- ,("fstype" , [string, mandatoryIfNotAbsent])- ,("name" , [nameval])- ,("options" , [string])- ,("pass" , [defaultvalue "0", integer])- ,("provider" , [defaultvalue "parsed", string, values ["parsed"]])- ,("remounts" , [string, values ["true","false"]])- ,("target" , [string, fullyQualified])- ]
− Puppet/NativeTypes/Notify.hs
@@ -1,15 +0,0 @@-module Puppet.NativeTypes.Notify (nativeNotify) where--import Puppet.Interpreter.Types-import Puppet.NativeTypes.Helpers--import qualified Data.Text as T--nativeNotify :: (NativeTypeName, NativeTypeMethods)-nativeNotify = ("notify", nativetypemethods parameterfunctions return)--parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])]-parameterfunctions =- [("message" , [])- ,("withpath" , [string, defaultvalue "false", values ["true","false"]])- ]
− Puppet/NativeTypes/Package.hs
@@ -1,110 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Puppet.NativeTypes.Package (nativePackage) where--import Puppet.NativeTypes.Helpers-import Puppet.Interpreter.Types-import Control.Monad.Except-import qualified Data.HashSet as HS-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import Control.Lens-import GHC.Generics-import Data.Hashable--nativePackage :: (NativeTypeName, NativeTypeMethods)-nativePackage = ("package", nativetypemethods parameterfunctions (getFeature >=> checkFeatures))---- Features are abilities that some providers may not support.-data PackagingFeatures = Holdable | InstallOptions | Installable | Purgeable | UninstallOptions | Uninstallable | Upgradeable | Versionable deriving (Show, Eq, Generic)--instance Hashable PackagingFeatures--isFeatureSupported :: HM.HashMap T.Text (HS.HashSet PackagingFeatures)-isFeatureSupported = HM.fromList [ ("aix", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])- , ("appdmg", HS.fromList [Installable])- , ("apple", HS.fromList [Installable])- , ("apt", HS.fromList [Holdable, InstallOptions, Installable, Purgeable, Uninstallable, Upgradeable, Versionable])- , ("aptitude", HS.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable])- , ("aptrpm", HS.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable])- , ("blastwave", HS.fromList [Installable, Uninstallable, Upgradeable])- , ("dpkg", HS.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable])- , ("fink", HS.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable])- , ("freebsd", HS.fromList [Installable, Uninstallable])- , ("gem", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])- , ("hpux", HS.fromList [Installable, Uninstallable])- , ("macports", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])- , ("msi", HS.fromList [InstallOptions, Installable, UninstallOptions, Uninstallable])- , ("nim", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])- , ("openbsd", HS.fromList [Installable, Uninstallable, Versionable])- , ("pacman", HS.fromList [Installable, Uninstallable, Upgradeable])- , ("pip", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])- , ("pkg", HS.fromList [Holdable, Installable, Uninstallable, Upgradeable, Versionable])- , ("pkgdmg", HS.fromList [Installable])- , ("pkgin", HS.fromList [Installable, Uninstallable])- , ("pkgutil", HS.fromList [Installable, Uninstallable, Upgradeable])- , ("portage", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])- , ("ports", HS.fromList [Installable, Uninstallable, Upgradeable])- , ("portupgrade", HS.fromList [Installable, Uninstallable, Upgradeable])- , ("rpm", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])- , ("rug", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])- , ("sun", HS.fromList [InstallOptions, Installable, Uninstallable, Upgradeable])- , ("sunfreeware", HS.fromList [Installable, Uninstallable, Upgradeable])- , ("up2date", HS.fromList [Installable, Uninstallable, Upgradeable])- , ("urpmi", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])- , ("windows", HS.fromList [InstallOptions, Installable, UninstallOptions, Uninstallable])- , ("yum", HS.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable])- , ("zypper", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])- ]--parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])]-parameterfunctions =- [("adminfile" , [string, fullyQualified])- ,("allowcdrom" , [string, values ["true","false"]])- ,("configfiles" , [string, values ["keep","replace"]])- --,("ensure" , [defaultvalue "present", string, values ["present","absent","latest","held","purged","installed"]])- ,("ensure" , [defaultvalue "present", string])- ,("flavor" , [])- ,("install_options" , [rarray])- ,("name" , [nameval])- ,("provider" , [defaultvalue "apt", string])- ,("responsefile" , [string, fullyQualified])- ,("source" , [string])- ,("uninstall_options", [rarray])- ]--getFeature :: Resource -> Either PrettyError (HS.HashSet PackagingFeatures, Resource)-getFeature res = case res ^. rattributes . at "provider" of- Just (PString x) -> case HM.lookup x isFeatureSupported of- Just s -> Right (s,res)- Nothing -> Left $ PrettyError ("Do not know provider" <+> ttext x)- _ -> Left "Can't happen at Puppet.NativeTypes.Package"--checkFeatures :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError Resource-checkFeatures =- checkAdminFile- >=> checkEnsure- >=> checkParam "install_options" InstallOptions- >=> checkParam "uninstall_options" UninstallOptions- >=> decap- where- checkFeature :: HS.HashSet PackagingFeatures -> Resource -> PackagingFeatures -> Either PrettyError (HS.HashSet PackagingFeatures, Resource)- checkFeature s r f = if HS.member f s- then Right (s, r)- else Left $ PrettyError ("Feature" <+> text (show f) <+> "is required for the current configuration")- checkParam :: T.Text -> PackagingFeatures -> (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError (HS.HashSet PackagingFeatures, Resource)- checkParam pn f (s,r) = if has (ix pn) (r ^. rattributes)- then checkFeature s r f- else Right (s,r)- checkAdminFile :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError (HS.HashSet PackagingFeatures, Resource)- checkAdminFile = Right -- TODO, check that it only works for aix- checkEnsure :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError (HS.HashSet PackagingFeatures, Resource)- checkEnsure (s, res) = case res ^. rattributes . at "ensure" of- Just (PString "latest") -> checkFeature s res Installable- Just (PString "purged") -> checkFeature s res Purgeable- Just (PString "absent") -> checkFeature s res Uninstallable- Just (PString "installed") -> checkFeature s res Installable- Just (PString "present") -> checkFeature s res Installable- Just (PString "held") -> checkFeature s res Installable >> checkFeature s res Holdable- _ -> checkFeature s res Versionable- decap :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError Resource- decap = Right . snd
− Puppet/NativeTypes/SshSecure.hs
@@ -1,33 +0,0 @@-module Puppet.NativeTypes.SshSecure (nativeSshSecure) where--import Puppet.NativeTypes.Helpers-import Puppet.Interpreter.Types-import Control.Monad.Except-import qualified Data.Text as T-import Control.Lens--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.-parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])]-parameterfunctions =- [("type" , [string, defaultvalue "ssh-rsa", values ["rsa","dsa","ssh-rsa","ssh-dss"]])- ,("key" , [string])- ,("user" , [string])- ,("ensure" , [defaultvalue "present", string, values ["present","absent","role"]])- ,("target" , [string])- ,("options" , [rarray, strings])- ]--userOrTarget :: 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 :: 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"
− Puppet/NativeTypes/User.hs
@@ -1,45 +0,0 @@-module Puppet.NativeTypes.User (nativeUser) where--import Puppet.NativeTypes.Helpers-import Puppet.Interpreter.Types-import qualified Data.Text as T--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.-parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])]-parameterfunctions =- [("allowdupe" , [string, defaultvalue "false", values ["true","false"]])- ,("attribute_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]])- ,("attributes" , [rarray,strings])- ,("auth_membership" , [defaultvalue "minimum", string, values ["inclusive","minimum"]])- ,("auths" , [rarray,strings])- ,("comment" , [string])- ,("ensure" , [defaultvalue "present", string, values ["present","absent","role"]])- ,("expiry" , [string])- ,("gid" , [string])- ,("groups" , [rarray,strings])- ,("home" , [string, fullyQualified, noTrailingSlash])- ,("ia_load_module" , [string])- ,("iterations" , [integer])- ,("key_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]])- ,("keys" , [])- ,("managehome" , [string, defaultvalue "false", values ["true","false"]])- ,("membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]])- ,("name" , [nameval])- ,("password" , [string])- ,("password_max_age" , [integer])- ,("password_min_age" , [integer])- ,("profile_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]])- ,("profiles" , [rarray,strings])- ,("project" , [string])- ,("provider" , [string, values ["aix","directoryservice","hpuxuseradd","useradd","ldap","pw","user_role_add","window_adsi"]])- ,("role_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]])- ,("roles" , [rarray,strings])- ,("salt" , [string])- ,("shell" , [string, fullyQualified, noTrailingSlash])- ,("system" , [string, defaultvalue "false", values ["true","false"]])- ,("uid" , [integer])- ]
− Puppet/NativeTypes/ZoneRecord.hs
@@ -1,39 +0,0 @@-module Puppet.NativeTypes.ZoneRecord (nativeZoneRecord) where--import Puppet.NativeTypes.Helpers-import Puppet.Interpreter.Types-import Control.Monad.Except-import qualified Data.Text as T-import Control.Lens--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.-parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])]-parameterfunctions =- [("name" , [nameval])- ,("owner" , [string])- ,("dest" , [string])- ,("ensure" , [defaultvalue "present", string, values ["present","absent"]])- ,("rtype" , [string, defaultvalue "A", values ["SOA", "A", "AAAA", "MX", "NS", "CNAME", "PTR", "SRV"]])- ,("rclass" , [defaultvalue "IN", string])- ,("ttl" , [defaultvalue "2d", string])- ,("target" , [string, mandatory])- ,("nsname" , [string])- ,("serial" , [string])- ,("slave_refresh" , [string])- ,("slave_retry" , [string])- ,("slave_expiration" , [string])- ,("min_ttl" , [string])- ,("email" , [string])- ]--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"]- Just (PString "NS") -> foldM (flip mandatory) res ["owner", "rclass", "rtype", "dest"]- Just (PString _) -> foldM (flip mandatory) res ["owner", "rclass", "rtype", "dest", "ttl"]- Just x -> perror $ "Can't use this for the rtype parameter" <+> pretty x
− Puppet/OptionalTests.hs
@@ -1,99 +0,0 @@-{-# LANGUAGE LambdaCase #-}--- | The module works in IO and throws a 'PrettyError' exception at each failure.--- These exceptions can be caught (see the exceptions package).-module Puppet.OptionalTests (testCatalog) where--import Control.Lens-import Control.Monad (unless)-import Control.Monad.Catch-import Control.Monad.Trans (liftIO)-import Control.Monad.Trans.Except-import Data.Foldable (asum, toList, traverse_)-import qualified Data.HashSet as HS-import Data.Maybe (mapMaybe)-import Data.Monoid ((<>))-import qualified Data.Text as T--import Puppet.Interpreter.PrettyPrinter ()-import Puppet.Interpreter.Types-import Puppet.Lens (_PString)-import Puppet.PP-import Puppet.Preferences-import System.Posix.Files----- | Entry point for all optional tests-testCatalog :: Preferences IO -> FinalCatalog -> IO ()-testCatalog prefs c = testFileSources (prefs ^. prefPuppetPaths.baseDir) c >> testUsersGroups (prefs ^. prefKnownusers) (prefs ^. prefKnowngroups) c---- | Tests that all users and groups are defined-testUsersGroups :: [T.Text] -> [T.Text] -> FinalCatalog -> IO ()-testUsersGroups kusers kgroups c = do- let users = HS.fromList $ "" : "0" : map (view (rid . iname)) (getResourceFrom "user") ++ kusers- groups = HS.fromList $ "" : "0" : map (view (rid . iname)) (getResourceFrom "group") ++ kgroups- checkResource lu lg = mapM_ (checkResource' lu lg)- checkResource' lu lg res = do- let msg att name = align (vsep [ "Resource" <+> ttext (res^.rid.itype)- <+> ttext (res^.rid.iname) <+> showPos (res^.rpos._1)- , "references the unknown" <+> string att <+> squotes (ttext name)])- <> line- case lu of- Just lu' -> do- let u = res ^. rattributes . lu' . _PString- unless (HS.member u users) $ throwM $ PrettyError (msg "user" u)- Nothing -> pure ()- case lg of- Just lg' -> do- let g = res ^. rattributes . lg' . _PString- unless (HS.member g groups) $ throwM $ PrettyError (msg "group" g)- Nothing -> pure ()- do- checkResource (Just $ ix "owner") (Just $ ix "group") (getResourceFrom "file")- checkResource (Just $ ix "user") (Just $ ix "group") (getResourceFrom "exec")- checkResource (Just $ ix "user") Nothing (getResourceFrom "cron")- checkResource (Just $ ix "user") Nothing (getResourceFrom "ssh_authorized_key")- checkResource (Just $ ix "user") Nothing (getResourceFrom "ssh_authorized_key_secure")- checkResource Nothing (Just $ ix "gid") (getResourceFrom "users")- where- getResourceFrom t = c ^.. traverse . filtered (\r -> r ^. rid . itype == t && r ^. rattributes . at "ensure" /= Just "absent")---- | Test source for every file resources in the catalog.-testFileSources :: FilePath -> FinalCatalog -> IO ()-testFileSources basedir c = do- let getFiles = filter presentFile . toList- presentFile r = r ^. rid . itype == "file"- && (r ^. rattributes . at "ensure") `elem` [Nothing, Just "present"]- && r ^. rattributes . at "source" /= Just PUndef- getSource = mapMaybe (\r -> (,) <$> pure r <*> r ^. rattributes . at "source")- checkAllSources basedir $ (getSource . getFiles) c---- | Check source for all file resources and append failures along.-checkAllSources :: FilePath -> [(Resource, PValue)] -> IO ()-checkAllSources fp fs = go fs []- where- go ((res, filesource):xs) es =- runExceptT (checkFile fp filesource) >>= \case- Right () -> go xs es- Left err -> go xs ((PrettyError $ "Could not find " <+> pretty filesource <> semi- <+> align (vsep [getError err, showPos (res^.rpos^._1)])):es)- go [] [] = pure ()- go [] es = traverse_ throwM es--testFile :: FilePath -> ExceptT PrettyError IO ()-testFile fp = do- p <- liftIO (fileExist fp)- unless p (throwE $ PrettyError $ "searched in" <+> squotes (string fp))---- | Only test the `puppet:///` protocol (files managed by the puppet server)--- we don't test absolute path (puppet client files)-checkFile :: FilePath -> PValue -> ExceptT PrettyError IO ()-checkFile basedir (PString f) = case T.stripPrefix "puppet:///" f of- Just stringdir -> case T.splitOn "/" stringdir of- ("modules":modname:rest) -> testFile (basedir <> "/modules/" <> T.unpack modname <> "/files/" <> T.unpack (T.intercalate "/" rest))- ("files":rest) -> testFile (basedir <> "/files/" <> T.unpack (T.intercalate "/" rest))- ("private":_) -> return ()- _ -> throwE (PrettyError $ "Invalid file source:" <+> ttext f)- Nothing -> return ()--- source is always an array of possible paths. We only fails if none of them check.-checkFile basedir (PArray xs) = asum [checkFile basedir x | x <- toList xs]-checkFile _ x = throwE (PrettyError $ "Source was not a string, but" <+> pretty x)
− Puppet/PP.hs
@@ -1,31 +0,0 @@-module Puppet.PP- ( ttext- , prettyToText- , displayNocolor- -- * Re-exports- , module Text.PrettyPrint.ANSI.Leijen- ) where--import Data.Text (Text)-import qualified Data.Text as T-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))--ttext :: T.Text -> Doc-ttext = text . T.unpack--prettyToText :: Doc -> Text-prettyToText = T.pack . prettyToShow--prettyToShow :: Doc -> String-prettyToShow d = displayS (renderCompact d) ""---- | A rendering function that drops colors.-displayNocolor :: Doc -> String-displayNocolor = flip displayS "" . dropEffects . renderPretty 0.4 180- where- dropEffects :: SimpleDoc -> SimpleDoc- dropEffects (SSGR _ x) = dropEffects x- dropEffects (SLine l d) = SLine l (dropEffects d)- dropEffects (SText v t d) = SText v t (dropEffects d)- dropEffects (SChar c d) = SChar c (dropEffects d)- dropEffects x = x
− Puppet/Parser.hs
@@ -1,735 +0,0 @@-{-# LANGUAGE TupleSections #-}--{-| Parse puppet source code from text. -}-module Puppet.Parser (- -- * Runner- runPParser- -- * Parsers- , Parser- , puppetParser- , expression- , datatype-) where--import Control.Applicative-import Control.Lens hiding (noneOf)-import Control.Monad-import Data.Char-import qualified Data.Foldable as F-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NE-import qualified Data.Maybe.Strict as S-import Data.Maybe (fromMaybe)-import Data.Scientific-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Tuple.Strict hiding (fst,zip)-import qualified Data.Vector as V-import Data.Void (Void)-import Text.Megaparsec hiding (token)-import Text.Megaparsec.Char-import qualified Text.Megaparsec.Char.Lexer as L-import Text.Megaparsec.Expr-import Text.Regex.PCRE.ByteString.Utils--import Puppet.Parser.Types-import Puppet.Utils--type Parser = Parsec Void T.Text---- | Run a puppet parser against some 'T.Text' input.-runPParser :: String -> T.Text -> Either (ParseError Char Void) (V.Vector Statement)-runPParser = parse puppetParser--someSpace :: Parser ()-someSpace = L.space (skipSome spaceChar) (L.skipLineComment "#") (L.skipBlockComment "/*" "*/")--token :: Parser a -> Parser a-token = L.lexeme someSpace--integerOrDouble :: Parser (Either Integer Double)-integerOrDouble = fmap Left hex <|> (either Right Left . floatingOrInteger <$> L.scientific)- where- hex = string "0x" *> L.hexadecimal--symbol :: T.Text -> Parser ()-symbol = void . try . L.symbol someSpace--symbolic :: Char -> Parser ()-symbolic = symbol . T.singleton--braces :: Parser a -> Parser a-braces = between (symbol "{") (symbol "}")--parens :: Parser a -> Parser a-parens = between (symbol "(") (symbol ")")--brackets :: Parser a -> Parser a-brackets = between (symbol "[") (symbol "]")--comma :: Parser ()-comma = symbol ","--sepComma :: Parser a -> Parser [a]-sepComma p = p `sepEndBy` comma--sepComma1 :: Parser a -> Parser [a]-sepComma1 p = p `sepEndBy1` comma---- | Parse a collection of puppet 'Statement'.-puppetParser :: Parser (V.Vector Statement)-puppetParser = optional someSpace >> statementList---- | Parse a puppet 'Expression'.-expression :: Parser Expression-expression = condExpression- <|> makeExprParser (token terminal) expressionTable- <?> "expression"- where- condExpression = do- selectedExpression <- try $ do- trm <- token terminal- lookups <- optional indexLookupChain- symbolic '?'- return $ maybe trm ($ trm) lookups- let cas = do- c <- (SelectorDefault <$ symbol "default") -- default case- <|> fmap SelectorType (try datatype)- <|> fmap SelectorValue- ( fmap UVariableReference variableReference- <|> fmap UBoolean puppetBool- <|> (UUndef <$ symbol "undef")- <|> literalValue- <|> fmap UInterpolable interpolableString- <|> (URegexp <$> termRegexp)- )- void $ symbol "=>"- e <- expression- return (c :!: e)- cases <- braces (sepComma1 cas)- return (ConditionalValue selectedExpression (V.fromList cases))--variable :: Parser Expression-variable = Terminal . UVariableReference <$> variableReference--stringLiteral' :: Parser T.Text-stringLiteral' = char '\'' *> interior <* symbolic '\''- where- interior = T.pack . concat <$> many (some (noneOf ['\'', '\\']) <|> (char '\\' *> fmap escape anyChar))- escape '\'' = "'"- escape x = ['\\',x]--identifier :: Parser String-identifier = some (satisfy identifierPart)--identifierPart :: Char -> Bool-identifierPart x = isAsciiLower x || isAsciiUpper x || isDigit x || (x == '_')--identl :: Parser Char -> Parser Char -> Parser T.Text-identl fstl nxtl = do- f <- fstl- nxt <- token $ many nxtl- return $ T.pack $ f : nxt--operator :: T.Text -> Parser ()-operator = void . try . symbol--reserved :: T.Text -> Parser ()-reserved s = try $ do- void (string s)- notFollowedBy (satisfy identifierPart)- someSpace--variableName :: Parser T.Text-variableName = do- let acceptablePart = T.pack <$> many (satisfy identifierAcceptable)- identifierAcceptable x = isAsciiLower x || isAsciiUpper x || isDigit x || (x == '_')- out <- qualif acceptablePart- when (out == "string") (fail "The special variable $string should never be used")- return out--qualif :: Parser T.Text -> Parser T.Text-qualif p = token $ do- header <- option "" (string "::")- ( header <> ) . T.intercalate "::" <$> p `sepBy1` string "::"--qualif1 :: Parser T.Text -> Parser T.Text-qualif1 p = try $ do- r <- qualif p- unless ("::" `T.isInfixOf` r) (fail "This parser is not qualified")- return r--className :: Parser T.Text-className = qualif moduleName---- yay with reserved words-typeName :: Parser T.Text-typeName = className--moduleName :: Parser T.Text-moduleName = genericModuleName False--resourceNameRef :: Parser T.Text-resourceNameRef = qualif (genericModuleName True)--genericModuleName :: Bool -> Parser T.Text-genericModuleName isReference = do- let acceptable x = isAsciiLower x || isDigit x || (x == '_')- firstletter = if isReference- then fmap toLower (satisfy isAsciiUpper)- else satisfy isAsciiLower- identl firstletter (satisfy acceptable)--parameterName :: Parser T.Text-parameterName = moduleName--variableReference :: Parser T.Text-variableReference = char '$' *> variableName--interpolableString :: Parser (V.Vector Expression)-interpolableString = V.fromList <$> between (char '"') (symbolic '"')- ( many (interpolableVariableReference <|> doubleQuotedStringContent <|> fmap (Terminal . UString . T.singleton) (char '$')) )- where- doubleQuotedStringContent = Terminal . UString . T.pack . concat <$>- some ((char '\\' *> fmap stringEscape anyChar) <|> some (noneOf [ '"', '\\', '$' ]))- stringEscape :: Char -> String- stringEscape 'n' = "\n"- stringEscape 't' = "\t"- stringEscape 'r' = "\r"- stringEscape '"' = "\""- stringEscape '\\' = "\\"- stringEscape '$' = "$"- stringEscape x = ['\\',x]- -- this is specialized because we can't be "tokenized" here- variableAccept x = isAsciiLower x || isAsciiUpper x || isDigit x || x == '_'- rvariableName = do- v <- T.concat <$> some (string "::" <|> fmap T.pack (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 = do- void (char '$')- let fenced = try (simpleIndexing <* char '}')- <|> try (rvariable <* char '}')- <|> (expression <* char '}')- (symbolic '{' *> fenced) <|> try rvariable <|> pure (Terminal (UString (T.singleton '$')))--regexp :: Parser T.Text-regexp = do- void (char '/')- T.pack . concat <$> many ( do { void (char '\\') ; x <- anyChar; return ['\\', x] } <|> some (noneOf [ '/', '\\' ]) )- <* symbolic '/'--puppetArray :: Parser UnresolvedValue-puppetArray = fmap (UArray . V.fromList) (brackets (sepComma expression)) <?> "Array"--puppetHash :: Parser UnresolvedValue-puppetHash = fmap (UHash . V.fromList) (braces (sepComma hashPart)) <?> "Hash"- where- hashPart = (:!:) <$> (expression <* operator "=>")- <*> expression--puppetBool :: Parser Bool-puppetBool = (reserved "true" >> return True)- <|> (reserved "false" >> return False)- <?> "Boolean"--resourceReferenceRaw :: Parser (T.Text, [Expression])-resourceReferenceRaw = do- restype <- resourceNameRef <?> "Resource reference type"- resnames <- brackets (expression `sepBy1` comma) <?> "Resource reference values"- return (restype, resnames)--resourceReference :: Parser UnresolvedValue-resourceReference = do- (restype, resnames) <- resourceReferenceRaw- return $ UResourceReference restype $ case resnames of- [x] -> x- _ -> Terminal $ UArray (V.fromList resnames)--bareword :: Parser T.Text-bareword = identl (satisfy isAsciiLower) (satisfy acceptable) <?> "Bare word"- where- acceptable x = isAsciiLower x || isAsciiUpper x || isDigit x || (x == '_') || (x == '-')---- The first argument defines if non-parenthesized arguments are acceptable-genFunctionCall :: Bool -> Parser (T.Text, V.Vector Expression)-genFunctionCall nonparens = do- fname <- moduleName <?> "Function name"- -- this is a hack. Contrary to what the documentation says,- -- a "bareword" can perfectly be a qualified name :- -- include foo::bar- let argsc sep e = (fmap (Terminal . UString) (qualif1 className) <|> e <?> "Function argument A") `sep` comma- terminalF = terminalG (fail "function hack")- expressionF = makeExprParser (token terminalF) expressionTable <?> "function expression"- withparens = parens (argsc sepEndBy expression)- withoutparens = argsc sepEndBy1 expressionF- args <- withparens <|> if nonparens- then withoutparens <?> "Function arguments B"- else fail "Function arguments C"- return (fname, V.fromList args)---literalValue :: Parser UnresolvedValue-literalValue = token (fmap UString stringLiteral' <|> fmap UString bareword <|> fmap UNumber numericalvalue <?> "Literal Value")- where- 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 (Terminal . UInterpolable) interpolableString- <|> (reserved "undef" *> return (Terminal UUndef))- <|> fmap (Terminal . URegexp) termRegexp- <|> variable- <|> fmap Terminal puppetArray- <|> fmap Terminal puppetHash- <|> fmap (Terminal . UBoolean) puppetBool- <|> fmap Terminal resourceReference- <|> g- <|> fmap Terminal literalValue--compileRegexp :: T.Text -> Parser CompRegex-compileRegexp p = case compile' compBlank execBlank (T.encodeUtf8 p) of- Right r -> return $ CompRegex p r- Left ms -> fail ("Can't parse regexp /" ++ T.unpack p ++ "/ : " ++ show ms)--termRegexp :: Parser CompRegex-termRegexp = regexp >>= compileRegexp--terminal :: Parser Expression-terminal = terminalG (fmap Terminal (fmap UHOLambdaCall (try lambdaCall) <|> try funcCall))- where- funcCall :: Parser UnresolvedValue- funcCall = do- (fname, args) <- genFunctionCall False- return $ UFunctionCall fname args--expressionTable :: [[Operator Parser Expression]]-expressionTable = [ [ Postfix indexLookupChain ] -- http://stackoverflow.com/questions/10475337/parsec-expr-repeated-prefix-postfix-operator-not-supported- , [ Prefix ( operator "-" >> return Negate ) ]- , [ Prefix ( operator "!" >> return Not ) ]- , [ InfixL ( operator "." >> return FunctionApplication ) ]- , [ InfixL ( reserved "in" >> return Contains ) ]- , [ InfixL ( operator "/" >> return Division )- , InfixL ( operator "*" >> return Multiplication )- ]- , [ InfixL ( operator "+" >> return Addition )- , InfixL ( operator "-" >> return Substraction )- ]- , [ InfixL ( operator "<<" >> return LeftShift )- , InfixL ( operator ">>" >> return RightShift )- ]- , [ InfixL ( operator "==" >> return Equal )- , InfixL ( operator "!=" >> return Different )- ]- , [ InfixL ( operator "=~" >> return RegexMatch )- , InfixL ( operator "!~" >> return NotRegexMatch )- ]- , [ InfixL ( operator ">=" >> return MoreEqualThan )- , InfixL ( operator "<=" >> return LessEqualThan )- , InfixL ( operator ">" >> return MoreThan )- , InfixL ( operator "<" >> return LessThan )- ]- , [ InfixL ( reserved "and" >> return And )- , InfixL ( reserved "or" >> return Or )- ]- ]--indexLookupChain :: Parser (Expression -> Expression)-indexLookupChain = foldr1 (flip (.)) <$> some checkLookup- where- checkLookup = flip Lookup <$> between (operator "[") (operator "]") expression--stringExpression :: Parser Expression-stringExpression = fmap (Terminal . UInterpolable) interpolableString <|> (reserved "undef" *> return (Terminal UUndef)) <|> fmap (Terminal . UBoolean) puppetBool <|> variable <|> fmap Terminal literalValue--varAssign :: Parser VarAssignDecl-varAssign = do- p <- getPosition- v <- variableReference- void $ symbolic '='- e <- expression- when (T.all isDigit v) (fail "Can't assign fully numeric variables")- pe <- getPosition- return (VarAssignDecl v e (p :!: pe))--nodeDecl :: Parser [NodeDecl]-nodeDecl = do- p <- getPosition- reserved "node"- let toString (UString s) = s- toString (UNumber n) = scientific2text n- toString _ = error "Can't happen at nodeDecl"- nodename = (reserved "default" >> return NodeDefault) <|> fmap (NodeName . toString) literalValue- ns <- (fmap NodeMatch termRegexp <|> nodename) `sepBy1` comma- inheritance <- option S.Nothing (fmap S.Just (reserved "inherits" *> nodename))- st <- braces statementList- pe <- getPosition- return [NodeDecl n st inheritance (p :!: pe) | n <- ns]--defineDecl :: Parser DefineDecl-defineDecl = do- p <- getPosition- reserved "define"- name <- typeName- -- TODO check native type- params <- option V.empty puppetClassParameters- st <- braces statementList- pe <- getPosition- return (DefineDecl name params st (p :!: pe))--puppetClassParameters :: Parser (V.Vector (Pair (Pair T.Text (S.Maybe DataType)) (S.Maybe Expression)))-puppetClassParameters = V.fromList <$> parens (sepComma var)- where- toStrictMaybe (Just x) = S.Just x- toStrictMaybe Nothing = S.Nothing- var :: Parser (Pair (Pair T.Text (S.Maybe DataType)) (S.Maybe Expression))- var = do- tp <- toStrictMaybe <$> optional datatype- n <- variableReference- df <- toStrictMaybe <$> optional (symbolic '=' *> expression)- return (n :!: tp :!: df)--puppetIfStyleCondition :: Parser (Pair Expression (V.Vector Statement))-puppetIfStyleCondition = (:!:) <$> expression <*> braces statementList--unlessCondition :: Parser ConditionalDecl-unlessCondition = do- p <- getPosition- reserved "unless"- (cond :!: stmts) <- puppetIfStyleCondition- pe <- getPosition- return (ConditionalDecl (V.singleton (Not cond :!: stmts)) (p :!: pe))--ifCondition :: Parser ConditionalDecl-ifCondition = do- p <- getPosition- reserved "if"- maincond <- puppetIfStyleCondition- others <- many (reserved "elsif" *> puppetIfStyleCondition)- elsecond <- option V.empty (reserved "else" *> braces statementList)- let ec = if V.null elsecond- then []- else [Terminal (UBoolean True) :!: elsecond]- pe <- getPosition- return (ConditionalDecl (V.fromList (maincond : others ++ ec)) (p :!: pe))--caseCondition :: Parser ConditionalDecl-caseCondition = do- let puppetRegexpCase = Terminal . URegexp <$> termRegexp- defaultCase = Terminal (UBoolean True) <$ try (reserved "default")- matchesToExpression e (x, stmts) = f x :!: stmts- where f = case x of- (Terminal (UBoolean _)) -> id- (Terminal (URegexp _)) -> RegexMatch e- _ -> Equal e- cases = do- matches <- (puppetRegexpCase <|> defaultCase <|> expression) `sepBy1` comma- void $ symbolic ':'- stmts <- braces statementList- return $ map (,stmts) matches- p <- getPosition- reserved "case"- expr1 <- expression- condlist <- concat <$> braces (some cases)- pe <- getPosition- return (ConditionalDecl (V.fromList (map (matchesToExpression expr1) condlist)) (p :!: pe) )--data OperatorChain a = OperatorChain a LinkType (OperatorChain a)- | EndOfChain a--instance F.Foldable OperatorChain where- foldMap f (EndOfChain x) = f x- foldMap f (OperatorChain a _ nx) = f a <> F.foldMap f nx--operatorChainStatement :: OperatorChain a -> a-operatorChainStatement (OperatorChain a _ _) = a-operatorChainStatement (EndOfChain x) = x--zipChain :: OperatorChain a -> [ ( a, a, LinkType ) ]-zipChain (OperatorChain a d nx) = (a, operatorChainStatement nx, d) : zipChain nx-zipChain (EndOfChain _) = []--depOperator :: Parser LinkType-depOperator = (operator "->" *> pure RBefore)- <|> (operator "~>" *> pure RNotify)----assignment :: Parser AttributeDecl-assignment = AttributeDecl <$> key <*> arrowOp <*> expression- where- key = identl (satisfy isAsciiLower) (satisfy acceptable) <?> "Assignment key"- acceptable x = isAsciiLower x || isAsciiUpper x || isDigit x || (x == '_') || (x == '-')- arrowOp =- (symbol "=>" *> pure AssignArrow)- <|> (symbol "+>" *> pure AppendArrow)--searchExpression :: Parser SearchExpression-searchExpression = makeExprParser (token searchterm) searchTable- where- searchTable :: [[Operator Parser SearchExpression]]- searchTable = [ [ InfixL ( reserved "and" >> return AndSearch )- , InfixL ( reserved "or" >> return OrSearch )- ] ]- searchterm = parens searchExpression <|> check- check = do- attrib <- parameterName- opr <- (operator "==" *> return EqualitySearch) <|> (operator "!=" *> return NonEqualitySearch)- term <- stringExpression- return (opr attrib term)--resCollDecl :: Position -> T.Text -> Parser ResCollDecl-resCollDecl p restype = do- openchev <- some (char '<')- when (length openchev > 2) (fail "Too many brackets")- void $ symbolic '|'- e <- option AlwaysTrue searchExpression- void (char '|')- void (count (length openchev) (char '>'))- someSpace- overrides <- option [] $ braces (sepComma assignment)- let collectortype = if length openchev == 1- then Collector- else ExportedCollector- pe <- getPosition- return (ResCollDecl collectortype restype e (V.fromList overrides) (p :!: pe) )--classDecl :: Parser ClassDecl-classDecl = do- p <- getPosition- reserved "class"- ClassDecl <$> className- <*> option V.empty puppetClassParameters- <*> option S.Nothing (fmap S.Just (reserved "inherits" *> className))- <*> braces statementList- <*> ( (p :!:) <$> getPosition )--mainFuncDecl :: Parser MainFuncDecl-mainFuncDecl = do- p <- getPosition- (fname, args) <- genFunctionCall True- pe <- getPosition- return (MainFuncDecl fname args (p :!: pe))--hoLambdaDecl :: Parser HigherOrderLambdaDecl-hoLambdaDecl = do- p <- getPosition- fc <- try lambdaCall- pe <- getPosition- return (HigherOrderLambdaDecl fc (p :!: pe))--dotLambdaDecl :: Parser HigherOrderLambdaDecl-dotLambdaDecl = do- p <- getPosition- ex <- expression- pe <- getPosition- hf <- case ex of- FunctionApplication e (Terminal (UHOLambdaCall hf)) -> do- unless (S.isNothing (hf ^. hoLambdaExpr)) (fail "Can't call a function with . and ()")- return (hf & hoLambdaExpr .~ S.Just e)- Terminal (UHOLambdaCall hf) -> do- when (S.isNothing (hf ^. hoLambdaExpr)) (fail "This function needs data to operate on")- return hf- _ -> fail "A method chained by dots."- unless (hf ^. hoLambdaFunc == LambEach) (fail "Expected 'each', the other types of method calls are not supported by language-puppet at the statement level.")- return (HigherOrderLambdaDecl hf (p :!: pe))---resDefaultDecl :: Parser ResDefaultDecl-resDefaultDecl = do- p <- getPosition- rnd <- resourceNameRef- let assignmentList = V.fromList <$> sepComma1 assignment- asl <- braces assignmentList- pe <- getPosition- return (ResDefaultDecl rnd asl (p :!: pe))--resOverrideDecl :: Parser [ResOverrideDecl]-resOverrideDecl = do- p <- getPosition- restype <- resourceNameRef- names <- brackets (expression `sepBy1` comma) <?> "Resource reference values"- assignments <- V.fromList <$> braces (sepComma assignment)- pe <- getPosition- return [ ResOverrideDecl restype n assignments (p :!: pe) | n <- names ]---- | Heterogeneous chain (interleaving resource declarations with--- resource references)needs to be supported:------ class { 'docker::service': } ->--- Class['docker']-chainableResources :: Parser [Statement]-chainableResources = 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 <$> resCollDecl p restype- chain <- parseRelationships $ pure <$> try withresname <|> map ChainResDecl <$> resDeclGroup- let relations = do- (g1, g2, lt) <- zipChain chain- (rt1, rn1, _ :!: pe1) <- concatMap extractResRef g1- (rt2, rn2, ps2 :!: _ ) <- concatMap extractResRef g2- return (DepDecl (rt1 :!: rn1) (rt2 :!: rn2) lt (pe1 :!: ps2))- return $ map DependencyDeclaration relations <> (chain ^.. folded . folded . to extractChainStatement . folded)- where- extractResRef :: ChainableRes -> [(T.Text, Expression, PPosition)]- extractResRef (ChainResColl _) = []- extractResRef (ChainResDecl (ResDecl rt rn _ _ pp)) = [(rt,rn,pp)]- extractResRef (ChainResRefr rt rns pp) = [(rt,rn,pp) | rn <- rns]-- extractChainStatement :: ChainableRes -> [Statement]- extractChainStatement (ChainResColl r) = [ResourceCollectionDeclaration r]- extractChainStatement (ChainResDecl d) = [ResourceDeclaration d]- extractChainStatement ChainResRefr{} = []-- parseRelationships :: Parser a -> Parser (OperatorChain a)- parseRelationships p = do- g <- p- o <- optional depOperator- case o of- Just o' -> OperatorChain g o' <$> parseRelationships p- Nothing -> pure (EndOfChain g)-- resDeclGroup :: Parser [ResDecl]- resDeclGroup = do- let resourceName = expression- resourceDeclaration = do- p <- getPosition- names <- brackets (sepComma1 resourceName) <|> fmap return resourceName- void $ symbolic ':'- vals <- fmap V.fromList (sepComma assignment)- pe <- getPosition- return [(n, vals, p :!: pe) | n <- names ]- groupDeclaration = (,) <$> many (char '@') <*> typeName <* symbolic '{'- (virts, rtype) <- try groupDeclaration -- for matching reasons, this gets a try until the opening brace- let sep = symbolic ';' <|> comma- x <- resourceDeclaration `sepEndBy1` sep- void $ symbolic '}'- virtuality <- case virts of- "" -> return Normal- "@" -> return Virtual- "@@" -> return Exported- _ -> fail "Invalid virtuality"- return [ ResDecl rtype rname conts virtuality pos | (rname, conts, pos) <- concat x ]--statement :: Parser [Statement]-statement =- (pure . HigherOrderLambdaDeclaration <$> try dotLambdaDecl)- <|> (pure . VarAssignmentDeclaration <$> varAssign)- <|> (map NodeDeclaration <$> nodeDecl)- <|> (pure . DefineDeclaration <$> defineDecl)- <|> (pure . ConditionalDeclaration <$> unlessCondition)- <|> (pure . ConditionalDeclaration <$> ifCondition)- <|> (pure . ConditionalDeclaration <$> caseCondition)- <|> (pure . ResourceDefaultDeclaration <$> try resDefaultDecl)- <|> (map ResourceOverrideDeclaration <$> try resOverrideDecl)- <|> chainableResources- <|> (pure . ClassDeclaration <$> classDecl)- <|> (pure . HigherOrderLambdaDeclaration <$> hoLambdaDecl)- <|> (pure . MainFunctionDeclaration <$> mainFuncDecl)- <?> "Statement"--datatype :: Parser DataType-datatype = dtString- <|> dtInteger- <|> dtFloat- <|> dtNumeric- <|> (DTBoolean <$ reserved "Boolean")- <|> (DTScalar <$ reserved "Scalar")- <|> (DTData <$ reserved "Data")- <|> (DTAny <$ reserved "Any")- <|> (DTCollection <$ reserved "Collection")- <|> dtArray- <|> dtHash- <|> (DTUndef <$ reserved "Undef")- <|> (reserved "Optional" *> (DTOptional <$> brackets datatype))- <|> (NotUndef <$ reserved "NotUndef")- <|> (reserved "Variant" *> (DTVariant . NE.fromList <$> brackets (datatype `sepBy1` symbolic ',')))- <|> (reserved "Pattern" *> (DTPattern . NE.fromList <$> brackets (termRegexp `sepBy1` symbolic ',')))- <|> (reserved "Enum" *> (DTEnum . NE.fromList <$> brackets ((stringLiteral' <|> bareword) `sepBy1` symbolic ',')))- <?> "DataType"- where- integer = integerOrDouble >>= either (return . fromIntegral) (\d -> fail ("Integer value expected, instead of " ++ show d))- float = either fromIntegral id <$> integerOrDouble- dtArgs str def parseArgs = do- void $ reserved str- fromMaybe def <$> optional (brackets parseArgs)- dtbounded s constructor parser = dtArgs s (constructor Nothing Nothing) $ do- lst <- parser `sepBy1` symbolic ','- case lst of- [minlen] -> return $ constructor (Just minlen) Nothing- [minlen,maxlen] -> return $ constructor (Just minlen) (Just maxlen)- _ -> fail ("Too many arguments to datatype " ++ T.unpack s)- dtString = dtbounded "String" DTString integer- dtInteger = dtbounded "Integer" DTInteger integer- dtFloat = dtbounded "Float" DTFloat float- dtNumeric = dtbounded "Numeric" (\ma mb -> DTVariant (DTFloat ma mb :| [DTInteger (truncate <$> ma) (truncate <$> mb)])) float- dtArray = do- reserved "Array"- ml <- optional $ brackets $ do- tp <- datatype- rst <- optional (symbolic ',' *> integer `sepBy1` symbolic ',')- return (tp, rst)- case ml of- Nothing -> return (DTArray DTData 0 Nothing)- Just (t, Nothing) -> return (DTArray t 0 Nothing)- Just (t, Just [mi]) -> return (DTArray t mi Nothing)- Just (t, Just [mi, mx]) -> return (DTArray t mi (Just mx))- Just (_, Just _) -> fail "Too many arguments to datatype Array"- dtHash = do- reserved "Hash"- ml <- optional $ brackets $ do- tk <- datatype- symbolic ','- tv <- datatype- rst <- optional (symbolic ',' *> integer `sepBy1` symbolic ',')- return (tk, tv, rst)- case ml of- Nothing -> return (DTHash DTScalar DTData 0 Nothing)- Just (tk, tv, Nothing) -> return (DTHash tk tv 0 Nothing)- Just (tk, tv, Just [mi]) -> return (DTHash tk tv mi Nothing)- Just (tk, tv, Just [mi, mx]) -> return (DTHash tk tv mi (Just mx))- Just (_, _, Just _) -> fail "Too many arguments to datatype Hash"--statementList :: Parser (V.Vector Statement)-statementList = (V.fromList . concat) <$> many statement--lambdaCall :: Parser HOLambdaCall-lambdaCall = do- let toStrict (Just x) = S.Just x- toStrict Nothing = S.Nothing- HOLambdaCall <$> lambFunc- <*> fmap (toStrict . join) (optional (parens (optional expression)))- <*> lambParams- <*> (symbolic '{' *> fmap (V.fromList . concat) (many (try statement)))- <*> fmap toStrict (optional expression) <* symbolic '}'- where- lambFunc :: Parser LambdaFunc- lambFunc = (reserved "each" *> pure LambEach)- <|> (reserved "map" *> pure LambMap )- <|> (reserved "reduce" *> pure LambReduce)- <|> (reserved "filter" *> pure LambFilter)- <|> (reserved "slice" *> pure LambSlice)- <|> (reserved "lookup" *> pure LambLookup)- lambParams :: Parser LambdaParameters- lambParams = between (symbolic '|') (symbolic '|') hp- where- acceptablePart = T.pack <$> identifier- lambdaParameter :: Parser LambdaParameter- lambdaParameter = LParam <$> optional datatype <*> (char '$' *> acceptablePart)- hp = do- vars <- lambdaParameter `sepBy1` comma- case vars of- [a] -> return (BPSingle a)- [a,b] -> return (BPPair a b)- _ -> fail "Invalid number of variables between the pipes"
− Puppet/Parser/PrettyPrinter.hs
@@ -1,239 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Puppet.Parser.PrettyPrinter where--import qualified Data.Maybe.Strict as S-import qualified Data.Text as T-import Data.Tuple.Strict (Pair ((:!:)))-import qualified Data.Tuple.Strict as S-import qualified Data.Vector as V-import Puppet.Parser.Types-import Puppet.PP-import Puppet.Utils-import Text.PrettyPrint.ANSI.Leijen ((<$>))-import Prelude hiding ((<$>))--capitalize :: T.Text -> Doc-capitalize = dullyellow . text . T.unpack . capitalizeRT--parensList :: Pretty a => V.Vector a -> Doc-parensList = tupled . map pretty . V.toList--hashComma :: (Pretty a, Pretty b) => V.Vector (Pair a b) -> Doc-hashComma = encloseSep lbrace rbrace comma . map showC . V.toList- where- showC (a :!: b) = pretty a <+> text "=>" <+> pretty b---- Extremely hacky escaping system-stringEscape :: T.Text -> T.Text-stringEscape = T.concatMap escapeChar- where- escapeChar '"' = "\\\""- escapeChar '\n' = "\\n"- escapeChar '\t' = "\\t"- escapeChar '\r' = "\\r"- escapeChar x = T.singleton x-{-# INLINE stringEscape #-}--instance Pretty DataType where- pretty t = case t of- DTType -> "Type"- DTString ma mb -> bounded "String" ma mb- DTInteger ma mb -> bounded "Integer" ma mb- DTFloat ma mb -> bounded "Float" ma mb- DTBoolean -> "Boolean"- DTArray dt mi mmx -> "Array" <> list (pretty dt : pretty mi : maybe [] (pure . pretty) mmx)- DTHash kt dt mi mmx -> "Hash" <> list (pretty kt : pretty dt : pretty mi : maybe [] (pure . pretty) mmx)- DTUndef -> "Undef"- DTScalar -> "Scalar"- DTData -> "Data"- DTOptional o -> "Optional" <> brackets (pretty o)- NotUndef -> "NotUndef"- DTVariant vs -> "Variant" <> list (foldMap (pure . pretty) vs)- DTPattern vs -> "Pattern" <> list (foldMap (pure . pretty) vs)- DTEnum tx -> "Enum" <> list (foldMap (pure . text . T.unpack) tx)- DTAny -> "Any"- DTCollection -> "Collection"- where- bounded :: (Pretty a, Pretty b) => Doc -> Maybe a -> Maybe b -> Doc- bounded s ma mb = s <> case (ma, mb) of- (Just a, Nothing) -> list [pretty a]- (Just a, Just b) -> list [pretty a, pretty b]- _ -> mempty--instance Pretty Expression where- pretty (Equal a b) = parens (pretty a <+> text "==" <+> pretty b)- pretty (Different a b) = parens (pretty a <+> text "!=" <+> pretty b)- pretty (And a b) = parens (pretty a <+> text "and" <+> pretty b)- pretty (Or a b) = parens (pretty a <+> text "or" <+> pretty b)- pretty (LessThan a b) = parens (pretty a <+> text "<" <+> pretty b)- pretty (MoreThan a b) = parens (pretty a <+> text ">" <+> pretty b)- pretty (LessEqualThan a b) = parens (pretty a <+> text "<=" <+> pretty b)- pretty (MoreEqualThan a b) = parens (pretty a <+> text ">=" <+> pretty b)- pretty (RegexMatch a b) = parens (pretty a <+> text "=~" <+> pretty b)- pretty (NotRegexMatch a b) = parens (pretty a <+> text "!~" <+> pretty b)- pretty (Contains a b) = parens (pretty a <+> text "in" <+> pretty b)- pretty (Addition a b) = parens (pretty a <+> text "+" <+> pretty b)- pretty (Substraction a b) = parens (pretty a <+> text "-" <+> pretty b)- pretty (Division a b) = parens (pretty a <+> text "/" <+> pretty b)- pretty (Multiplication a b) = parens (pretty a <+> text "*" <+> pretty b)- pretty (Modulo a b) = parens (pretty a <+> text "%" <+> pretty b)- pretty (RightShift a b) = parens (pretty a <+> text ">>" <+> pretty b)- pretty (LeftShift a b) = parens (pretty a <+> text "<<" <+> pretty b)- pretty (Lookup a b) = pretty a <> brackets (pretty b)- pretty (ConditionalValue a b) = parens (pretty a <+> text "?" <+> hashComma b)- pretty (Negate a) = text "-" <+> parens (pretty a)- pretty (Not a) = text "!" <+> parens (pretty a)- pretty (Terminal a) = pretty a- pretty (FunctionApplication e1 e2) = parens (pretty e1) <> text "." <> pretty e2--instance Pretty LambdaFunc where- pretty LambEach = bold $ red $ text "each"- pretty LambMap = bold $ red $ text "map"- pretty LambReduce = bold $ red $ text "reduce"- pretty LambFilter = bold $ red $ text "filter"- pretty LambSlice = bold $ red $ text "slice"- pretty LambLookup = bold $ red $ text "lookup"--instance Pretty LambdaParameters where- pretty b = magenta (char '|') <+> vars <+> magenta (char '|')- where- pmspace = foldMap ((<> " ") . pretty)- vars = case b of- BPSingle (LParam mt v) -> pmspace mt <> pretty (UVariableReference v)- BPPair (LParam mt1 v1) (LParam mt2 v2) -> pmspace mt1 <> pretty (UVariableReference v1) <> comma <+> pmspace mt2 <> pretty (UVariableReference v2)--instance Pretty SearchExpression where- pretty (EqualitySearch t e) = text (T.unpack t) <+> text "==" <+> pretty e- pretty (NonEqualitySearch t e) = text (T.unpack t) <+> text "!=" <+> pretty e- pretty AlwaysTrue = empty- pretty (AndSearch s1 s2) = parens (pretty s1) <+> text "and" <+> parens (pretty s2)- pretty (OrSearch s1 s2) = parens (pretty s1) <+> text "and" <+> parens (pretty s2)--instance Pretty UnresolvedValue where- pretty (UBoolean True) = dullmagenta $ text "true"- pretty (UBoolean False) = dullmagenta $ text "false"- pretty (UString s) = char '"' <> dullcyan (ttext (stringEscape s)) <> char '"'- pretty (UNumber n) = cyan (ttext (scientific2text n))- pretty (UInterpolable v) = char '"' <> hcat (map specific (V.toList v)) <> char '"'- where- 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) = pretty r- pretty (UVariableReference v) = dullblue (char '$' <> text (T.unpack v))- pretty (UFunctionCall f args) = showFunc f args- pretty (UHOLambdaCall c) = pretty c--instance Pretty CompRegex where- pretty (CompRegex r _) = char '/' <> text (T.unpack r) <> char '/'--instance Pretty HOLambdaCall where- pretty (HOLambdaCall hf me bp stts mee) = pretty hf <> mme <+> pretty bp <+> nest 2 (char '{' <$> ppStatements stts <> mmee) <$> char '}'- where- mme = case me of- S.Just x -> mempty <+> pretty x- S.Nothing -> mempty- mmee = case mee of- S.Just x -> mempty </> pretty x- S.Nothing -> mempty-instance Pretty SelectorCase where- pretty SelectorDefault = dullmagenta (text "default")- pretty (SelectorType t) = pretty t- pretty (SelectorValue v) = pretty v--instance Pretty LinkType where- pretty RNotify = "~>"- pretty RRequire = "<-"- pretty RBefore = "->"- pretty RSubscribe = "<~"--instance Pretty ArrowOp where- pretty AssignArrow = "=>"- pretty AppendArrow = "+>"--showPos :: Position -> Doc-showPos p = green (char '#' <+> string (show p))--showPPos :: PPosition -> Doc-showPPos p = green (char '#' <+> string (show (S.fst p)))--showAss :: V.Vector AttributeDecl -> Doc-showAss vx = folddoc (\a b -> a <> char ',' <$> b) prettyDecl (V.toList vx)- where- folddoc _ _ [] = empty- folddoc acc docGen (x:xs) = foldl acc (docGen x) (map docGen xs)- maxlen = maximum (fmap (\(AttributeDecl k _ _) -> T.length k) vx)- prettyDecl (AttributeDecl k op v) = dullblue (fill maxlen (ttext k)) <+> pretty op <+> pretty v--showArgs :: V.Vector (Pair (Pair T.Text (S.Maybe DataType)) (S.Maybe Expression)) -> Doc-showArgs vec = tupled (map ra lst)- where- lst = V.toList vec- maxlen = maximum (map (T.length . S.fst . S.fst) lst)- ra (argname :!: mtype :!: rval)- = dullblue (char '$' <> foldMap (\t -> pretty t <+> empty) mtype- <> fill maxlen (text (T.unpack argname)))- <> foldMap (\v -> empty <+> char '=' <+> pretty v) rval--showFunc :: T.Text -> V.Vector Expression -> Doc-showFunc funcname args = bold (red (text (T.unpack funcname))) <> parensList args-braceStatements :: V.Vector Statement -> Doc-braceStatements stts = nest 2 (char '{' <$> ppStatements stts) <$> char '}'--instance Pretty NodeDesc where- pretty NodeDefault = dullmagenta (text "default")- pretty (NodeName n) = pretty (UString n)- pretty (NodeMatch r) = pretty (URegexp r)--instance Pretty Statement where- pretty (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl c p)) = pretty c <+> showPPos p- pretty (ConditionalDeclaration (ConditionalDecl 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 (Terminal (UBoolean True) :!: st) = text "else" <+> braceStatements st- rendernexts (c :!: st) | V.null st = empty- | otherwise = text "elsif" <+> pretty c <+> braceStatements st- pretty (MainFunctionDeclaration (MainFuncDecl funcname args p)) = showFunc funcname args <+> showPPos p- pretty (ResourceDefaultDeclaration (ResDefaultDecl rtype defaults p)) = capitalize rtype <+> nest 2 (char '{' <+> showPPos p <$> showAss defaults) <$> char '}'- pretty (ResourceOverrideDeclaration (ResOverrideDecl rtype rnames overs p)) = pretty (UResourceReference rtype rnames) <+> nest 2 (char '{' <+> showPPos p <$> showAss overs) <$> char '}'- pretty (ResourceDeclaration (ResDecl 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 (DefineDecl 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 (VarAssignmentDeclaration (VarAssignDecl a b p)) = dullblue (char '$' <> text (T.unpack a)) <+> char '=' <+> pretty b <+> showPPos p- pretty (NodeDeclaration (NodeDecl 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 (DependencyDeclaration (DepDecl (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 (ResourceCollectionDeclaration (ResCollDecl coltype restype search overrides p)) = capitalize restype <> enc (pretty search) <+> overs- where- overs | V.null overrides = showPPos p- | otherwise = nest 2 (char '{' <+> showPPos p <$> showAss overrides) <$> char '}'- enc = case coltype of- Collector -> enclose (text "<|") (text "|>")- ExportedCollector -> enclose (text "<<|") (text "|>>")--ppStatements :: V.Vector Statement -> Doc-ppStatements = vcat . map pretty . V.toList
− Puppet/Parser/Types.hs
@@ -1,401 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}--- | All the types used for parsing, and helpers working on these types.-module Puppet.Parser.Types- ( -- * Position management- Position,- PPosition,- initialPPos,- toPPos,- -- ** Lenses- lSourceName,- lSourceLine,- lSourceColumn,- -- * Helpers- capitalizeRT,- rel2text,- -- * Types- -- ** Expressions- Expression(..),- SelectorCase(..),- UnresolvedValue(..),- LambdaFunc(..),- HOLambdaCall(..),- ChainableRes(..),- HasHOLambdaCall(..),- LambdaParameter(..),- LambdaParameters(..),- CompRegex(..),- CollectorType(..),- Virtuality(..),- NodeDesc(..),- LinkType(..),- -- ** Datatypes- DataType(..),- -- ** Search Expressions- SearchExpression(..),- -- ** Statements- ArrowOp(..),- AttributeDecl(..),- ConditionalDecl(..),- ClassDecl(..),- ResDefaultDecl(..),- DepDecl(..),- Statement(..),- ResDecl(..),- ResOverrideDecl(..),- DefineDecl(..),- NodeDecl(..),- VarAssignDecl(..),- vadname,- vadpos,- vadvalue,- MainFuncDecl(..),- HigherOrderLambdaDecl(..),- ResCollDecl(..)- ) where--import Control.Lens-import Data.Aeson-import Data.Aeson.TH (deriveToJSON)-import Data.Char (toUpper)-import Data.Hashable-import qualified Data.Maybe.Strict as S-import Data.Scientific-import Data.String-import Data.Text (Text)-import qualified Data.Text as T-import Data.Tuple.Strict-import qualified Data.Vector as V-import Data.List.NonEmpty (NonEmpty)--import GHC.Exts-import GHC.Generics--import Text.Megaparsec.Pos-import Text.Regex.PCRE.String---- | Properly capitalizes resource types.-capitalizeRT :: Text -> Text-capitalizeRT = T.intercalate "::" . map capitalize' . T.splitOn "::"- where- capitalize' :: Text -> Text- capitalize' t | T.null t = T.empty- | otherwise = T.cons (toUpper (T.head t)) (T.tail t)---- | A pair containing the start and end of a given token.-type PPosition = Pair Position Position---- | Position in a puppet file. Currently an alias to 'SourcePos'.-type Position = SourcePos--lSourceName :: Lens' Position String-lSourceName = lens sourceName (\s n -> s { sourceName = n })--lSourceLine :: Lens' Position Pos-lSourceLine = lens sourceLine (\s l -> s { sourceLine = l })--lSourceColumn :: Lens' Position Pos-lSourceColumn = lens sourceColumn (\s c -> s { sourceColumn = c })---- | Generates an initial position based on a filename.-initialPPos :: Text -> PPosition-initialPPos x =- let i = initialPos (T.unpack x)- in (i :!: i)---- | Generates a 'PPosition' based on a filename and line number.-toPPos :: Text -> Int -> PPosition-toPPos fl ln =- let p = (initialPos (T.unpack fl)) { sourceLine = mkPos $ fromIntegral (max 1 ln) }- in (p :!: p)---- | /High Order lambdas/.-data LambdaFunc- = LambEach- | LambMap- | LambReduce- | LambFilter- | LambSlice- | LambLookup- deriving (Eq, Show)---- | Lambda block parameters:------ Currently only two types of block parameters are supported:--- single values and pairs.-data LambdaParameters- = BPSingle !LambdaParameter -- ^ @|k|@- | BPPair !LambdaParameter !LambdaParameter -- ^ @|k,v|@- deriving (Eq, Show)--data LambdaParameter- = LParam !(Maybe DataType) !Text- deriving (Eq, Show)---- The description of the /higher level lambda/ call.-data HOLambdaCall = HOLambdaCall- { _hoLambdaFunc :: !LambdaFunc- , _hoLambdaExpr :: !(S.Maybe Expression)- , _hoLambdaParams :: !LambdaParameters- , _hoLambdaStatements :: !(V.Vector Statement)- , _hoLambdaLastExpr :: !(S.Maybe Expression)- } deriving (Eq,Show)--data ChainableRes- = ChainResColl !ResCollDecl- | ChainResDecl !ResDecl- | ChainResRefr !Text [Expression] !PPosition- deriving (Show, Eq)--data AttributeDecl = AttributeDecl !Text !ArrowOp !Expression- deriving (Show, Eq)-data ArrowOp- = AppendArrow -- ^ `+>`- | AssignArrow -- ^ `=>`- deriving (Show, Eq)--data CompRegex = CompRegex !Text !Regex-instance Show CompRegex where- show (CompRegex t _) = show t-instance Eq CompRegex where- (CompRegex a _) == (CompRegex b _) = a == b-instance FromJSON CompRegex where- parseJSON = fail "Can't deserialize a regular expression"-instance ToJSON CompRegex where- toJSON (CompRegex t _) = toJSON t---- | An unresolved value, typically the parser's output.-data UnresolvedValue- = UBoolean !Bool -- ^ Special tokens generated when parsing the @true@ or @false@ literals.- | UString !Text -- ^ Raw string.- | 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 !Text !Expression -- ^ A Resource[reference]- | UArray !(V.Vector Expression)- | UHash !(V.Vector (Pair Expression Expression))- | URegexp !CompRegex -- ^ The regular expression compilation is performed during parsing.- | UVariableReference !Text- | UFunctionCall !Text !(V.Vector Expression)- | UHOLambdaCall !HOLambdaCall- | UNumber !Scientific- deriving (Show, Eq)--instance IsList UnresolvedValue where- type Item UnresolvedValue = Expression- fromList = UArray . V.fromList- toList u = case u of- UArray lst -> V.toList lst- _ -> [Terminal u]--instance IsString UnresolvedValue where- fromString = UString . T.pack--data SelectorCase- = SelectorValue !UnresolvedValue- | SelectorType !DataType- | SelectorDefault- deriving (Eq, Show)---- | The 'Expression's-data Expression- = Equal !Expression !Expression- | Different !Expression !Expression- | Not !Expression- | And !Expression !Expression- | Or !Expression !Expression- | LessThan !Expression !Expression- | MoreThan !Expression !Expression- | LessEqualThan !Expression !Expression- | MoreEqualThan !Expression !Expression- | RegexMatch !Expression !Expression- | NotRegexMatch !Expression !Expression- | Contains !Expression !Expression- | Addition !Expression !Expression- | Substraction !Expression !Expression- | Division !Expression !Expression- | Multiplication !Expression !Expression- | Modulo !Expression !Expression- | RightShift !Expression !Expression- | LeftShift !Expression !Expression- | Lookup !Expression !Expression- | Negate !Expression- | ConditionalValue !Expression !(V.Vector (Pair SelectorCase Expression)) -- ^ All conditionals are stored in this format.- | FunctionApplication !Expression !Expression -- ^ This is for /higher order functions/.- | Terminal !UnresolvedValue -- ^ Terminal object contains no expression- deriving (Eq, Show)--data DataType- = DTType- | DTString (Maybe Int) (Maybe Int)- | DTInteger (Maybe Int) (Maybe Int)- | DTFloat (Maybe Double) (Maybe Double)- | DTBoolean- | DTArray DataType Int (Maybe Int)- | DTHash DataType DataType Int (Maybe Int)- | DTUndef- | DTScalar- | DTData- | DTOptional DataType- | NotUndef- | DTVariant (NonEmpty DataType)- | DTPattern (NonEmpty CompRegex)- | DTEnum (NonEmpty Text)- | DTAny- | DTCollection- -- Tuple (NonEmpty DataType) Integer Integer- -- DTDefault- -- Struct TODO- deriving (Eq, Show)--instance IsList Expression where- type Item Expression = Expression- fromList = Terminal . fromList- toList u = case u of- Terminal t -> toList t- _ -> [u]--instance Num Expression where- (+) = Addition- (-) = Substraction- (*) = Multiplication- 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)])- ])--instance Fractional Expression where- (/) = Division- recip x = 1 / x- fromRational = Terminal . UNumber . fromRational--instance IsString Expression where- fromString = Terminal . fromString---- | Search expression inside collector `<| searchexpr |>`-data SearchExpression- = EqualitySearch !Text !Expression- | NonEqualitySearch !Text !Expression- | AndSearch !SearchExpression !SearchExpression- | OrSearch !SearchExpression !SearchExpression- | AlwaysTrue- deriving (Eq, Show)--data CollectorType- = Collector- | ExportedCollector- deriving (Eq, Show)--data Virtuality- = Normal -- ^ Normal resource, that will be included in the catalog.- | Virtual -- ^ Type for virtual resources.- | Exported -- ^ Type for exported resources.- | ExportedRealized -- ^ These are resources that are exported AND included in the catalogderiving (Generic, Eq, Show).- deriving (Eq, Show)--data NodeDesc- = NodeName !Text- | NodeMatch !CompRegex- | NodeDefault- deriving (Show, Eq)---- | Relationship link type.-data LinkType- = RNotify- | RRequire- | RBefore- | RSubscribe- deriving(Show, Eq,Generic)-instance Hashable LinkType--rel2text :: LinkType -> Text-rel2text RNotify = "notify"-rel2text RRequire = "require"-rel2text RBefore = "before"-rel2text RSubscribe = "subscribe"--instance FromJSON LinkType where- parseJSON (String "require") = return RRequire- parseJSON (String "notify") = return RNotify- parseJSON (String "subscribe") = return RSubscribe- parseJSON (String "before") = return RBefore- parseJSON _ = fail "invalid linktype"--instance ToJSON LinkType where- toJSON = String . rel2text---- | Resource declaration:------ @ file { mode => 755} @-data ResDecl = ResDecl !Text !Expression !(V.Vector AttributeDecl) !Virtuality !PPosition deriving (Eq, Show)---- | Resource default:------ @ File { mode => 755 } @------ <https://docs.puppetlabs.com/puppet/latest/reference/lang_defaults.html#language:-resource-default-statements puppet reference>.-data ResDefaultDecl = ResDefaultDecl !Text !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show)---- | Resource override:------ @ File['title'] { mode => 755} @------ See <https://docs.puppetlabs.com/puppet/latest/reference/lang_resources_advanced.html#amending-attributes-with-a-resource-reference puppet reference>.-data ResOverrideDecl = ResOverrideDecl !Text !Expression !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show)---- | All types of conditional statements : @case@, @if@, ...------ Stored as an ordered list of pair @ (condition, statements) @.--- Interpreted as "if first cond is true, choose first statements, else take the next pair, check the condition ..."-data ConditionalDecl = ConditionalDecl !(V.Vector (Pair Expression (V.Vector Statement))) !PPosition deriving (Eq, Show)--data ClassDecl = ClassDecl !Text !(V.Vector (Pair (Pair Text (S.Maybe DataType)) (S.Maybe Expression))) !(S.Maybe Text) !(V.Vector Statement) !PPosition deriving (Eq, Show)-data DefineDecl = DefineDecl !Text !(V.Vector (Pair (Pair Text (S.Maybe DataType)) (S.Maybe Expression))) !(V.Vector Statement) !PPosition deriving (Eq, Show)---- | A node is a collection of statements + maybe an inherit node.-data NodeDecl = NodeDecl !NodeDesc !(V.Vector Statement) !(S.Maybe NodeDesc) !PPosition deriving (Eq, Show)---- | @ $newvar = 'world' @-data VarAssignDecl- = VarAssignDecl- { _vadname :: !Text- , _vadvalue :: !Expression- , _vadpos :: !PPosition- } deriving (Eq, Show)--data MainFuncDecl = MainFuncDecl !Text !(V.Vector Expression) !PPosition deriving (Eq, Show)---- | /Higher order function/ call.-data HigherOrderLambdaDecl = HigherOrderLambdaDecl !HOLambdaCall !PPosition deriving (Eq, Show)---- | Resource Collector including exported collector (`\<\<| |>>`)------ @ User \<| title == 'jenkins' |> { groups +> "docker"} @------ See <https://docs.puppetlabs.com/puppet/latest/reference/lang_collectors.html#language:-resource-collectors puppet reference>-data ResCollDecl = ResCollDecl !CollectorType !Text !SearchExpression !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show)--data DepDecl = DepDecl !(Pair Text Expression) !(Pair Text Expression) !LinkType !PPosition deriving (Eq, Show)---- | All possible statements.-data Statement- = ResourceDeclaration !ResDecl- | ResourceDefaultDeclaration !ResDefaultDecl- | ResourceOverrideDeclaration !ResOverrideDecl- | ResourceCollectionDeclaration !ResCollDecl- | ClassDeclaration !ClassDecl- | DefineDeclaration !DefineDecl- | NodeDeclaration !NodeDecl- | ConditionalDeclaration !ConditionalDecl- | VarAssignmentDeclaration !VarAssignDecl- | MainFunctionDeclaration !MainFuncDecl- | HigherOrderLambdaDeclaration !HigherOrderLambdaDecl- | DependencyDeclaration !DepDecl- | TopContainer !(V.Vector Statement) !Statement -- ^ Special statement used to include the expressions that are top level. Certainly buggy, but probably just like the original implementation.- deriving (Eq, Show)--makeClassy ''HOLambdaCall-makeLenses ''VarAssignDecl-$(deriveToJSON defaultOptions ''DataType)
− Puppet/Parser/Utils.hs
@@ -1,12 +0,0 @@-module Puppet.Parser.Utils where--import Text.Megaparsec.Pos--import Puppet.Parser.Types---dummyppos :: PPosition-dummyppos = initialPPos "dummy"--dummypos :: Position-dummypos = initialPos "dummy"
− Puppet/Paths.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Puppet.Paths where--import Control.Lens-import Data.Monoid--data PuppetDirPaths = PuppetDirPaths- { _baseDir :: FilePath -- ^ Puppet base working directory- , _manifestPath :: FilePath -- ^ The path to the manifests.- , _modulesPath :: FilePath -- ^ The path to the modules.- , _templatesPath :: FilePath -- ^ The path to the template.- , _testPath :: FilePath -- ^ The path to a tests folders to hold tests files such as the pdbfiles.- }--makeClassy ''PuppetDirPaths--puppetPaths :: FilePath -> PuppetDirPaths-puppetPaths basedir = PuppetDirPaths basedir manifestdir modulesdir templatedir testdir- where- manifestdir = basedir <> "/manifests"- modulesdir = basedir <> "/modules"- templatedir = basedir <> "/templates"- testdir = basedir <> "/tests"
− Puppet/Preferences.hs
@@ -1,147 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-module Puppet.Preferences (- dfPreferences- , HasPreferences(..)- , Preferences(Preferences)- , PuppetDirPaths- , HasPuppetDirPaths(..)-) where--import Control.Lens-import Control.Monad (mzero)-import Data.Aeson-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import Data.Maybe (fromMaybe)-import Data.Text (Text)-import qualified Data.Text as T-import System.Posix (fileExist)-import qualified System.Log.Logger as LOG--import Puppet.Interpreter.Types-import Puppet.NativeTypes-import Puppet.NativeTypes.Helpers-import Puppet.Stdlib-import Puppet.Paths-import qualified Puppet.Puppetlabs as Puppetlabs-import Puppet.Utils-import PuppetDB.Dummy--data Preferences m = Preferences- { _prefPuppetPaths :: PuppetDirPaths- , _prefPDB :: PuppetDBAPI m- , _prefNatTypes :: Container NativeTypeMethods -- ^ The list of native types.- , _prefExtFuncs :: Container ( [PValue] -> InterpreterMonad PValue )- , _prefHieraPath :: Maybe FilePath- , _prefIgnoredmodules :: HS.HashSet Text- , _prefStrictness :: Strictness- , _prefExtraTests :: Bool- , _prefKnownusers :: [Text]- , _prefKnowngroups :: [Text]- , _prefExternalmodules :: HS.HashSet Text- , _prefPuppetSettings :: Container Text- , _prefFactsOverride :: Container PValue- , _prefFactsDefault :: Container PValue- , _prefLogLevel :: LOG.Priority- }--data Defaults = Defaults- { _dfKnownusers :: Maybe [Text]- , _dfKnowngroups :: Maybe [Text]- , _dfIgnoredmodules :: Maybe [Text]- , _dfStrictness :: Maybe Strictness- , _dfExtratests :: Maybe Bool- , _dfExternalmodules :: Maybe [Text]- , _dfPuppetSettings :: Maybe (Container Text)- , _dfFactsDefault :: Maybe (Container PValue)- , _dfFactsOverride :: Maybe (Container PValue)- } deriving Show---makeClassy ''Preferences--instance FromJSON Defaults where- parseJSON (Object v) = Defaults- <$> v .:? "knownusers"- <*> v .:? "knowngroups"- <*> v .:? "ignoredmodules"- <*> v .:? "strict"- <*> v .:? "extratests"- <*> v .:? "externalmodules"- <*> v .:? "settings"- <*> v .:? "factsdefault"- <*> v .:? "factsoverride"- parseJSON _ = mzero---- | generate default preferences-dfPreferences :: FilePath- -> IO (Preferences IO)-dfPreferences basedir = do- let dirpaths = puppetPaths basedir- modulesdir = dirpaths ^. modulesPath- testdir = dirpaths ^. testPath- typenames <- fmap (map takeBaseName) (getFiles (T.pack modulesdir) "lib/puppet/type" ".rb")- defaults <- loadDefaults (testdir ++ "/defaults.yaml")- labsFunctions <- Puppetlabs.extFunctions modulesdir- let loadedTypes = HM.fromList (map defaulttype typenames)- return $ Preferences dirpaths- dummyPuppetDB- (baseNativeTypes `HM.union` loadedTypes)- (HM.union stdlibFunctions labsFunctions)- (Just (basedir <> "/hiera.yaml"))- (getIgnoredmodules defaults)- (getStrictness defaults)- (getExtraTests defaults)- (getKnownusers defaults)- (getKnowngroups defaults)- (getExternalmodules defaults)- (getPuppetSettings dirpaths defaults)- (getFactsOverride defaults)- (getFactsDefault defaults)- LOG.NOTICE -- good default as INFO is quite noisy--loadDefaults :: FilePath -> IO (Maybe Defaults)-loadDefaults fp = do- p <- fileExist fp- if p then loadYamlFile fp else return Nothing---- Utilities for getting default values from the yaml file--- It provides (the same) static defaults (see the 'Nothing' case) when--- no default yaml file or--- not key/value for the option has been provided-getKnownusers :: Maybe Defaults -> [Text]-getKnownusers = fromMaybe ["mysql", "vagrant","nginx", "nagios", "postgres", "puppet", "root", "syslog", "www-data"] . (>>= _dfKnownusers)--getKnowngroups :: Maybe Defaults -> [Text]-getKnowngroups = fromMaybe ["adm", "syslog", "mysql", "nagios","postgres", "puppet", "root", "www-data", "postfix"] . (>>= _dfKnowngroups)--getStrictness :: Maybe Defaults -> Strictness-getStrictness = fromMaybe Permissive . (>>= _dfStrictness)--getIgnoredmodules :: Maybe Defaults -> HS.HashSet Text-getIgnoredmodules = maybe mempty HS.fromList . (>>= _dfIgnoredmodules)--getExtraTests :: Maybe Defaults -> Bool-getExtraTests = fromMaybe True . (>>= _dfExtratests)--getExternalmodules :: Maybe Defaults -> HS.HashSet Text-getExternalmodules = maybe mempty HS.fromList . (>>= _dfExternalmodules)--getPuppetSettings :: PuppetDirPaths -> Maybe Defaults -> Container Text-getPuppetSettings dirpaths = fromMaybe df . (>>= _dfPuppetSettings)- where- df :: Container Text- df = HM.fromList [ ("confdir", T.pack $ dirpaths^.baseDir)- , ("strict_variables", "true")- ]--getFactsOverride :: Maybe Defaults -> Container PValue-getFactsOverride = fromMaybe mempty . (>>= _dfFactsOverride)--getFactsDefault :: Maybe Defaults -> Container PValue-getFactsDefault = fromMaybe mempty . (>>= _dfFactsDefault)
− Puppet/Puppetlabs.hs
@@ -1,125 +0,0 @@--- | Contains an Haskell implementation (or mock implementation) of some ruby functions found in puppetlabs modules-module Puppet.Puppetlabs (extFunctions) where--import Control.Lens-import Crypto.Hash as Crypto-import Data.ByteString (ByteString)-import Data.Foldable (foldlM)-import qualified Data.HashMap.Strict as HM-import Data.Monoid-import Data.Scientific as Sci-import Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-import Data.Vector (Vector)-import Formatting (scifmt, sformat, (%), (%.))-import qualified Formatting as FMT-import System.Posix.Files (fileExist)-import System.Random (mkStdGen, randomRs)--import Puppet.Interpreter.PrettyPrinter ()-import Puppet.Interpreter.Types-import Puppet.PP--md5 :: Text -> Text-md5 = Text.pack . show . (Crypto.hash :: ByteString -> Digest MD5) . Text.encodeUtf8--extFun :: [(FilePath, Text, [PValue] -> InterpreterMonad PValue)]-extFun = [ ("/apache", "bool2httpd", apacheBool2httpd)- , ("/docker", "docker_run_flags", mockDockerRunFlags)- , ("/jenkins", "jenkins_port", mockJenkinsPort)- , ("/jenkins", "jenkins_prefix", mockJenkinsPrefix)- , ("/postgresql", "postgresql_acls_to_resources_hash", pgAclsToHash)- , ("/postgresql", "postgresql_password", pgPassword)- , ("/extlib", "random_password", randomPassword)- , ("/extlib", "cache_data", mockCacheData)- ]---- | Build the map of available ext functions--- If the ruby file is not found on the local filesystem the record is ignored. This is to avoid potential namespace conflict-extFunctions :: FilePath -> IO (Container ( [PValue] -> InterpreterMonad PValue))-extFunctions modpath = foldlM f HM.empty extFun- where- f acc (modname, fname, fn) = do- test <- testFile modname fname- if test- then return $ HM.insert fname fn acc- else return acc- testFile modname fname = fileExist (modpath <> modname <> "/lib/puppet/parser/functions/" <> Text.unpack fname <>".rb")--apacheBool2httpd :: MonadThrowPos m => [PValue] -> m PValue-apacheBool2httpd [PBoolean True] = return $ PString "On"-apacheBool2httpd [PString "true"] = return $ PString "On"-apacheBool2httpd [_] = return $ PString "Off"-apacheBool2httpd arg@_ = throwPosError $ "expect one single argument" <+> pretty arg--pgPassword :: MonadThrowPos m => [PValue] -> m PValue-pgPassword [PString username, PString pwd] =- return $ PString $ "md5" <> md5 (pwd <> username)-pgPassword _ = throwPosError "expects 2 string arguments"---- | The function is pure and always return the same "random" password-randomPassword :: MonadThrowPos m => [PValue] -> m PValue-randomPassword [PNumber s] =- PString . Text.pack . randomChars <$> scientificToInt s- where- randomChars n = take n $ randomRs ('a', 'z') (mkStdGen 1)--randomPassword _ = throwPosError "expect one single string arguments"----- | To be implemented if needed-mockJenkinsPrefix :: MonadThrowPos m => [PValue] -> m PValue-mockJenkinsPrefix [] = return $ PString ""-mockJenkinsPrefix arg@_ = throwPosError $ "expect no argument" <+> pretty arg---- | To be implemented if needed-mockJenkinsPort :: MonadThrowPos m => [PValue] -> m PValue-mockJenkinsPort [] = return $ PString "8080"-mockJenkinsPort arg@_ = throwPosError $ "expect no argument" <+> pretty arg--mockCacheData :: MonadThrowPos m => [PValue] -> m PValue-mockCacheData [_, _, b] = return b-mockCacheData arg@_ = throwPosError $ "expect 3 string arguments" <+> pretty arg---- | Simple implemenation that does not handle all cases.--- For instance 'auth_option' is currently not implemented.--- Please add cases as needed.-pgAclsToHash :: MonadThrowPos m => [PValue] -> m PValue-pgAclsToHash [PArray as, PString ident, PNumber offset] = do- x <- aclsToHash as ident offset- return $ PHash x-pgAclsToHash _ = throwPosError "expects 3 arguments; one array one string and one number"--aclsToHash :: MonadThrowPos m => Vector PValue -> Text -> Scientific -> m (Container PValue)-aclsToHash vec ident offset = ifoldlM f HM.empty vec- where- f :: MonadThrowPos m => Int -> Container PValue -> PValue -> m (Container PValue)- f idx acc (PString acl) = do- let order = offset + scientific (toInteger idx) 0- keymsg = sformat ("postgresql class generated rule " % FMT.stext % " " % FMT.int) ident idx- x <- aclToHash (Text.words acl) order- return $ HM.insert keymsg x acc- f _ _ pval = throwPosError $ "expect a string as acl but get" <+> pretty pval--aclToHash :: (MonadThrowPos m) => [Text] -> Scientific -> m PValue-aclToHash [typ, db, usr, addr, auth] order =- return $ PHash $ HM.fromList [ ("type", PString typ)- , ("database", PString db )- , ("user", PString usr)- , ("order", PString (sformat (FMT.left 3 '0' %. scifmt Sci.Fixed (Just 0)) order))- , ("address", PString addr)- , ("auth_method", PString auth)- ]-aclToHash acl _ = throwPosError $ "Unable to parse acl line" <+> squotes (ttext (Text.unwords acl))---- faked implementation, replace by the correct one if you need so.-mockDockerRunFlags :: MonadThrowPos m => [PValue] -> m PValue-mockDockerRunFlags arg@[PHash _]= (return . PString . Text.pack . displayNocolor . pretty . head) arg-mockDockerRunFlags arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg---- utils-scientificToInt :: MonadThrowPos m => Scientific -> m Int-scientificToInt s = maybe (throwPosError $ "Unable to convert" <+> string (show s) <+> "into an int.")- return- (Sci.toBoundedInteger s)
− Puppet/Stats.hs
@@ -1,64 +0,0 @@-{-| A quickly done module that exports utility functions used to collect various-statistics. All statistics are stored in a MVar holding a HashMap.--This is not accurate in the presence of lazy evaluation. Nothing is forced.--}-module Puppet.Stats (measure, newStats, getStats, StatsTable, StatsPoint(..), MStats) where--import Data.Time.Clock.POSIX (getPOSIXTime)-import Control.Concurrent-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import Control.Lens--data StatsPoint = StatsPoint { _statspointCount :: !Int -- ^ Total number of calls to a computation- , _statspointTotal :: !Double -- ^ Total time spent during this computation- , _statspointMin :: !Double -- ^ Minimum execution time- , _statspointMax :: !Double -- ^ Maximum execution time- } deriving(Show)---- | A table where keys are the names of the computations, and values are--- 'StatsPoint's.-type StatsTable = HM.HashMap T.Text StatsPoint--newtype MStats = MStats { unMStats :: MVar StatsTable }--- | Returns the actual statistical values.-getStats :: MStats -> IO StatsTable-getStats = readMVar . unMStats---- | Create a new statistical container.-newStats :: IO MStats-newStats = MStats `fmap` newMVar HM.empty---- | Wraps a computation, and measures related execution statistics.-measure :: MStats -- ^ Statistics container- -> T.Text -- ^ Action identifier- -> IO a -- ^ Computation- -> IO a-measure (MStats mtable) statsname action = do- (!tm, !out) <- time action- !stats <- takeMVar mtable- let nstats :: StatsTable- !nstats = case stats ^. at statsname of- Nothing -> stats & at statsname ?~ StatsPoint 1 tm tm tm- Just (StatsPoint sc st smi sma) ->- let !nmax = if tm > sma- then tm- else sma- !nmin = if tm < smi- then tm- else smi- in stats & at statsname ?~ StatsPoint (sc+1) (st+tm) nmin nmax- putMVar mtable nstats- return $! out--getTime :: IO Double-getTime = realToFrac `fmap` getPOSIXTime--time :: IO a -> IO (Double, a)-time action = do- start <- getTime- !result <- action- end <- getTime- let !delta = end - start- return (delta, result)
− Puppet/Stdlib.hs
@@ -1,499 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE PatternGuards #-}-module Puppet.Stdlib (stdlibFunctions) where--import Control.Applicative-import Control.Lens-import Control.Monad-import Data.Aeson.Lens-import qualified Data.ByteString.Base16 as B16-import Data.Char-import qualified Data.HashMap.Strict as HM-import qualified Data.List as List-import Data.List.Split (chunksOf)-import Data.Maybe (mapMaybe)-import Data.Monoid-import qualified Data.Scientific as Scientific-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Traversable (for)-import qualified Data.Vector as V-import Data.Vector.Lens (toVectorOf)-import qualified Text.PrettyPrint.ANSI.Leijen as PP-import Text.Regex.PCRE.ByteString.Utils--import Puppet.Interpreter.Resolve-import Puppet.Interpreter.Types-import Puppet.Interpreter.Utils-import Puppet.PP-import Puppet.Utils (text2Scientific)---- | Contains the implementation of the StdLib functions.-stdlibFunctions :: Container ( [PValue] -> InterpreterMonad PValue )-stdlibFunctions = HM.fromList [ singleArgument "abs" puppetAbs- , ("any2array", any2array)- , ("assert_private", assertPrivate)- , ("base64", base64)- -- basename- , singleArgument "bool2num" bool2num- -- bool2str- -- camelcase- , ("capitalize", stringArrayFunction (safeEmptyString (\t -> T.cons (toUpper (T.head t)) (T.tail t))))- -- ceiling- , ("chomp", stringArrayFunction (T.dropWhileEnd (\c -> c == '\n' || c == '\r')))- , ("chop", stringArrayFunction (safeEmptyString T.init))- -- clamp- , ("concat", puppetConcat)- -- convert_base- , ("count", puppetCount)- -- deep_merge- , ("defined_with_params", const (throwPosError "defined_with_params can't be implemented with language-puppet"))- , ("delete", delete)- , ("delete_at", deleteAt)- , singleArgument "delete_undef_values" deleteUndefValues- -- delete_values- -- difference- -- dirname- -- dos2unix- , ("downcase", stringArrayFunction T.toLower)- , singleArgument "empty" _empty- -- ensure_packages (in main interpreter module)- -- ensure_resource (in main interpreter module)- , singleArgument "flatten" flatten- -- floor- -- fqdn_rand_string- -- fqdn_rotate- -- get_module_path- , ("getparam", const $ throwPosError "The getparam function is uncool and shall not be implemented in language-puppet")- , singleArgument "getvar" getvar- , ("grep", _grep)- , ("hash", hash)- -- has_interface_with- -- has_ip_address- -- has_ip_network- , ("has_key", hasKey)- -- intersection- -- is_absolute_path- , singleArgument "is_array" isArray- , singleArgument "is_bool" isBool- , singleArgument "is_domain_name" isDomainName- -- is_float- -- is_function_available- , singleArgument "is_hash" isHash- , singleArgument "is_integer" isInteger- -- is_ip_address- -- is_mac_address- -- is_numeric- , singleArgument "is_string" isString- , ("join", puppetJoin)- , ("join_keys_to_values", joinKeysToValues)- , singleArgument "keys" keys- -- load_module_metadata- -- loadyaml- , ("lstrip", stringArrayFunction T.stripStart)- -- max- , ("member", member)- , ("merge", merge)- -- min- -- num2bool- -- parsejson- -- parseyaml- , ("pick", pick)- , ("pick_default", pickDefault)- -- prefix- -- private- -- pw_hash- -- range- -- reject- -- reverse- , ("rstrip", stringArrayFunction T.stripEnd)- -- seeded_rand- -- shuffle- , singleArgument "size" size- , singleArgument "sort" sort- -- squeeze- , singleArgument "str2bool" str2Bool- -- strtosaltedshar512- -- strftime- , ("strip", stringArrayFunction T.strip)- -- suffix- -- swapcase- -- time- -- to_bytes- -- try_get_value- -- type3x- -- type- -- union- -- unique- -- unix2dos- , ("upcase", stringArrayFunction T.toUpper)- -- uriescape- , ("validate_absolute_path", validateAbsolutePath)- , ("validate_array", validateArray)- -- validate_augeas- , ("validate_bool", validateBool)- -- validate_cmd- , ("validate_hash", validateHash)- , ("validate_integer", validateInteger)- -- validate_ip_address- -- validate_ipv4_address- -- validate_ipv6_address- , ("validate_numeric", validateNumeric)- , ("validate_re", validateRe)- -- validate_slength- , ("validate_string", validateString)- -- validate_x509_rsa_key_pair- -- values_at- , singleArgument "values" pvalues- -- zip- ]--singleArgument :: T.Text -> (PValue -> InterpreterMonad PValue) -> (T.Text, [PValue] -> InterpreterMonad PValue )-singleArgument fname ifunc = (fname, ofunc)- where- ofunc [x] = ifunc x- ofunc _ = throwPosError (ttext fname <> "(): Expects a single argument.")--safeEmptyString :: (T.Text -> T.Text) -> T.Text -> T.Text-safeEmptyString _ "" = ""-safeEmptyString f x = f x--stringArrayFunction :: (T.Text -> T.Text) -> [PValue] -> InterpreterMonad PValue-stringArrayFunction f [PString s] = return (PString (f s))-stringArrayFunction f [PArray xs] = fmap PArray (V.mapM (fmap (PString . f) . resolvePValueString) xs)-stringArrayFunction _ [a] = throwPosError ("function expects a string or an array of strings, not" <+> pretty a)-stringArrayFunction _ _ = throwPosError "function expects a single argument"--compileRE :: T.Text -> InterpreterMonad Regex-compileRE r = case compile' compBlank execBlank (T.encodeUtf8 r) of- Left rr -> throwPosError ("Could not compile" <+> ttext r <+> ":" <+> string (show rr))- Right x -> return x--matchRE :: Regex -> T.Text -> InterpreterMonad Bool-matchRE r t = case execute' r (T.encodeUtf8 t) of- Left rr -> throwPosError ("Could not match:" <+> string (show rr))- Right m -> return (has _Just m)--puppetAbs :: PValue -> InterpreterMonad PValue-puppetAbs y = case y ^? _Number of- Just x -> return $ _Number # abs x- Nothing -> throwPosError ("abs(): Expects a number, not" <+> pretty y)--assertPrivate :: [PValue] -> InterpreterMonad PValue-assertPrivate args = case args of- [] -> go Nothing- [t] -> resolvePValueString t >>= go . Just- _ -> throwPosError "assert_private: expects no or a single string argument"- where- go msg = do- scp <- use curScope- case scp of- funScope : callerScope : _ ->- let takeModule = T.takeWhile (/= ':') . moduleName- in if takeModule funScope == takeModule callerScope- then return PUndef- else throwPosError $ maybe ("assert_private: failed: " <> pretty funScope <> " is private") ttext msg- _ -> return PUndef--any2array :: [PValue] -> InterpreterMonad PValue-any2array [PArray v] = return (PArray v)-any2array [PHash h] = return (PArray lst)- where lst = V.fromList $ concatMap arraypair $ HM.toList h- arraypair (a,b) = [PString a, b]-any2array [x] = return (PArray (V.singleton x))-any2array x = return (PArray (V.fromList x))--base64 :: [PValue] -> InterpreterMonad PValue-base64 [pa,pb] = do- b <- fmap T.encodeUtf8 (resolvePValueString pb)- r <- resolvePValueString pa >>= \case- "encode" -> return (B16.encode b)- "decode" -> case B16.decode b of- (x, "") -> return x- _ -> throwPosError ("base64(): could not decode" <+> pretty pb)- a -> throwPosError ("base64(): the first argument must be either 'encode' or 'decode', not" <+> ttext a)- fmap PString (safeDecodeUtf8 r)-base64 _ = throwPosError "base64(): Expects 2 arguments"--bool2num :: PValue -> InterpreterMonad PValue-bool2num (PString "") = return (PBoolean False)-bool2num (PString "1") = return (PBoolean True)-bool2num (PString "t") = return (PBoolean True)-bool2num (PString "y") = return (PBoolean True)-bool2num (PString "true") = return (PBoolean True)-bool2num (PString "yes") = return (PBoolean True)-bool2num (PString "0") = return (PBoolean False)-bool2num (PString "f") = return (PBoolean False)-bool2num (PString "n") = return (PBoolean False)-bool2num (PString "false") = return (PBoolean False)-bool2num (PString "no") = return (PBoolean False)-bool2num (PString "undef") = return (PBoolean False)-bool2num (PString "undefined") = return (PBoolean False)-bool2num x@(PBoolean _) = return x-bool2num x = throwPosError ("bool2num(): Can't convert" <+> pretty x <+> "to boolean")--puppetConcat :: [PValue] -> InterpreterMonad PValue-puppetConcat = return . PArray . V.concat . map toArr- where- toArr (PArray x) = x- toArr x = V.singleton x--puppetCount :: [PValue] -> InterpreterMonad PValue-puppetCount [PArray x] = return (_Integer # V.foldl' cnt 0 x)- where- cnt cur (PString "") = cur- cnt cur PUndef = cur- cnt cur _ = cur + 1-puppetCount [PArray x, y] = return (_Integer # V.foldl' cnt 0 x)- where- cnt cur z | y == z = cur + 1- | otherwise = cur-puppetCount _ = throwPosError "count(): expects 1 or 2 arguments"--delete :: [PValue] -> InterpreterMonad PValue-delete [PString x, y] = fmap (PString . T.concat . (`T.splitOn` x)) (resolvePValueString y)-delete [PArray r, z] = return $ PArray $ V.filter (/= z) r-delete [PHash h, z] = do- tz <- resolvePValueString z- return $ PHash (h & at tz .~ Nothing)-delete [a,_] = throwPosError ("delete(): First argument must be an Array, String, or Hash. Given:" <+> pretty a)-delete _ = throwPosError "delete(): expects 2 arguments"--deleteAt :: [PValue] -> InterpreterMonad PValue-deleteAt [PArray r, z] = case z ^? _Integer of- Just gn ->- let n = fromInteger gn- lr = V.length r- s1 = V.slice 0 n r- s2 = V.slice (n+1) (lr - n - 1) r- in if V.length r <= n- then throwPosError ("delete_at(): Out of bounds access detected, tried to remove index" <+> pretty z <+> "wheras the array only has" <+> string (show lr) <+> "elements")- else return (PArray (s1 <> s2))- _ -> throwPosError ("delete_at(): The second argument must be an integer, not" <+> pretty z)-deleteAt [x,_] = throwPosError ("delete_at(): expects its first argument to be an array, not" <+> pretty x)-deleteAt _ = throwPosError "delete_at(): expects 2 arguments"--deleteUndefValues :: PValue -> InterpreterMonad PValue-deleteUndefValues (PArray r) = return $ PArray $ V.filter (/= PUndef) r-deleteUndefValues (PHash h) = return $ PHash $ HM.filter (/= PUndef) h-deleteUndefValues x = throwPosError ("delete_undef_values(): Expects an Array or a Hash, not" <+> pretty x)--_empty :: PValue -> InterpreterMonad PValue-_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)- where- flatten' :: PValue -> V.Vector PValue- flatten' (PArray x) = V.concatMap flatten' x- flatten' x = V.singleton x-flatten x = throwPosError ("flatten(): Expects an Array, not" <+> pretty x)--getvar :: PValue -> InterpreterMonad PValue-getvar = resolvePValueString >=> resolveVariable--_grep :: [PValue] -> InterpreterMonad PValue-_grep [PArray vls, rawre] = do- regexp <- resolvePValueString rawre >>= compileRE- rvls <- for vls $ \v -> do- r <- resolvePValueString v- ismatched <- matchRE regexp r- return (r, ismatched)- return $ PArray $ V.map (PString . fst) (V.filter snd rvls)-_grep [x,_] = throwPosError ("grep(): The first argument must be an Array, not" <+> pretty x)-_grep _ = throwPosError "grep(): Expected two arguments."--hash :: [PValue] -> InterpreterMonad PValue-hash [PArray elems] = do- let xs = mapMaybe assocPairs $ chunksOf 2 $ V.toList elems- assocPairs [a,b] = Just (a,b)- assocPairs _ = Nothing- PHash . HM.fromList <$> mapM (\(k,v) -> (,v) <$> resolvePValueString k) xs-hash _ = throwPosError "hash(): Expected and array."--isArray :: PValue -> InterpreterMonad PValue-isArray = return . PBoolean . has _PArray--isDomainName :: PValue -> InterpreterMonad PValue-isDomainName s = do- rs <- resolvePValueString s- let ndrs = if T.last rs == '.'- then T.init rs- else rs- prts = T.splitOn "." ndrs- checkPart x = not (T.null x)- && (T.length x <= 63)- && (T.head x /= '-')- && (T.last x /= '-')- && T.all (\y -> isAlphaNum y || y == '-') x- return $ PBoolean $ not (T.null rs) && T.length rs <= 255 && all checkPart prts--isInteger :: PValue -> InterpreterMonad PValue-isInteger = return . PBoolean . has _Integer--isHash :: PValue -> InterpreterMonad PValue-isHash = return . PBoolean . has _PHash--isString :: PValue -> InterpreterMonad PValue-isString pv = return $ PBoolean $ case (pv ^? _PString, pv ^? _Number) of- (_, Just _) -> False- (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"--joinKeysToValues :: [PValue] -> InterpreterMonad PValue-joinKeysToValues [PHash h, separator] = do- ssep <- resolvePValueString separator- fmap (PArray . V.fromList) $ forM (itoList h) $ \(k,v) -> do- sv <- case v of- PUndef -> return ""- _ -> resolvePValueString v- return (PString (k <> ssep <> sv))-joinKeysToValues _ = throwPosError "join_keys_to_values(): expects 2 arguments, an hash and a string"--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)--member :: [PValue] -> InterpreterMonad PValue-member [PArray v, x] = return $ PBoolean (x `V.elem` v)-member _ = throwPosError "member() expects 2 arguments"--hasKey :: [PValue] -> InterpreterMonad PValue-hasKey [PHash h, k] = do- 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."--merge :: [PValue] -> InterpreterMonad PValue-merge xs | length xs < 2 = throwPosError "merge(): Expects at least two hashes"- | otherwise = let hashcontents = mapM (preview _PHash) xs- in case hashcontents of- Nothing -> throwPosError "merge(): Expects hashes"- Just hashes -> return $ PHash (getDual $ foldMap Dual hashes)--pick :: [PValue] -> InterpreterMonad PValue-pick [] = throwPosError "pick(): must receive at least one non empty value"-pick xs = case filter (`notElem` [PUndef, PString "", PString "undef"]) xs of- [] -> throwPosError "pick(): no value suitable to be picked"- (x:_) -> return x--pickDefault :: [PValue] -> InterpreterMonad PValue-pickDefault [] = throwPosError "pick_default(): must receive at least one non empty value"-pickDefault xs = case filter (`notElem` [PUndef, PString "", PString "undef"]) xs of- [] -> return (last xs)- (x:_) -> return x--size :: PValue -> InterpreterMonad PValue-size (PHash h) = return (_Integer # fromIntegral (HM.size h))-size (PArray v) = return (_Integer # fromIntegral (V.length v))-size (PString s) = return (_Integer # fromIntegral (T.length s))-size x = throwPosError ("size(): Expects a hash, and array or a string, not" <+> pretty x)--sort :: PValue -> InterpreterMonad PValue-sort (PArray s) =- let lst = V.toList s- msort :: Ord a => Prism' PValue a -> Maybe PValue- msort prsm = PArray . V.fromList . map (review prsm) . List.sort <$> mapM (preview prsm) lst- in case (msort _PString <|> msort _PNumber) of- Just x -> return x- _ -> throwPosError "sort(): only homogeneous arrays of numbers or strings are allowed"-sort x = throwPosError ("sort(): Expect to sort an array, not" <+> pretty x)--str2Bool :: PValue -> InterpreterMonad PValue-str2Bool PUndef = return (PBoolean False)-str2Bool a@(PBoolean _) = return a-str2Bool a = do- s <- resolvePValueString a- let b | s `elem` ["", "1", "t", "y", "true", "yes"] = Just True- | s `elem` [ "0", "f", "n", "false", "no"] = Just False- | otherwise = Nothing- case b of- Just x -> return (PBoolean x)- Nothing -> throwPosError "str2bool(): Unknown type of boolean given"--validateAbsolutePath :: [PValue] -> InterpreterMonad PValue-validateAbsolutePath [] = throwPosError "validateAbsolutePath(): wrong number of arguments, must be > 0"-validateAbsolutePath a = mapM_ (resolvePValueString >=> validate) a >> return PUndef- where- validate x | T.head x == '/' = return ()- | otherwise = throwPosError (ttext x <+> "is not an absolute path")--validateArray :: [PValue] -> InterpreterMonad PValue-validateArray [] = throwPosError "validate_array(): wrong number of arguments, must be > 0"-validateArray x = mapM_ vb x >> return PUndef- where- vb (PArray _) = return ()- vb y = throwPosError (pretty y <+> "is not an array.")--validateBool :: [PValue] -> InterpreterMonad PValue-validateBool [] = throwPosError "validate_bool(): wrong number of arguments, must be > 0"-validateBool x = mapM_ vb x >> return PUndef- where- vb (PBoolean _) = return ()- vb y = throwPosError (pretty y <+> "is not a boolean.")--validateHash :: [PValue] -> InterpreterMonad PValue-validateHash [] = throwPosError "validate_hash(): wrong number of arguments, must be > 0"-validateHash x = mapM_ vb x >> return PUndef- where- vb (PHash _) = return ()- vb y = throwPosError (pretty y <+> "is not a hash.")--validateNumeric :: [PValue] -> InterpreterMonad PValue-validateNumeric [] = throwPosError "validate_numeric: invalid arguments"-validateNumeric (arr:extra) = do- (mn, mx) <- case extra of- [mx'] -> (Nothing,) . Just <$> resolvePValueNumber mx'- [PUndef, mi'] -> (,Nothing) . Just <$> resolvePValueNumber mi'- [mx',mi'] -> (,) <$> (Just <$> resolvePValueNumber mi') <*> (Just <$> resolvePValueNumber mx')- [] -> pure (Nothing, Nothing)- _ -> throwPosError "validate_numeric: invalid arguments"- numbers <- case arr of- PArray lst -> mapM resolvePValueNumber (V.toList lst)- _ -> pure <$> resolvePValueNumber arr- forM_ mn $ \mn' -> unless (all (>= mn') numbers) $ throwPosError "validate_numeric: failure"- forM_ mx $ \mx' -> unless (all (<= mx') numbers) $ throwPosError "validate_numeric: failure"- return PUndef--validateRe :: [PValue] -> InterpreterMonad PValue-validateRe [str, reg] = validateRe [str, reg, PString "Match failed"]-validateRe [str, PString reg, msg] = validateRe [str, PArray (V.singleton (PString reg)), msg]-validateRe [str, PArray v, msg] = do- rstr <- resolvePValueString str- rest <- mapM (resolvePValueString >=> compileRE >=> flip matchRE rstr) (V.toList v)- if or rest- then return PUndef- else throwPosError (pretty msg PP.<$> "Source string:" <+> pretty str <> comma <+> "regexps:" <+> pretty (V.toList v))-validateRe [_, r, _] = throwPosError ("validate_re(): expected a regexp or an array of regexps, but not" <+> pretty r)-validateRe _ = throwPosError "validate_re(): wrong number of arguments (#{args.length}; must be 2 or 3)"--validateString :: [PValue] -> InterpreterMonad PValue-validateString [] = throwPosError "validate_string(): wrong number of arguments, must be > 0"-validateString x = mapM_ resolvePValueString x >> return PUndef--validateInteger :: [PValue] -> InterpreterMonad PValue-validateInteger [] = throwPosError "validate_integer(): wrong number of arguments, must be > 0"-validateInteger x = PUndef <$ mapM_ vb x- where- msg d = pretty d <+> "is not an integer."- check n = unless (Scientific.isInteger n) $ throwPosError (msg (show n))- vb (PNumber n) = check n- vb (PString s) | Just n <- text2Scientific s = check n- vb a = throwPosError (msg a)--pvalues :: PValue -> InterpreterMonad PValue-pvalues (PHash h) = return $ PArray (toVectorOf traverse h)-pvalues x = throwPosError ("values(): expected a hash, not" <+> pretty x)
− Puppet/Utils.hs
@@ -1,156 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE LambdaCase #-}--- | Those are utility functions, most of them being pretty much self--- explanatory.-module Puppet.Utils (- textElem- , getDirectoryContents- , takeBaseName- , takeDirectory- , strictifyEither- , loadYamlFile- , scientific2text- , text2Scientific- , getFiles- , ifromList, ikeys, isingleton, ifromListWith, iunionWith, iinsertWith- -- * re-export- , module Data.Monoid-) where--import Data.Attoparsec.Text (parseOnly, rational)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.ByteString as BS-import qualified Data.Foldable as F-import Data.Hashable-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import Data.Monoid-import System.Posix.Directory.ByteString-import qualified Data.Either.Strict as S-import Data.Scientific-import Control.Exception-import Control.Lens-import qualified Data.Yaml as Y--text2Scientific :: T.Text -> Maybe Scientific-text2Scientific t = case parseOnly rational t of- Left _ -> Nothing- Right s -> Just s--scientific2text :: Scientific -> T.Text-scientific2text n = T.pack $ case floatingOrInteger n of- Left r -> show (r :: Double)- Right i -> show (i :: Integer)--strictifyEither :: Either a b -> S.Either a b-strictifyEither (Left x) = S.Left x-strictifyEither (Right x) = S.Right x--textElem :: Char -> T.Text -> Bool-textElem c = T.any (==c)--getDirectoryContents :: T.Text -> IO [T.Text]-getDirectoryContents fpath = do- h <- openDirStream (T.encodeUtf8 fpath)- let readHandle = do- fp <- readDirStream h- if BS.null fp- then return []- else fmap (T.decodeUtf8 fp :) readHandle- out <- readHandle- closeDirStream h- return out---- | See System.FilePath.Posix-takeBaseName :: T.Text -> T.Text-takeBaseName fullname =- let afterLastSlash = last $ T.splitOn "/" fullname- splitExtension = init $ T.splitOn "." afterLastSlash- in T.intercalate "." splitExtension---- | See System.FilePath.Posix-takeDirectory :: T.Text -> T.Text-takeDirectory "" = "."-takeDirectory "/" = "/"-takeDirectory x =- let res = T.dropWhileEnd (== '/') file- file = dropFileName x- in if T.null res && not (T.null file)- then file- else res---- | Drop the filename.------ > dropFileName x == fst (splitFileName x)------ (See System.FilePath.Posix)-dropFileName :: T.Text -> T.Text-dropFileName = fst . splitFileName---- | Split a filename into directory and file. 'combine' is the inverse.------ > Valid x => uncurry (</>) (splitFileName x) == x || fst (splitFileName x) == "./"--- > Valid x => isValid (fst (splitFileName x))--- > splitFileName "file/bob.txt" == ("file/", "bob.txt")--- > splitFileName "file/" == ("file/", "")--- > splitFileName "bob" == ("./", "bob")--- > Posix: splitFileName "/" == ("/","")--- > Windows: splitFileName "c:" == ("c:","")------ (See System.FilePath.Posix)-splitFileName :: T.Text -> (T.Text, T.Text)-splitFileName x = (if T.null dir then "./" else dir, name)- where- (dir, name) = splitFileName_ x- splitFileName_ y = (T.reverse b, T.reverse a)- where- (a,b) = T.break (=='/') $ T.reverse y---- | Read a yaml file and throw a runtime error if the parsing fails-loadYamlFile :: Y.FromJSON a => FilePath -> IO a-loadYamlFile fp = Y.decodeFileEither fp >>= \case- Left rr -> error ("Error when parsing " ++ fp ++ ": " ++ show rr)- Right x -> return x---- | helper for hashmap, in case we want another kind of map ..-ifromList :: (Monoid m, At m, F.Foldable f) => f (Index m, IxValue m) -> m-{-# INLINABLE ifromList #-}-ifromList = F.foldl' (\curm (k,v) -> curm & at k ?~ v) mempty--ikeys :: (Eq k, Hashable k) => HM.HashMap k v -> HS.HashSet k-{-# INLINABLE ikeys #-}-ikeys = HS.fromList . HM.keys--isingleton :: (Monoid b, At b) => Index b -> IxValue b -> b-{-# INLINABLE isingleton #-}-isingleton k v = mempty & at k ?~ v--ifromListWith :: (Monoid m, At m, F.Foldable f) => (IxValue m -> IxValue m -> IxValue m) -> f (Index m, IxValue m) -> m-{-# INLINABLE ifromListWith #-}-ifromListWith f = F.foldl' (\curmap (k,v) -> iinsertWith f k v curmap) mempty--iinsertWith :: At m => (IxValue m -> IxValue m -> IxValue m) -> Index m -> IxValue m -> m -> m-{-# INLINABLE iinsertWith #-}-iinsertWith f k v m = m & at k %~ mightreplace- where- mightreplace Nothing = Just v- mightreplace (Just x) = Just (f v x)--iunionWith :: (Hashable k, Eq k) => (v -> v -> v) -> HM.HashMap k v -> HM.HashMap k v -> HM.HashMap k v-{-# INLINABLE iunionWith #-}-iunionWith = HM.unionWith--getFiles :: T.Text -> T.Text -> T.Text -> IO [T.Text]-getFiles moduledir subdir extension = fmap concat $- getDirContents moduledir- >>= mapM ( checkForSubFiles extension . (\x -> moduledir <> "/" <> x <> "/" <> subdir))--checkForSubFiles :: T.Text -> T.Text -> IO [T.Text]-checkForSubFiles extension dir =- catch (fmap Right (getDirContents dir)) (\e -> return $ Left (e :: IOException)) >>= \case- Right o -> return ((map (\x -> dir <> "/" <> x) . filter (T.isSuffixOf extension)) o )- Left _ -> return []--getDirContents :: T.Text -> IO [T.Text]-getDirContents x = fmap (filter (not . T.all (=='.'))) (getDirectoryContents x)
− PuppetDB/Common.hs
@@ -1,57 +0,0 @@-{-# LANGUAGE LambdaCase #-}--- | Common data types for PuppetDB.-module PuppetDB.Common where--import Puppet.Interpreter.Types-import PuppetDB.Remote-import PuppetDB.Dummy-import PuppetDB.TestDB--import Data.Maybe-import Data.List (stripPrefix)-import Control.Lens-import System.Environment-import Data.Vector.Lens-import Servant.Common.BaseUrl-import Network.HTTP.Client---- | The supported PuppetDB implementations.-data PDBType = PDBRemote -- ^ Your standard PuppetDB, queried through the HTTP interface.- | PDBDummy -- ^ A stupid stub, this is the default choice.- | PDBTest -- ^ A slow but handy PuppetDB implementation that is backed by a YAML file.- deriving Eq--instance Read PDBType where- readsPrec _ r | isJust reml = [(PDBRemote, fromJust reml)]- | isJust rems = [(PDBRemote, fromJust rems)]- | isJust duml = [(PDBDummy, fromJust duml)]- | isJust dums = [(PDBDummy, fromJust dums)]- | isJust tstl = [(PDBTest, fromJust tstl)]- | isJust tsts = [(PDBTest, fromJust tsts)]- | otherwise = []- where- reml = stripPrefix "PDBRemote" r- rems = stripPrefix "remote" r- duml = stripPrefix "PDBDummy" r- dums = stripPrefix "dummy" r- tstl = stripPrefix "PDBTest" r- tsts = stripPrefix "test" r---- | Given a 'PDBType', will try return a sane default implementation.-getDefaultDB :: PDBType -> IO (Either PrettyError (PuppetDBAPI IO))-getDefaultDB PDBDummy = return (Right dummyPuppetDB)-getDefaultDB PDBRemote = do- url <- parseBaseUrl "http://localhost:8080"- mgr <- newManager defaultManagerSettings- pdbConnect mgr url-getDefaultDB PDBTest = lookupEnv "HOME" >>= \case- Just h -> loadTestDB (h ++ "/.testdb")- Nothing -> fmap Right initTestDB---- | Turns a 'FinalCatalog' and 'EdgeMap' into a document that can be- -- serialized and fed to @puppet apply@.-generateWireCatalog :: NodeName -> FinalCatalog -> EdgeMap -> WireCatalog-generateWireCatalog node cat edgemap = WireCatalog node "version" edges resources "uiid"- where- edges = toVectorOf (folded . to (\li -> PuppetEdge (li ^. linksrc) (li ^. linkdst) (li ^. linkType))) (concatOf folded edgemap)- resources = toVectorOf folded cat
− PuppetDB/Dummy.hs
@@ -1,18 +0,0 @@--- | A dummy implementation of 'PuppetDBAPI', that will return empty--- responses.-module PuppetDB.Dummy where--import Control.Monad.Except-import Puppet.Interpreter.Types--dummyPuppetDB :: Monad m => PuppetDBAPI m-dummyPuppetDB = PuppetDBAPI- (return "dummy")- (const (return ()))- (const (return ()))- (const (return ()))- (const (throwError "not implemented"))- (const (return [] ))- (const (return [] ))- (throwError "not implemented")- (\_ _ -> return [] )
− PuppetDB/Remote.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-module PuppetDB.Remote (pdbConnect) where--import Control.Lens-import Control.Monad.Except-import Data.Proxy-import Data.Text (Text)-import Network.HTTP.Client (Manager)-import Servant.API-import Servant.Client--import Puppet.Interpreter.Types-import Puppet.PP--type PDBAPIv3 = "nodes" :> QueryParam "query" (Query NodeField) :> Get '[JSON] [NodeInfo]- :<|> "nodes" :> Capture "resourcename" Text :> "resources" :> QueryParam "query" (Query ResourceField) :> Get '[JSON] [Resource]- :<|> "facts" :> QueryParam "query" (Query FactField) :> Get '[JSON] [FactInfo]- :<|> "resources" :> QueryParam "query" (Query ResourceField) :> Get '[JSON] [Resource]--type PDBAPI = "v3" :> PDBAPIv3--api :: Proxy PDBAPI-api = Proxy---- | Given an URL (ie. @http://localhost:8080@), will return an incomplete 'PuppetDBAPI'.-pdbConnect :: Manager -> BaseUrl -> IO (Either PrettyError (PuppetDBAPI IO))-pdbConnect mgr url =- return $ Right $ PuppetDBAPI- (return (string $ show url))- (const (throwError "operation not supported"))- (const (throwError "operation not supported"))- (const (throwError "operation not supported"))- (q1 sgetFacts)- (q1 sgetResources)- (q1 sgetNodes)- (throwError "operation not supported")- (\ndename q -> prettyError $ sgetNodeResources ndename (Just q))- where- sgetNodes :: Maybe (Query NodeField) -> ClientM [NodeInfo]- sgetNodeResources :: Text -> Maybe (Query ResourceField) -> ClientM [Resource]- sgetFacts :: Maybe (Query FactField) -> ClientM [FactInfo]- sgetResources :: Maybe (Query ResourceField) -> ClientM [Resource]- (sgetNodes :<|> sgetNodeResources :<|> sgetFacts :<|> sgetResources) = client api-- prettyError :: ClientM b -> ExceptT PrettyError IO b- prettyError = ExceptT . fmap (_Left %~ PrettyError . string. show) . flip runClientM (ClientEnv mgr url)- q1 :: (Maybe a -> ClientM b) -> a -> ExceptT PrettyError IO b- q1 f a = prettyError (f (Just a))
− PuppetDB/TestDB.hs
@@ -1,192 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell #-}---- | A stub implementation of PuppetDB, backed by a YAML file.-module PuppetDB.TestDB- ( loadTestDB- , initTestDB-) where--import Control.Concurrent.STM-import Control.Exception-import Control.Lens-import Control.Monad.IO.Class-import Control.Monad.Except-import Data.Aeson.Lens-import Data.CaseInsensitive-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import Data.List (foldl')-import qualified Data.Maybe.Strict as S-import Data.Monoid-import qualified Data.Text as T-import qualified Data.Vector as V-import Data.Yaml-import Text.Megaparsec.Pos--import Puppet.Interpreter.Types-import Puppet.Parser.Types-import Puppet.PP--data DBContent = DBContent- { _dbcontentResources :: Container WireCatalog- , _dbcontentFacts :: Container Facts- , _dbcontentBackingFile :: Maybe FilePath- }--makeLensesWith abbreviatedFields ''DBContent--type DB = TVar DBContent--instance FromJSON DBContent where- parseJSON (Object v) = DBContent <$> v .: "resources" <*> v .: "facts" <*> pure Nothing- parseJSON _ = mempty--instance ToJSON DBContent where- toJSON (DBContent r f _) = object [("resources", toJSON r), ("facts", toJSON f)]---- | Initializes the test DB using a file to back its content-loadTestDB :: FilePath -> IO (Either PrettyError (PuppetDBAPI IO))-loadTestDB fp =- decodeFileEither fp >>= \case- Left (OtherParseException rr) -> return (Left (PrettyError (string (show rr))))- Left (InvalidYaml Nothing) -> baseError "Unknown error"- Left (InvalidYaml (Just (YamlException s))) -> if take 21 s == "Yaml file not found: "- then newFile- else baseError (string s)- Left (InvalidYaml (Just (YamlParseException pb ctx (YamlMark _ l c)))) -> baseError $ red (string pb <+> string ctx) <+> "at line" <+> int l <> ", column" <+> int c- Left _ -> newFile- Right x -> fmap Right (genDBAPI (x & backingFile ?~ fp ))- where- baseError r = return $ Left $ PrettyError $ "Could not parse" <+> string fp <> ":" <+> r- newFile = Right <$> genDBAPI (newDB & backingFile ?~ fp )---- | Starts a new PuppetDB, without any backing file.-initTestDB :: IO (PuppetDBAPI IO)-initTestDB = genDBAPI newDB--newDB :: DBContent-newDB = DBContent mempty mempty Nothing--genDBAPI :: DBContent -> IO (PuppetDBAPI IO)-genDBAPI db = do- d <- newTVarIO db- return (PuppetDBAPI (dbapiInfo d)- (replCat d)- (replFacts d)- (deactivate d)- (getFcts d)- (getRes d)- (getNds d)- (commit d)- (getResNode d)- )--data Extracted = EText T.Text- | ESet (HS.HashSet T.Text)- | ENil--resolveQuery :: (a -> b -> Extracted) -> Query a -> b -> Bool-resolveQuery _ QEmpty = const True-resolveQuery f (QEqual a t) = \v -> case f a v of- EText tt -> mk tt == mk t- ESet ss -> ss ^. contains t- _ -> False-resolveQuery f (QNot q) = not . resolveQuery f q-resolveQuery f (QG a i) = ncompare (>) f a i-resolveQuery f (QL a i) = ncompare (<) f a i-resolveQuery f (QGE a i) = ncompare (>=) f a i-resolveQuery f (QLE a i) = ncompare (<=) f a i-resolveQuery _ (QMatch _ _) = const False-resolveQuery f (QAnd qs) = \v -> all (\q -> resolveQuery f q v) qs-resolveQuery f (QOr qs) = \v -> any (\q -> resolveQuery f q v) qs--dbapiInfo :: DB -> IO Doc-dbapiInfo db = do- c <- readTVarIO db- case c ^. backingFile of- Nothing -> return "TestDB"- Just v -> return ("TestDB" <+> string v)--ncompare :: (Integer -> Integer -> Bool) -> (a -> b -> Extracted) -> a -> Integer -> b -> Bool-ncompare operation f a i v = case f a v of- EText tt -> case PString tt ^? _Integer of- Just ii -> operation i ii- _ -> False- _ -> False--replCat :: DB -> WireCatalog -> ExceptT PrettyError IO ()-replCat db wc = liftIO $ atomically $ modifyTVar db (resources . at (wc ^. wireCatalogNodename) ?~ wc)--replFacts :: DB -> [(NodeName, Facts)] -> ExceptT PrettyError IO ()-replFacts db lst = liftIO $ atomically $ modifyTVar db $- facts %~ (\r -> foldl' (\curr (n,f) -> curr & at n ?~ f) r lst)--deactivate :: DB -> NodeName -> ExceptT PrettyError IO ()-deactivate db n = liftIO $ atomically $ modifyTVar db $- (resources . at n .~ Nothing) . (facts . at n .~ Nothing)--getFcts :: DB -> Query FactField -> ExceptT PrettyError IO [FactInfo]-getFcts db f = fmap (filter (resolveQuery factQuery f) . toFactInfo) (liftIO $ readTVarIO db)- where- toFactInfo :: DBContent -> [FactInfo]- toFactInfo = concatMap gf . HM.toList . _dbcontentFacts- where- gf (k,n) = do- (fn,fv) <- HM.toList n- return $ FactInfo k fn fv- factQuery :: FactField -> FactInfo -> Extracted- factQuery t = EText . view l- where- l = case t of- FName -> factInfoName- FValue -> factInfoVal . _PString- FCertname -> factInfoNodename--resourceQuery :: ResourceField -> Resource -> Extracted-resourceQuery RTag r = r ^. rtags . to ESet-resourceQuery RCertname r = r ^. rnode . to EText-resourceQuery (RParameter p) r = case r ^? rattributes . ix p . _PString of- Just s -> EText s- Nothing -> ENil-resourceQuery RType r = r ^. rid . itype . to EText-resourceQuery RTitle r = r ^. rid . iname . to EText-resourceQuery RExported r = if r ^. rvirtuality == Exported- then EText "true"- else EText "false"-resourceQuery RFile r = r ^. rpos . _1 . to sourceName . to T.pack . to EText-resourceQuery RLine r = r ^. rpos . _1 . to sourceLine . to show . to T.pack . to EText--getRes :: DB -> Query ResourceField -> ExceptT PrettyError IO [Resource]-getRes db f = fmap (filter (resolveQuery resourceQuery f) . toResources) (liftIO $ readTVarIO db)- where- toResources :: DBContent -> [Resource]- toResources = concatMap (V.toList . view wireCatalogResources) . HM.elems . view resources--getResNode :: DB -> NodeName -> Query ResourceField -> ExceptT PrettyError IO [Resource]-getResNode db nn f = do- c <- liftIO $ readTVarIO db- case c ^. resources . at nn of- Just cnt -> return $ filter (resolveQuery resourceQuery f) $ V.toList $ cnt ^. wireCatalogResources- Nothing -> throwError "Unknown node"--commit :: DB -> ExceptT PrettyError IO ()-commit db = do- dbc <- liftIO $ atomically $ readTVar db- case dbc ^. backingFile of- Nothing -> throwError "No backing file defined"- Just bf -> liftIO (encodeFile bf dbc `catches` [ ])--getNds :: DB -> Query NodeField -> ExceptT PrettyError IO [NodeInfo]-getNds db QEmpty = fmap toNodeInfo (liftIO $ readTVarIO db)- where- toNodeInfo :: DBContent -> [NodeInfo]- toNodeInfo = fmap g . HM.keys . _dbcontentFacts- where- g :: NodeName -> NodeInfo- g = \n -> NodeInfo n False S.Nothing S.Nothing S.Nothing--getNds _ _ = throwError "getNds with query not implemented"
language-puppet.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet-version: 1.3.12.1+version: 1.3.13 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,10 +15,10 @@ build-type: Simple cabal-version: >=1.8 -Tested-With: GHC == 8.0.2, GHC == 8.2.1+Tested-With: GHC == 8.0.2, GHC == 8.2.2 extra-source-files:- CHANGELOG.markdown+ CHANGELOG README.adoc HLint.hs @@ -30,6 +30,7 @@ location: git://github.com/bartavelle/language-puppet.git library+ hs-source-dirs: src exposed-modules: Erb.Evaluate , Erb.Parser , Erb.Ruby@@ -60,7 +61,7 @@ , Puppet.Stats , Puppet.Stdlib , Puppet.OptionalTests- , Puppet.Utils+ , Puppet.Prelude other-modules: Erb.Compute , Paths_language_puppet , Puppet.Interpreter.RubyRandom@@ -79,7 +80,7 @@ , Puppet.NativeTypes.ZoneRecord , Puppet.Parser.Utils , Puppet.Paths- extensions: OverloadedStrings, BangPatterns+ extensions: OverloadedStrings, BangPatterns, NoImplicitPrelude ghc-options: -Wall -funbox-strict-fields -j1 -- ghc-prof-options: -auto-all -caf-all build-depends: aeson >= 0.8@@ -94,6 +95,7 @@ , directory >= 1.2 && < 1.4 , exceptions >= 0.8 && < 0.9 , filecache >= 0.2.9 && < 0.3+ , filepath >= 1.4 , formatting , hashable == 1.2.* , http-api-data >= 0.2 && < 0.4@@ -110,12 +112,13 @@ , parsec == 3.1.* , pcre-utils >= 0.1.7 && < 0.2 , process >= 1.2+ , protolude >= 0.2 , random , regex-pcre-builtin >= 0.94.4 , scientific >= 0.2 && < 0.4 , semigroups- , servant >= 0.9 && < 1- , servant-client >= 0.9 && < 1+ , servant >= 0.9 && < 0.12+ , servant-client >= 0.9 && < 0.12 , split == 0.2.* , stm == 2.4.* , strict-base-types >= 0.3@@ -151,8 +154,9 @@ hs-source-dirs: tests type: exitcode-stdio-1.0 ghc-options: -Wall -rtsopts -threaded- extensions: OverloadedStrings- build-depends: language-puppet,base,hspec,temporary,strict-base-types,HUnit,lens,vector,unordered-containers,text,hslogger+ extensions: OverloadedStrings, NoImplicitPrelude+ Other-Modules: Helpers+ build-depends: language-puppet,base,hspec,temporary,strict-base-types,HUnit,lens,vector,unordered-containers,text,hslogger,neat-interpolation,protolude >=0.2,scientific,mtl main-is: hiera.hs Test-Suite test-puppetdb hs-source-dirs: tests@@ -171,9 +175,9 @@ Test-Suite spec hs-source-dirs: tests type: exitcode-stdio-1.0- ghc-options: -Wall -rtsopts -threaded- extensions: OverloadedStrings- build-depends: language-puppet,base,strict-base-types,lens,text,hspec,unordered-containers,megaparsec,vector,scientific,mtl,hspec-megaparsec+ ghc-options: -Wall -Wno-missing-signatures -rtsopts -threaded+ extensions: OverloadedStrings, NoImplicitPrelude+ build-depends: language-puppet,base,strict-base-types,lens,text,hspec,unordered-containers,megaparsec,vector,scientific,mtl,hspec-megaparsec, protolude >= 0.2 other-modules: Function.ShellquoteSpec Function.SprintfSpec Function.SizeSpec@@ -182,6 +186,7 @@ Function.DeleteAtSpec Function.AssertPrivateSpec Function.JoinKeysToValuesSpec+ Function.LookupSpec InterpreterSpec Interpreter.CollectorSpec Interpreter.IfSpec@@ -194,6 +199,7 @@ extensions: BangPatterns, OverloadedStrings ghc-options: -Wall -rtsopts -funbox-strict-fields -threaded -with-rtsopts "-A2M" -eventlog -- ghc-prof-options: -auto-all -caf-all -fprof-auto+ other-modules: Paths_language_puppet build-depends: base , Glob , aeson@@ -234,6 +240,7 @@ extensions: BangPatterns, OverloadedStrings ghc-options: -Wall -rtsopts -threaded -- ghc-prof-options: -auto-all -caf-all -fprof-auto+ other-modules: Paths_language_puppet build-depends: base , aeson , bytestring
progs/PuppetResources.hs view
@@ -1,44 +1,36 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-} module Main where +import Puppet.Prelude hiding (option)+ import Control.Concurrent.ParallelIO (parallel)-import Control.Lens hiding (Strict)-import Control.Monad-import Control.Monad.Trans.Except-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.Aeson as Aeson import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS-import Data.List (isInfixOf)-import Data.Maybe (fromMaybe, isNothing, mapMaybe)-import Data.Monoid hiding (First)+import qualified Data.List as List import qualified Data.Set as Set-import qualified Data.Text as T-import qualified Data.Text.IO as T-import Data.Text.Strict.Lens-import Data.Tuple (swap)+import qualified Data.Text as Text+import Data.Text.Strict.Lens (unpacked) import qualified Data.Vector as V import qualified Data.Version (showVersion)-import Data.Void (Void)-import Network.HTTP.Client+import qualified Network.HTTP.Client as Http import Options.Applicative-import qualified Paths_language_puppet-import Servant.Common.BaseUrl (parseBaseUrl)-import System.Exit (exitFailure, exitSuccess)-import qualified System.FilePath.Glob as G-import System.IO (hIsTerminalDevice, stdout)-import qualified System.Log.Logger as LOG+import qualified Paths_language_puppet as Meta+import qualified Servant.Common.BaseUrl as Servant+import qualified System.FilePath.Glob as Glob+import System.IO (hIsTerminalDevice)+import qualified System.Log.Logger as Log import qualified Text.Megaparsec as P-import qualified Text.Regex.PCRE.String as REG+import qualified Text.Regex.PCRE.String as Reg import qualified Facter import Puppet.Daemon import Puppet.Lens-import Puppet.Parser hiding (Parser)+import Puppet.Parser hiding (Parser) import Puppet.Parser.PrettyPrinter (ppStatements) import Puppet.Parser.Types import Puppet.Preferences@@ -49,35 +41,35 @@ import PuppetDB.TestDB (loadTestDB) type ParseError' = P.ParseError Char Void-type QueryFunc = NodeName -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))+type QueryFunc = NodeName -> IO (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) -data MultNodes = MultNodes [T.Text] | AllNodes deriving Show+data MultNodes = MultNodes [Text] | AllNodes deriving Show -instance Read MultNodes where- readsPrec _ "allnodes" = [(AllNodes, "")]- readsPrec _ s = let os = (T.splitOn "," . T.pack) s- in [(MultNodes os, "")]+readMultNodes:: String -> Maybe MultNodes+readMultNodes "allnodes" = Just AllNodes+readMultNodes n = Just (MultNodes (Text.splitOn "," (toS n))) data Options = Options { _optShowjson :: Bool , _optShowContent :: Bool- , _optResourceType :: Maybe T.Text- , _optResourceName :: Maybe T.Text+ , _optResourceType :: Maybe Text+ , _optResourceName :: Maybe Text , _optPuppetdir :: Maybe FilePath , _optNodename :: Maybe NodeName , _optMultnodes :: Maybe MultNodes , _optDeadcode :: Bool , _optPdburl :: Maybe String , _optPdbfile :: Maybe FilePath- , _optLoglevel :: LOG.Priority+ , _optLoglevel :: Log.Priority , _optHieraFile :: Maybe FilePath , _optCommitDB :: Bool , _optCheckExport :: Bool- , _optIgnoredMods :: Maybe (HS.HashSet T.Text)+ , _optIgnoredMods :: Maybe (HS.HashSet Text) , _optParse :: Maybe FilePath , _optStrictMode :: Bool , _optNoExtraTests :: Bool , _optVersion :: Bool+ , _optRebaseFile :: Maybe FilePath } deriving (Show) options :: Parser Options@@ -90,11 +82,11 @@ ( long "showcontent" <> short 'c' <> help "When specifying a file resource, only output its content (useful for testing templates)")- <*> optional (T.pack <$> strOption+ <*> optional (Text.pack <$> strOption ( long "type" <> short 't' <> help "Filter the output by resource type (accepts a regular expression, ie '^file$')"))- <*> optional (T.pack <$> strOption+ <*> optional (Text.pack <$> strOption ( long "name" <> short 'n' <> help "Filter the output by resource name (accepts a regular expression)"))@@ -102,11 +94,11 @@ ( long "puppetdir" <> short 'p' <> help "Puppet directory"))- <*> optional (T.pack <$> strOption+ <*> optional (Text.pack <$> strOption ( long "node" <> short 'o' <> help "The name of the node"))- <*> optional (option auto+ <*> optional (option (maybeReader readMultNodes) ( long "all" <> short 'a' <> help "Values are a list of nodes or \"allnodes\""))@@ -123,18 +115,17 @@ ( long "loglevel" <> short 'v' <> help "Values are : DEBUG, INFO, NOTICE, WARNING, ERROR"- <> value LOG.WARNING)+ <> value Log.WARNING) <*> optional (strOption ( long "hiera"- <> help "Path to the Hiera configuration file (default hiera.yaml)"- <> value "hiera.yaml"))+ <> help "Path to the Hiera configuration file (default hiera.yaml)")) <*> switch ( long "commitdb" <> help "Commit the computed catalogs in the puppetDB") <*> switch ( long "checkExported" <> help "Save exported resources in the puppetDB")- <*> optional (HS.fromList . T.splitOn "," . T.pack <$>+ <*> optional (HS.fromList . Text.splitOn "," . Text.pack <$> strOption ( long "ignoredmodules" <> help "Specify a comma-separated list of modules to ignore"))@@ -150,6 +141,9 @@ <*> switch ( long "version" <> help "Output version information and exit")+ <*> optional (strOption+ ( long "rebasefile"+ <> help "Rebase all calls to the 'file' function so that absolute path are relative to the Puppet directory")) -- | Like catMaybes, but it counts the Nothing values@@ -167,38 +161,39 @@ -> Options -> IO (QueryFunc, PuppetDBAPI IO, MStats, MStats, MStats) initializedaemonWithPuppet workingdir Options {..} = do- mgr <- newManager defaultManagerSettings+ mgr <- Http.newManager Http.defaultManagerSettings pdbapi <- case (_optPdburl, _optPdbfile) of (Nothing, Nothing) -> return dummyPuppetDB- (Just _, Just _) -> error "You must choose between a testing PuppetDB and a remote one"- (Just url, _) -> checkError "Error when parsing url" (parseBaseUrl url)+ (Just _, Just _) -> panic "You must choose between a testing PuppetDB and a remote one"+ (Just url, _) -> checkError "Error when parsing url" (Servant.parseBaseUrl url) >>= pdbConnect mgr >>= checkError "Error when connecting to the remote PuppetDB" (_, Just file) -> loadTestDB file >>= checkError "Error when initializing the PuppetDB API" pref <- dfPreferences workingdir <&> prefPDB .~ pdbapi <&> prefHieraPath .~ _optHieraFile <&> prefIgnoredmodules %~ (`fromMaybe` _optIgnoredMods)- <&> (if _optStrictMode then prefStrictness .~ Strict else id)- <&> (if _optNoExtraTests then prefExtraTests .~ False else id)+ <&> (if _optStrictMode then prefStrictness .~ Strict else identity)+ <&> (if _optNoExtraTests then prefExtraTests .~ False else identity) <&> prefLogLevel .~ _optLoglevel+ <&> prefRebaseFile .~ _optRebaseFile d <- initDaemon pref let queryfunc = \node -> fmap (unifyFacts (pref ^. prefFactsDefault) (pref ^. prefFactsOverride)) (Facter.puppetDBFacts node pdbapi) >>= getCatalog d node- return (queryfunc, pdbapi, parserStats d, catalogStats d, templateStats d)+ pure (queryfunc, pdbapi, parserStats d, catalogStats d, templateStats d) where -- merge 3 sets of facts : some defaults, the original set and some override unifyFacts :: Container PValue -> Container PValue -> Container PValue -> Container PValue unifyFacts defaults override c = override `HM.union` c `HM.union` defaults parseFile :: FilePath -> IO (Either ParseError' (V.Vector Statement))-parseFile fp = runPParser fp <$> T.readFile fp+parseFile fp = runPParser fp <$> readFile fp -printContent :: T.Text -> FinalCatalog -> IO ()+printContent :: Text -> FinalCatalog -> IO () printContent filename catalog = case HM.lookup (RIdentifier "file" filename) catalog of- Nothing -> error "File not found"+ Nothing -> panic "File not found" Just r -> case HM.lookup "content" (r ^. rattributes) of- Nothing -> error "This file has no content"- Just (PString c) -> T.putStrLn c+ Nothing -> panic "This file has no content"+ Just (PString c) -> putText c Just x -> print x prepareForPuppetApply :: WireCatalog -> WireCatalog@@ -209,8 +204,8 @@ capi :: RIdentifier -> RIdentifier capi r = r & itype %~ capitalizeRT & if r ^. itype == "class" then iname %~ capitalizeRT- else id- aliasMap :: HM.HashMap RIdentifier T.Text+ else identity+ aliasMap :: HM.HashMap RIdentifier Text aliasMap = HM.fromList $ concatMap genAliasList (res ^.. folded) genAliasList r = map (\n -> (RIdentifier (r ^. rid . itype) n, r ^. rid . iname)) (r ^. rid . iname : r ^.. ralias . folded) nr = V.map (rid %~ capi) res@@ -238,17 +233,17 @@ -- first collect all files / positions from all the catalogs let allpositions = Set.fromList $ catalogs ^.. traverse . rpos -- now find all haskell files- puppetfiles <- Set.fromList <$> G.globDir1 (G.compile "**/*.pp") (puppetdir <> "/modules")- let deadfiles = Set.filter ("/manifests/" `isInfixOf`) $ puppetfiles `Set.difference` allfiles+ puppetfiles <- Set.fromList <$> Glob.globDir1 (Glob.compile "**/*.pp") (puppetdir <> "/modules")+ let deadfiles = Set.filter ("/manifests/" `List.isInfixOf`) $ puppetfiles `Set.difference` allfiles usedfiles = puppetfiles `Set.intersection` allfiles unless (Set.null deadfiles) $ do putDoc ("The following files" <+> int (Set.size deadfiles) <+> "are not used: " <> list (map string $ Set.toList deadfiles))- putStrLn ""+ putText "" allparses <- parallel (map parseFile (Set.toList usedfiles)) let (parseFailed, parseSucceeded) = partitionEithers allparses unless (null parseFailed) $ do putDoc ("The following" <+> int (length parseFailed) <+> "files could not be parsed:" </> indent 4 (vcat (map (string . show) parseFailed)))- putStrLn ""+ putText "" let getSubStatements s@ResourceDeclaration{} = [s] getSubStatements (ConditionalDeclaration (ConditionalDecl conds _)) = conds ^.. traverse . _2 . tgt getSubStatements s@ClassDeclaration{} = extractPrism s@@ -264,8 +259,7 @@ isDead (ResourceDeclaration (ResDecl _ _ _ _ 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)))- putStrLn ""+ putDoc ("The following" <+> int (length deadResources) <+> "resource declarations are not used:" </> indent 4 (vcat (map pretty deadResources)) <> line ) newtype Maximum a = Maximum { getMaximum :: Maybe a } @@ -287,7 +281,7 @@ cStats <- getStats catalogStats tStats <- getStats templateStats let allres = (cats ^.. folded . _1 . folded) ++ (cats ^.. folded . _2 . folded)- allfiles = Set.fromList $ map T.unpack $ HM.keys pStats+ allfiles = Set.fromList $ map Text.unpack $ HM.keys pStats when _optDeadcode $ findDeadCode workingdir allres allfiles -- compute statistics let (parsing, Just (wPName, wPMean)) = worstAndSum pStats@@ -303,10 +297,10 @@ putStr ("\nTested " ++ show nbnodes ++ " nodes. ") unless (nbnodes == 0) $ do putStrLn (formatDouble parserShare <> "% of total CPU time spent parsing, " <> formatDouble templateShare <> "% spent computing templates")- when (_optLoglevel <= LOG.NOTICE) $ 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")+ when (_optLoglevel <= Log.NOTICE) $ do+ putStrLn ("Slowest template: " <> Text.unpack wTName <> ", taking " <> formatDouble wTMean <> "s on average")+ putStrLn ("Slowest file to parse: " <> Text.unpack wPName <> ", taking " <> formatDouble wPMean <> "s on average")+ putStrLn ("Slowest catalog to compute: " <> Text.unpack wCName <> ", taking " <> formatDouble wCMean <> "s on average") if failures > 0 then do {putDoc ("Found" <+> red (int failures) <+> "failure(s)." <> line) ; exitFailure}@@ -316,35 +310,35 @@ computeCatalog :: QueryFunc -> NodeName -> IO (Maybe (FinalCatalog, [Resource])) computeCatalog func node = func node >>= \case- S.Left err -> putDoc (line <> red "ERROR:" <+> parens (ttext node) <+> ":" <+> getError err) >> return Nothing- S.Right (rawcatalog, _ , rawexported, knownRes) -> return (Just (rawcatalog <> rawexported, knownRes))+ Left err -> putDoc (line <> red "ERROR:" <+> parens (ttext node) <+> ":" <+> getError err) >> return Nothing+ Right (rawcatalog, _ , rawexported, knownRes) -> return (Just (rawcatalog <> rawexported, knownRes)) -- | Queryfunc the catalog for the node and PP the result computeNodeCatalog :: Options -> QueryFunc -> PuppetDBAPI IO -> NodeName -> IO () computeNodeCatalog Options {..} queryfunc pdbapi node = queryfunc node >>= \case- S.Left rr -> do+ Left rr -> do putDoc (line <> red "ERROR:" <+> parens (ttext node) <+> getError rr) exitFailure- S.Right (rawcatalog, edgemap, rawexported, _) -> do+ Right (rawcatalog, edgemap, rawexported, _) -> do printFunc <- hIsTerminalDevice stdout >>= \isterm -> return $ \x -> if isterm- then putDoc x >> putStrLn ""- else displayIO stdout (renderCompact x) >> putStrLn ""+ then putDoc (x <> line)+ else displayIO stdout (renderCompact (x <> line)) catalog <- filterCatalog _optResourceType _optResourceName rawcatalog exported <- filterCatalog _optResourceType _optResourceName rawexported let wirecatalog = generateWireCatalog node (catalog <> exported ) edgemap rawWireCatalog = generateWireCatalog node (rawcatalog <> rawexported) edgemap when _optCheckExport $ void $ runExceptT $ replaceCatalog pdbapi rawWireCatalog case (_optShowContent, _optShowjson) of- (_, True) -> BSL.putStrLn (encode (prepareForPuppetApply wirecatalog))+ (_, True) -> putLByteString (Aeson.encode (prepareForPuppetApply wirecatalog)) (True, _) -> do unless (_optResourceType == Just "file" || isNothing _optResourceType) $ do putDoc "Show content only works with resource of type file. It is an error to provide another filter type" exitFailure case _optResourceName of Just f -> printContent f catalog- Nothing -> putDoc "You should supply a resource name when using showcontent" >> exitFailure+ Nothing -> die "You should supply a resource name when using showcontent" _ -> do printFunc (pretty (HM.elems catalog)) unless (HM.null exported) $ do@@ -353,34 +347,34 @@ -- | Filter according to the type and name regex from the command line option-filterCatalog :: Maybe T.Text -> Maybe T.Text -> FinalCatalog -> IO FinalCatalog+filterCatalog :: Maybe Text -> Maybe Text -> FinalCatalog -> IO FinalCatalog filterCatalog typeFilter nameFilter = filterC typeFilter (_1 . itype . unpacked) >=> filterC nameFilter (_1 . iname . unpacked) where -- filter catalog using the adhoc lens filterC Nothing _ c = return c- filterC (Just regexp) l c = REG.compile REG.compBlank REG.execBlank (T.unpack regexp) >>= \case- Left rr -> error ("Error compiling regexp 're': " ++ show rr)+ filterC (Just regexp) l c = Reg.compile Reg.compBlank Reg.execBlank (Text.unpack regexp) >>= \case+ Left rr -> panic ("Error compiling regexp 're': " <> show rr) Right reg -> HM.fromList <$> filterM (filterResource reg l) (HM.toList c)- filterResource reg l v = REG.execute reg (v ^. l) >>= \case- Left rr -> error ("Error when applying regexp: " ++ show rr)+ filterResource reg l v = Reg.execute reg (v ^. l) >>= \case+ Left rr -> panic ("Error when applying regexp: " <> show rr) Right Nothing -> return False _ -> return True run :: Options -> IO ()-run Options {_optVersion = True, ..} = putStrLn ("language-puppet " ++ Data.Version.showVersion Paths_language_puppet.version)+run Options {_optVersion = True, ..} = putStrLn ("language-puppet " ++ Data.Version.showVersion Meta.version) -- | Parse mode run Options {_optParse = Just fp, ..} = parseFile fp >>= \case- Left rr -> error (P.parseErrorPretty rr)- Right s -> if _optLoglevel == LOG.DEBUG+ Left rr -> panic (toS $ P.parseErrorPretty rr)+ Right s -> if _optLoglevel == Log.DEBUG then mapM_ print s else putDoc $ ppStatements s run Options {_optPuppetdir = Nothing, _optParse = Nothing } =- error "Without a puppet dir, only the `--parse` option can be supported"+ panic "Without a puppet dir, only the `--parse` option can be supported" run Options {_optPuppetdir = Just _, _optNodename = Nothing, _optMultnodes = Nothing} =- error "You need to choose between single or multiple node"+ panic "You need to choose between single or multiple node" -- | Single node mode (`--node` option) run cmd@Options {_optNodename = Just node, _optPuppetdir = Just workingdir, ..} = do@@ -395,12 +389,12 @@ where retrieveNodes :: MultNodes -> IO [NodeName] retrieveNodes AllNodes = do- allstmts <- parseFile (workingdir <> "/manifests/site.pp") >>= \case Left err -> error (show err)+ allstmts <- parseFile (workingdir <> "/manifests/site.pp") >>= \case Left err -> panic (show err) Right x -> return x let getNodeName (NodeDeclaration (NodeDecl (NodeName n) _ _ _)) = Just n getNodeName _ = Nothing return $ mapMaybe getNodeName (V.toList allstmts)- retrieveNodes (MultNodes xs) = return xs+ retrieveNodes (MultNodes xs) = pure xs main :: IO () main = execParser opts >>= run
progs/pdbQuery.hs view
@@ -1,26 +1,23 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-} module Main where -import Control.Lens-import Control.Monad (forM_, unless, (>=>))-import Control.Monad.Trans.Except-import qualified Data.Aeson as Aeson-import qualified Data.ByteString.Lazy.Char8 as BS-import qualified Data.Either.Strict as S-import qualified Data.HashMap.Strict as HM-import Data.List (foldl')-import Data.Monoid-import qualified Data.Text as T-import qualified Data.Vector as V-import qualified Data.Version (showVersion)-import Network.HTTP.Client-import Options.Applicative as O-import qualified Paths_language_puppet-import Servant.Common.BaseUrl-import System.Exit (exitFailure)+import Puppet.Prelude hiding (option) +import qualified Data.Aeson as Aeson+import qualified Data.Either.Strict as S+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as Text+import qualified Data.Vector as V+import qualified Data.Version as Version+import qualified Network.HTTP.Client as Http+import Options.Applicative as O+import qualified Paths_language_puppet as Meta+import qualified Servant.Common.BaseUrl as Servant+ import Facter import Puppet.Interpreter.Types import PuppetDB.Common@@ -28,20 +25,21 @@ import PuppetDB.TestDB -data Options = Options { _pdbloc :: Maybe FilePath- , _pdbtype :: PDBType- , _pdbcmd :: Maybe Command- , _pdbversion :: Bool- }+data Options = Options+ { _pdbloc :: Maybe FilePath+ , _pdbtype :: PDBType+ , _pdbcmd :: Maybe Command+ , _pdbversion :: Bool+ } data Command = DumpFacts- | DumpFact T.Text+ | DumpFact Text | DumpNodes- | EditFact T.Text T.Text- | DeactivateNode T.Text- | DumpResources T.Text+ | EditFact Text Text+ | DeactivateNode Text+ | DumpResources Text | CreateTestDB FilePath- | AddFacts T.Text+ | AddFacts Text options :: Parser Options options = Options@@ -75,10 +73,10 @@ factedit = EditFact <$> O.argument auto mempty <*> O.argument auto mempty factparser :: Parser Command-factparser = DumpFact <$> fmap T.pack (O.strArgument (metavar "NODE"))+factparser = DumpFact <$> fmap Text.pack (O.strArgument (metavar "NODE")) resourcesparser :: Parser Command-resourcesparser = DumpResources <$> fmap T.pack (O.strArgument (metavar "NODE"))+resourcesparser = DumpResources <$> fmap Text.pack (O.strArgument (metavar "NODE")) delnodeparser :: Parser Command delnodeparser = DeactivateNode <$> O.argument auto mempty@@ -90,19 +88,19 @@ addfacts = AddFacts <$> O.argument auto mempty -display :: (Show r, Aeson.ToJSON a) => String -> Either r a -> IO ()-display s (Left rr) = error (s <> " " <> show rr)-display _ (Right a) = BS.putStrLn (Aeson.encode a)+display :: (Show r, Aeson.ToJSON a) => Text -> Either r a -> IO ()+display s (Left rr) = panic (s <> " " <> show rr)+display _ (Right a) = putLByteString (Aeson.encode a) -checkErrorS :: (Show r) => String -> S.Either r a -> IO a-checkErrorS s (S.Left rr) = error (s <> " " <> show rr)+checkErrorS :: (Show r) => Text -> S.Either r a -> IO a+checkErrorS s (S.Left rr) = panic (s <> " " <> show rr) checkErrorS _ (S.Right a) = return a -checkError :: (Show r) => String -> Either r a -> IO a-checkError s (Left rr) = error (s <> " " <> show rr)+checkError :: (Show r) => Text -> Either r a -> IO a+checkError s (Left rr) = panic (s <> " " <> show rr) checkError _ (Right a) = return a -runCheck :: Show r => String -> ExceptT r IO a -> IO a+runCheck :: Show r => Text -> ExceptT r IO a -> IO a runCheck s = runExceptT >=> checkError s showHelpText :: ParserPrefs -> ParserInfo a -> IO ()@@ -111,17 +109,17 @@ run :: Options -> IO () run Options {_pdbversion = False, _pdbcmd = Nothing} =- putStrLn "Please provide one of the available command (see --help for more information) " *> exitFailure-run Options {_pdbversion = True, ..} = putStrLn ("language-puppet " ++ Data.Version.showVersion Paths_language_puppet.version)+ putText "Please provide one of the available command (see --help for more information) " *> exitFailure+run Options {_pdbversion = True, ..} = putStrLn ("language-puppet " ++ Version.showVersion Meta.version) run Options{_pdbcmd = Just pdbcmd, ..} = do- mgr <- newManager defaultManagerSettings+ mgr <- Http.newManager Http.defaultManagerSettings epdbapi <- case (_pdbloc, _pdbtype) of- (Just l, PDBRemote) -> pdbConnect mgr $ either (error . show) id $ parseBaseUrl l+ (Just l, PDBRemote) -> pdbConnect mgr $ either (panic . show) identity $ Servant.parseBaseUrl l (Just l, PDBTest) -> loadTestDB l (_, x) -> getDefaultDB x pdbapi <- case epdbapi of- Left r -> error (show r)+ Left r -> panic (show r) Right x -> return x case pdbcmd of DumpFacts -> if _pdbtype == PDBDummy@@ -138,7 +136,7 @@ DumpNodes -> runExceptT (getNodes pdbapi QEmpty) >>= display "dump nodes" DumpResources n -> runExceptT (getResourcesOfNode pdbapi n QEmpty) >>= display "get resources" AddFacts n -> do- unless (_pdbtype == PDBTest) (error "This option only works with the test puppetdb")+ unless (_pdbtype == PDBTest) (panic "This option only works with the test puppetdb") fcts <- puppetDBFacts n pdbapi runCheck "replace facts" (replaceFacts pdbapi [(n, fcts)]) runCheck "commit db" (commitDB pdbapi)@@ -150,11 +148,11 @@ runCheck "replace facts" (replaceFacts ndb factsGrouped) forM_ allnodes $ \pnodename -> do let ndename = pnodename ^. nodeInfoName- res <- runCheck ("get resources for " ++ show ndename) (getResourcesOfNode pdbapi ndename QEmpty)+ res <- runCheck ("get resources for " <> show ndename) (getResourcesOfNode pdbapi ndename QEmpty) let wirecatalog = WireCatalog ndename "version" V.empty (V.fromList res) ndename runCheck "replace catalog" (replaceCatalog ndb wirecatalog) runCheck "commit db" (commitDB ndb)- _ -> error "Not yet implemented"+ _ -> panic "Not yet implemented" main :: IO () main = execParser opts >>= run
progs/yera.hs view
@@ -1,45 +1,42 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE StrictData #-} module Main (main) where- ++import Puppet.Prelude hiding (option)++import qualified Data.Either.Strict as S+import qualified Data.HashMap.Strict as HM+import qualified Data.List as List import Options.Applicative-import Data.Monoid-import qualified Data.Text as T-import qualified Data.Either.Strict as S-import qualified Data.HashMap.Strict as HM-import Text.PrettyPrint.ANSI.Leijen (pretty)+import Text.PrettyPrint.ANSI.Leijen (pretty) -import Puppet.Interpreter.Types-import Puppet.Interpreter.PrettyPrinter()-import Hiera.Server+import Hiera.Server+import Puppet.Interpreter.PrettyPrinter ()+import Puppet.Interpreter.Types+import Puppet.Interpreter.Utils (readQueryType) data Config = Config- { _filepath :: FilePath- , _query :: String- , _queryType :: HieraQueryType- , _variables :: [(T.Text,T.Text)]+ { _filepath :: FilePath+ , _query :: String+ , _queryType :: HieraQueryType+ , _variables :: [(Text,Text)] } -readQT :: String -> Maybe HieraQueryType-readQT s- = case s of- "first" -> Just QFirst- "unique" -> Just QUnique- "hash" -> Just QHash- _ -> Nothing--parseVariable :: String -> Either String (T.Text, T.Text)+parseVariable :: String -> Either String (Text, Text) parseVariable s =- case break (=='=') s of- ([], []) -> Left "Empty variable"- ([], _) -> Left "Nothing on the left side of the = symbol"- (_, []) -> Left "Nothing on the right side of the = symbol"- (var, '=':val) -> Right (T.pack var, T.pack val)- _ -> Left "???"+ case List.break (=='=') s of+ ([], []) -> Left "Empty variable"+ ([], _) -> Left "Nothing on the left side of the = symbol"+ (_, []) -> Left "Nothing on the right side of the = symbol"+ (var, '=':val) -> Right (toS var, toS val)+ _ -> Left "???" configParser :: Parser Config configParser = Config <$> strOption (long "config" <> short 'c' <> metavar "CONFIG" <> value "hiera.yaml") <*> strOption (long "query" <> short 'q' <> metavar "QUERY")- <*> option (maybeReader readQT) (long "querytype" <> short 't' <> metavar "QUERYTYPE" <> value QFirst <> help "values: first (default), unique, hash")+ <*> option (maybeReader (readQueryType.toS)) (long "querytype" <> short 't' <> metavar "QUERYTYPE" <> value QFirst <> help "values: first (default), unique, hash") <*> many (argument (eitherReader parseVariable) (metavar "VARIABLE" <> help "Variables, in the form key=value")) configInfo :: ParserInfo Config@@ -48,12 +45,8 @@ main :: IO () main = do Config fp query qtype vars <- execParser configInfo- ehiera <- startHiera fp- case ehiera of- Left rr -> error rr- Right hiera -> do- r <- hiera (HM.fromList vars) (T.pack query) qtype- case r of- S.Left rr -> error (show rr)- S.Right Nothing -> putStrLn "no match"- S.Right (Just res) -> print (pretty res)+ hiera <- startHiera fp+ hiera (HM.fromList vars) (toS query) qtype >>= \case+ S.Left rr -> panic (show rr)+ S.Right Nothing -> die "no match"+ S.Right (Just res) -> print (pretty res)
+ src/Erb/Compute.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+module Erb.Compute (+ initTemplateDaemon+) where++import Puppet.Prelude++import Data.Aeson.Lens (_Number)+import qualified Data.Either.Strict as S+import qualified Data.FileCache as Cache+import qualified Data.List as List+import Data.String+import qualified Data.Text as Text+import Data.Tuple.Strict (Pair (..))+import qualified Data.Vector as V+import Debug.Trace+import Foreign.Ruby+import qualified Foreign.Ruby.Bindings as FR+import qualified Foreign.Ruby.Helpers as FR+import GHC.Conc (labelThread)+import Paths_language_puppet (getDataFileName)+import System.Environment (getExecutablePath)+import System.Posix.Files+import Text.Parsec hiding (string)+import Text.Parsec.Error+import Text.Parsec.Pos++import Erb.Evaluate+import Erb.Parser+import Erb.Ruby+import Puppet.Interpreter.IO+import Puppet.Interpreter.Resolve+import Puppet.Interpreter.Types+import Puppet.PP+import Puppet.Preferences+import Puppet.Stats++instance IsString TemplateParseError where+ fromString s = TemplateParseError $ newErrorMessage (Message s) (initialPos "dummy")++newtype TemplateParseError = TemplateParseError { tgetError :: ParseError }++type TemplateQuery = (Chan TemplateAnswer, Either Text Text, InterpreterState, InterpreterReader IO)+type TemplateAnswer = S.Either PrettyError Text++showRubyError :: RubyError -> PrettyError+showRubyError (Stack msg stk) = PrettyError $ dullred (string msg) </> dullyellow (string stk)+showRubyError (WithOutput str _) = PrettyError $ dullred (string str)+showRubyError (OtherError rr) = PrettyError (dullred (text rr))++initTemplateDaemon :: RubyInterpreter -> Preferences IO -> MStats -> IO (Either Text Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text))+initTemplateDaemon intr prefs mvstats = do+ controlchan <- newChan+ templatecache <- Cache.newFileCache+ let returnError rs = return $ \_ _ _ -> return (S.Left (showRubyError rs))+ x <- runExceptT $ do+ liftIO (getRubyScriptPath "hrubyerb.rb") >>= ExceptT . loadFile intr+ ExceptT (registerGlobalFunction4 intr "varlookup" hrresolveVariable)+ ExceptT (registerGlobalFunction5 intr "callextfunc" hrcallfunction)+ liftIO $ void $ forkIO $ templateDaemon intr+ (Text.pack (prefs ^. prefPuppetPaths.modulesPath))+ (Text.pack (prefs ^. prefPuppetPaths.templatesPath))+ controlchan+ mvstats+ templatecache+ pure $! templateQuery controlchan+ either returnError return x++templateQuery :: Chan TemplateQuery -> Either Text Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text)+templateQuery qchan filename stt rdr = do+ rchan <- newChan+ writeChan qchan (rchan, filename, stt, rdr)+ readChan rchan++templateDaemon :: RubyInterpreter -> Text -> Text -> Chan TemplateQuery -> MStats -> Cache.FileCacheR TemplateParseError [RubyStatement] -> IO ()+templateDaemon intr modpath templatepath qchan mvstats filecache = do+ let nameThread :: String -> IO ()+ nameThread n = myThreadId >>= flip labelThread n+ nameThread "RubyTemplateDaemon"++ (respchan, fileinfo, stt, rdr) <- readChan qchan+ case fileinfo of+ Right filename -> do+ let prts = Text.splitOn "/" filename+ searchpathes | length prts > 1 = [modpath <> "/" <> List.head prts <> "/templates/" <> Text.intercalate "/" (List.tail prts), templatepath <> "/" <> filename]+ | otherwise = [templatepath <> "/" <> filename]+ acceptablefiles <- filterM (fileExist . Text.unpack) searchpathes+ if null acceptablefiles+ then writeChan respchan (S.Left $ PrettyError $ "Can't find template file for" <+> ttext filename <+> ", looked in" <+> list (map ttext searchpathes))+ else measure mvstats filename (computeTemplate intr (Right (List.head acceptablefiles)) stt rdr mvstats filecache) >>= writeChan respchan+ Left _ -> measure mvstats "inline" (computeTemplate intr fileinfo stt rdr mvstats filecache) >>= writeChan respchan+ templateDaemon intr modpath templatepath qchan mvstats filecache++computeTemplate :: RubyInterpreter -> Either Text Text -> InterpreterState -> InterpreterReader IO -> MStats -> Cache.FileCacheR TemplateParseError [RubyStatement] -> IO TemplateAnswer+computeTemplate intr fileinfo stt rdr mstats filecache = do+ let (curcontext, fvariables) = case extractFromState stt of+ Nothing -> (mempty, mempty)+ Just (c,v) -> (c,v)+ let (filename, ufilename) = case fileinfo of+ Left _ -> ("inline", "inline")+ Right x -> (x, Text.unpack x)+ mkSafe a = makeSafe intr a >>= \case+ Left rr -> return (S.Left (showRubyError rr))+ Right x -> return x+ encapsulateError = _Left %~ TemplateParseError+ variables = fvariables & traverse . scopeVariables . traverse . _1 . _1 %~ toStr+ toStr (PNumber n) = PString (scientific2text n)+ toStr x = x+ traceEventIO ("START template " ++ Text.unpack filename)+ parsed <- case fileinfo of+ Right _ -> measure mstats ("parsing - " <> filename) $ Cache.lazyQuery filecache ufilename $ fmap encapsulateError (parseErbFile ufilename)+ Left content -> measure mstats ("parsing - " <> filename) $ return $ encapsulateError (runParser erbparser () "inline" (Text.unpack content))+ o <- case parsed of+ Left err -> do+ let msg = "Template '" <> toS ufilename <> "' could not be parsed " <> show (tgetError err)+ logDebug msg+ measure mstats ("ruby - " <> filename) $ mkSafe $ computeTemplateWRuby fileinfo curcontext variables stt rdr+ Right ast -> case rubyEvaluate variables curcontext ast of+ Right ev -> return (S.Right ev)+ Left err -> do+ let !msg = "Template '" <> toS ufilename <> "' evaluation failed with: " <> show err+ logDebug msg+ measure mstats ("ruby efail - " <> filename) $ mkSafe $ computeTemplateWRuby fileinfo curcontext variables stt rdr+ traceEventIO ("STOP template " ++ Text.unpack filename)+ return o++getRubyScriptPath :: String -> IO String+getRubyScriptPath rubybin = do+ let checkpath :: FilePath -> IO FilePath -> IO FilePath+ checkpath fp nxt = do+ e <- fileExist fp+ if e+ then return fp+ else nxt+ withExecutablePath = do+ path <- fmap (Text.unpack . takeDirectory . Text.pack) getExecutablePath+ let fullpath = path <> "/" <> rubybin+ checkpath fullpath $ checkpath ("/usr/local/bin/" <> rubybin) (return rubybin)+ cabalPath <- getDataFileName $ "ruby/" ++ rubybin :: IO FilePath+ checkpath cabalPath withExecutablePath++-- This must be called from the proper thread. As this is callback, this+-- should be ok.+hrresolveVariable :: RValue -> RValue -> RValue -> RValue -> IO RValue+-- Text -> Container PValue -> RValue -> RValue -> IO RValue+hrresolveVariable _ rscp rvariables rtoresolve = do+ scope <- FR.extractHaskellValue rscp+ variables <- FR.extractHaskellValue rvariables+ toresolve <- FR.fromRuby rtoresolve+ let answer = case toresolve of+ Right "~g~e~t_h~a~s~h~" ->+ let getvars ctx = (variables ^. ix ctx . scopeVariables) & traverse %~ view (_1 . _1)+ vars = getvars "::" <> getvars scope+ in Right (PHash vars)+ Right t -> getVariable variables scope t+ Left rr -> Left ("The variable name is not a string" <+> text rr)+ case answer of+ Left _ -> getSymbol "undef"+ Right r -> FR.toRuby r++hrcallfunction :: RValue -> RValue -> RValue -> RValue -> RValue -> IO RValue+hrcallfunction _ rfname rargs rstt rrdr = do+ efname <- FR.fromRuby rfname+ eargs <- FR.fromRuby rargs+ rdr <- FR.extractHaskellValue rrdr+ stt <- FR.extractHaskellValue rstt+ let err :: String -> IO RValue+ err rr = fmap (either snd identity) (FR.toRuby (Text.pack rr) >>= FR.safeMethodCall "MyError" "new" . (:[]))+ case (,) <$> efname <*> eargs of+ Right (fname, varray) | fname `elem` ["template", "inline_template"] -> do+ logError $ "Can't parse a call to the external ruby function '" <> fname <> "' n an erb file.\n\tIt is not possible to call it from a Ruby function. It would stall (yes it sucks ...).\n\tChoosing to output \"undef\" !"+ getSymbol "undef"+ | otherwise -> do+ let args = case varray of+ [PArray vargs] -> V.toList vargs+ _ -> varray+ (x,_,_) <- interpretMonad rdr stt (resolveFunction' fname args)+ case x of+ Right o -> case o ^? _Number of+ Just n -> FR.toRuby n+ Nothing -> FR.toRuby o+ Left rr -> err (show rr)+ Left rr -> err rr++computeTemplateWRuby :: Either Text Text -> Text -> Container ScopeInformation -> InterpreterState -> InterpreterReader IO -> IO TemplateAnswer+computeTemplateWRuby fileinfo curcontext variables stt rdr = FR.freezeGC $ eitherDocIO $ do+ rscp <- FR.embedHaskellValue curcontext+ rvariables <- FR.embedHaskellValue variables+ rstt <- FR.embedHaskellValue stt+ rrdr <- FR.embedHaskellValue rdr+ let varlist = variables ^. ix curcontext . scopeVariables+ -- must be called from a "makeSafe" thingie+ contentinfo <- case fileinfo of+ Right fname -> FR.toRuby fname+ Left _ -> FR.toRuby ("-" :: Text)+ let withBinding f = do+ erbBinding <- FR.safeMethodCall "ErbBinding" "new" [rscp,rvariables,rstt,rrdr,contentinfo]+ case erbBinding of+ Left x -> return (Left x)+ Right v -> do+ forM_ (itoList varlist) $ \(varname, varval :!: _ :!: _) -> FR.toRuby varval >>= FR.rb_iv_set v (Text.unpack varname)+ f v+ o <- case fileinfo of+ Right fname -> do+ rfname <- FR.toRuby fname+ withBinding $ \v -> FR.safeMethodCall "Controller" "runFromFile" [rfname,v]+ Left content -> withBinding $ \v -> FR.toRuby content >>= FR.safeMethodCall "Controller" "runFromContent" . (:[v])+ FR.freeHaskellValue rrdr+ FR.freeHaskellValue rstt+ FR.freeHaskellValue rvariables+ FR.freeHaskellValue rscp+ case o of+ Left (rr, _) ->+ let fname = case fileinfo of+ Right f -> Text.unpack f+ Left _ -> "inline_template"+ in return (S.Left $ PrettyError (dullred (text rr) <+> "in" <+> dullgreen (text fname)))+ Right r -> FR.fromRuby r >>= \case+ Right result -> return (S.Right result)+ Left rr -> return (S.Left $ PrettyError ("Could not deserialiaze ruby output" <+> text rr))++eitherDocIO :: IO (S.Either PrettyError a) -> IO (S.Either PrettyError a)+eitherDocIO computation = (computation >>= check) `catch` (\e -> return $ S.Left $ PrettyError $ dullred $ text $ show (e :: SomeException))+ where+ check (S.Left r) = return (S.Left r)+ check (S.Right x) = return (S.Right x)
+ src/Erb/Evaluate.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE LambdaCase #-}+-- | Evaluates a ruby template from what's generated by "Erb.Parser".+module Erb.Evaluate (+ rubyEvaluate+ , extractFromState+ ) where++import Puppet.Prelude++import Data.Aeson.Lens+import qualified Data.Char as Char+import qualified Data.HashMap.Strict as HM+import qualified Data.List as List+import Data.Maybe (fromMaybe)+import qualified Data.Text as Text+import Data.Tuple.Strict (Pair (..))+import qualified Data.Vector as V++import Erb.Ruby+import Puppet.Interpreter.Resolve+import Puppet.Interpreter.Types+import Puppet.Interpreter.Utils+import Puppet.Parser.Utils+import Puppet.PP+import qualified Text.PrettyPrint.ANSI.Leijen as P++extractFromState :: InterpreterState -> Maybe (Text, Container ScopeInformation)+extractFromState stt =+ let cs = stt ^. curScope+ in if null cs+ then Nothing+ else let scp = scopeName (List.head cs)+ classes = (PArray . V.fromList . map PString . HM.keys) (stt ^. loadedClasses)+ scps = stt ^. scopes+ cd = fromMaybe ContRoot (scps ^? ix scp . scopeContainer . cctype) -- get the current containder description+ cscps = scps & ix scp . scopeVariables . at "classes" ?~ ( classes :!: dummyppos :!: cd )+ in Just (scp, cscps)++rubyEvaluate :: Container ScopeInformation -> Text -> [RubyStatement] -> Either Doc Text+rubyEvaluate vars ctx = foldl (evalruby vars ctx) (Right "") . optimize+ where+ optimize [] = []+ optimize (Puts x : DropPrevSpace' : xs) = optimize $ DropPrevSpace (Puts x) : xs+ optimize (x:xs) = x : optimize xs++spaceNotCR :: Char -> Bool+spaceNotCR c = Char.isSpace c && c /= '\n' && c /= '\r'++evalruby :: Container ScopeInformation -> Text -> Either Doc Text -> RubyStatement -> Either Doc Text+evalruby _ _ (Left err) _ = Left err+evalruby _ _ (Right _) (DropPrevSpace') = Left "Could not evaluate a non optimize DropPrevSpace'"+evalruby mp ctx (Right curstr) (DropNextSpace x) =+ case evalruby mp ctx (Right curstr) x of+ Left err -> Left err+ Right y -> Right (Text.dropWhile spaceNotCR y)+evalruby mp ctx (Right curstr) (DropPrevSpace x) =+ case evalruby mp ctx (Right curstr) x of+ Left err -> Left err+ Right y -> Right (Text.dropWhileEnd spaceNotCR y)+evalruby mp ctx (Right curstr) (Puts e) = case evalExpression mp ctx e of+ Left err -> Left err+ Right ex -> Right (curstr <> ex)++evalExpression :: Container ScopeInformation -> Text -> Expression -> Either Doc Text+evalExpression mp ctx (LookupOperation varname varindex) = do+ rvname <- evalExpression mp ctx varname+ rvindx <- evalExpression mp ctx varindex+ getVariable mp ctx rvname >>= \case+ PArray arr ->+ case a2i rvindx of+ Nothing -> Left $ "Can't convert index to integer when resolving" <+> ttext rvname P.<> brackets (ttext rvindx)+ Just i -> if fromIntegral (V.length arr) <= i+ then Left $ "Array out of bound" <+> ttext rvname P.<> brackets (ttext rvindx)+ else evalValue (arr V.! fromIntegral i)+ PHash hs -> case hs ^. at rvindx of+ Just x -> evalValue x+ _ -> Left $ "Can't index variable" <+> ttext rvname <+> ", it is " <+> pretty (PHash hs)+ varvalue -> Left $ "Can't index variable" <+> ttext rvname <+> ", it is " <+> pretty varvalue+evalExpression _ _ (Value (Literal x)) = Right x+evalExpression mp ctx (Object (Value (Literal x))) = getVariable mp ctx x >>= evalValue+evalExpression _ _ x = Left $ "Can't evaluate" <+> pretty x++evalValue :: PValue -> Either Doc Text+evalValue (PString x) = Right x+evalValue (PNumber x) = Right (scientific2text x)+evalValue x = Right $ show x++a2i :: Text -> Maybe Integer+a2i x = case text2Scientific x of+ Just y -> y ^? _Integer+ _ -> Nothing
+ src/Erb/Parser.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE LambdaCase #-}+module Erb.Parser where++import Puppet.Prelude hiding (option, try)++import Control.Exception (catch)+import qualified Data.Text as Text+import Text.Parsec.Char+import Text.Parsec.Combinator hiding (optional)+import Text.Parsec.Error+import Text.Parsec.Expr+import Text.Parsec.Language (emptyDef)+import Text.Parsec.Pos+import Text.Parsec.Prim hiding (many, (<|>))+import Text.Parsec.String+import qualified Text.Parsec.Token as P++import Erb.Ruby++def :: P.GenLanguageDef String u Identity+def = emptyDef+ { P.commentStart = "/*"+ , P.commentEnd = "*/"+ , P.commentLine = "#"+ , P.nestedComments = True+ , P.identStart = letter+ , P.identLetter = alphaNum <|> oneOf "_"+ , P.reservedNames = ["if", "else", "case", "elsif"]+ , P.reservedOpNames= ["=>","=","+","-","/","*","+>","->","~>","!"]+ , P.caseSensitive = True+ }++lexer :: P.GenTokenParser String u Identity+lexer = P.makeTokenParser def++parens :: Parser a -> Parser a+parens = P.parens lexer++braces :: Parser a -> Parser a+braces = P.braces lexer++operator :: Parser String+operator = P.operator lexer++symbol :: String -> Parser String+symbol = P.symbol lexer++reservedOp :: String -> Parser ()+reservedOp = P.reservedOp lexer++whiteSpace :: Parser ()+whiteSpace = P.whiteSpace lexer++naturalOrFloat :: Parser (Either Integer Double)+naturalOrFloat = P.naturalOrFloat lexer++identifier :: Parser String+identifier = P.identifier lexer++rubyexpression :: Parser Expression+rubyexpression = buildExpressionParser table term <?> "expression"++table :: [[Operator String () Identity Expression]]+table = [ [ Infix ( reservedOp "+" >> return PlusOperation ) AssocLeft+ , Infix ( reservedOp "-" >> return MinusOperation ) AssocLeft ]+ , [ Infix ( reservedOp "/" >> return DivOperation ) AssocLeft+ , Infix ( reservedOp "*" >> return MultiplyOperation ) AssocLeft ]+ , [ Infix ( reservedOp "<<" >> return ShiftLeftOperation ) AssocLeft+ , Infix ( reservedOp ">>" >> return ShiftRightOperation ) AssocLeft ]+ , [ Infix ( reservedOp "and" >> return AndOperation ) AssocLeft+ , Infix ( reservedOp "or" >> return OrOperation ) AssocLeft ]+ , [ Infix ( reservedOp "==" >> return EqualOperation ) AssocLeft+ , Infix ( reservedOp "!=" >> return DifferentOperation ) AssocLeft ]+ , [ Infix ( reservedOp ">" >> return AboveOperation ) AssocLeft+ , Infix ( reservedOp ">=" >> return AboveEqualOperation ) AssocLeft+ , Infix ( reservedOp "<=" >> return UnderEqualOperation ) AssocLeft+ , Infix ( reservedOp "<" >> return UnderOperation ) AssocLeft ]+ , [ Infix ( reservedOp "=~" >> return RegexpOperation ) AssocLeft+ , Infix ( reservedOp "!~" >> return NotRegexpOperation ) AssocLeft ]+ , [ Prefix ( symbol "!" >> return NotOperation ) ]+ , [ Prefix ( symbol "-" >> return NegOperation ) ]+ , [ Infix ( reservedOp "?" >> return ConditionalValue ) AssocLeft ]+ , [ Infix ( reservedOp "." >> return MethodCall ) AssocLeft ]+ ]+term :: Parser Expression+term+ = parens rubyexpression+ <|> scopeLookup+ <|> stringLiteral+ <|> objectterm+ <|> variablereference++scopeLookup :: Parser Expression+scopeLookup = do+ void $ try $ string "scope"+ end <- (string ".lookupvar(" >> return (char ')')) <|> (char '[' >> return (char ']'))+ expr <- rubyexpression+ void end+ return $ Object expr++stringLiteral :: Parser Expression+stringLiteral = Value `fmap` (doubleQuoted <|> singleQuoted)++doubleQuoted :: Parser Value+doubleQuoted = Interpolable <$> between (char '"') (char '"') quoteInternal+ where+ quoteInternal = many (basicContent <|> interpvar <|> escaped)+ escaped = char '\\' >> (Value . Literal . Text.singleton) `fmap` anyChar+ basicContent = (Value . Literal . Text.pack) `fmap` many1 (noneOf "\"\\#")+ interpvar = do+ void $ try (string "#{")+ o <- many1 (noneOf "}")+ void $ char '}'+ return (Object (Value (Literal (Text.pack o))))++singleQuoted :: Parser Value+singleQuoted = Literal . Text.pack <$> between (char '\'') (char '\'') (many $ noneOf "'")++objectterm :: Parser Expression+objectterm = do+ void $ optional (char '@')+ methodname' <- fmap Text.pack identifier+ let methodname = Value (Literal methodname')+ lookAhead anyChar >>= \case+ '[' -> do+ hr <- many (symbol "[" *> rubyexpression <* symbol "]")+ return $! foldl LookupOperation (Object methodname) hr+ '{' -> fmap (MethodCall methodname . BlockOperation . Text.pack) (braces (many1 $ noneOf "}"))+ '(' -> fmap (MethodCall methodname . Value . Array) (parens (rubyexpression `sepBy` symbol ","))+ _ -> return $ Object methodname++variablereference :: Parser Expression+variablereference = fmap (Object . Value . Literal . Text.pack) identifier++rubystatement :: Parser RubyStatement+rubystatement = fmap Puts rubyexpression++textblockW :: Maybe Char -> Parser [RubyStatement]+textblockW c = do+ s <- many (noneOf "<")+ let ns = case c of+ Just x -> x:s+ Nothing -> s+ returned = Puts $ Value $ Literal $ Text.pack ns+ optionMaybe eof >>= \case+ Just _ -> return [returned]+ Nothing -> do+ void $ char '<'+ n <- optionMaybe (char '%') >>= \case+ Just _ -> rubyblock+ Nothing -> textblockW (Just '<')+ return (returned : n)++textblock :: Parser [RubyStatement]+textblock = textblockW Nothing++rubyblock :: Parser [RubyStatement]+rubyblock = do+ ps <- option [] (char '-' >> return [DropPrevSpace'])+ parsed <- optionMaybe (char '=') >>= \case+ Just _ -> spaces >> fmap (return . Puts) rubyexpression+ Nothing -> spaces >> many1 rubystatement+ spaces+ let dn (x:xs) = DropNextSpace x : xs+ dn x = x+ ns <- option identity (char '-' >> return dn)+ void $ string "%>"+ n <- textblock+ return (ps ++ parsed ++ ns n)++erbparser :: Parser [RubyStatement]+erbparser = textblock++parseErbFile :: FilePath -> IO (Either ParseError [RubyStatement])+parseErbFile fname = parseContent `catch` handler+ where+ parseContent = (runParser erbparser () fname . Text.unpack) `fmap` readFile fname+ handler e = let msg = show (e :: SomeException)+ in return $ Left $ newErrorMessage (Message msg) (initialPos fname)++parseErbString :: String -> Either ParseError [RubyStatement]+parseErbString = runParser erbparser () "dummy"
+ src/Erb/Ruby.hs view
@@ -0,0 +1,58 @@+-- | Base types for the internal ruby parser ("Erb.Parser").+module Erb.Ruby where++import Puppet.Prelude hiding ((<>))++import Text.PrettyPrint.ANSI.Leijen++data Value+ = Literal !Text+ | Interpolable ![Expression]+ | Symbol !Text+ | Array ![Expression]+ deriving (Show, Ord, Eq)++data Expression+ = LookupOperation !Expression !Expression+ | PlusOperation !Expression !Expression+ | MinusOperation !Expression !Expression+ | DivOperation !Expression !Expression+ | MultiplyOperation !Expression !Expression+ | ShiftLeftOperation !Expression !Expression+ | ShiftRightOperation !Expression !Expression+ | AndOperation !Expression !Expression+ | OrOperation !Expression !Expression+ | EqualOperation !Expression !Expression+ | DifferentOperation !Expression !Expression+ | AboveOperation !Expression !Expression+ | AboveEqualOperation !Expression !Expression+ | UnderEqualOperation !Expression !Expression+ | UnderOperation !Expression !Expression+ | RegexpOperation !Expression !Expression+ | NotRegexpOperation !Expression !Expression+ | NotOperation !Expression+ | NegOperation !Expression+ | ConditionalValue !Expression !Expression+ | Object !Expression+ | MethodCall !Expression !Expression+ | BlockOperation !Text+ | Value !Value+ | BTrue+ | BFalse+ | Error !String+ deriving (Show, Ord, Eq)++instance Pretty Expression where+ pretty (LookupOperation a b) = pretty a <> brackets (pretty b)+ pretty (PlusOperation a b) = parens (pretty a <+> text "+" <+> pretty b)+ pretty (MinusOperation a b) = parens (pretty a <+> text "-" <+> pretty b)+ pretty (DivOperation a b) = parens (pretty a <+> text "/" <+> pretty b)+ pretty (MultiplyOperation a b) = parens (pretty a <+> text "*" <+> pretty b)+ pretty op = text (show op)++data RubyStatement+ = Puts !Expression+ | DropPrevSpace !RubyStatement+ | DropPrevSpace'+ | DropNextSpace !RubyStatement+ deriving(Show,Eq)
+ src/Facter.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE LambdaCase #-}+module Facter where++import Prelude++import Control.Arrow+import Control.Lens+import Control.Monad.Trans.Except+import Data.Char+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import Data.List (intercalate, stripPrefix)+import Data.List.Split (splitOn)+import Data.Maybe (mapMaybe)+import qualified Data.Text as T+import Puppet.Interpreter.Types+import System.Directory (doesFileExist)+import System.Environment+import System.Posix.Unistd (SystemID (..), getSystemID)+import System.Posix.User+import Text.Printf++storageunits :: [(String, Int)]+storageunits = [ ("", 0), ("K", 1), ("M", 2), ("G", 3), ("T", 4) ]++getPrefix :: Int -> String+getPrefix n | null fltr = error $ "Could not get unit prefix for order " ++ show n+ | otherwise = fst $ head fltr+ where fltr = filter (\(_, x) -> x == n) storageunits++getOrder :: String -> Int+getOrder n | null fltr = error $ "Could not get order for unit prefix " ++ show n+ | otherwise = snd $ head fltr+ where+ nu = map toUpper n+ fltr = filter (\(x, _) -> x == nu) storageunits++normalizeUnit :: (Double, Int) -> Double -> (Double, Int)+normalizeUnit (unit, order) base | unit > base = normalizeUnit (unit/base, order + 1) base+ | otherwise = (unit, order)++storagedesc :: (String, String) -> String+storagedesc (ssize, unit) = let+ size = read ssize :: Double+ uprefix | unit == "B" = ""+ | otherwise = [head unit]+ uorder = getOrder uprefix+ (osize, oorder) = normalizeUnit (size, uorder) 1024+ in printf "%.2f %sB" osize (getPrefix oorder)++factRAM :: IO [(String, String)]+factRAM = do+ meminfo <- fmap (map words . lines) (readFile "/proc/meminfo")+ let memtotal = ginfo "MemTotal:"+ memfree = ginfo "MemFree:"+ swapfree = ginfo "SwapFree:"+ swaptotal = ginfo "SwapTotal:"+ ginfo st = sdesc $ head $ filter ((== st) . head) meminfo+ sdesc [_, size, unit] = storagedesc (size, unit)+ sdesc _ = storagedesc ("1","B")+ return [("memorysize", memtotal), ("memoryfree", memfree), ("swapfree", swapfree), ("swapsize", swaptotal)]++factNET :: IO [(String, String)]+factNET = return [("ipaddress", "192.168.0.1")]++factOS :: IO [(String, String)]+factOS = do+ islsb <- doesFileExist "/etc/lsb-release"+ isdeb <- doesFileExist "/etc/debian_version"+ case (islsb, isdeb) of+ (True, _) -> factOSLSB+ (_, True) -> factOSDebian+ _ -> return []++factOSDebian :: IO [(String, String)]+factOSDebian = fmap (toV . head . lines) (readFile "/etc/debian_version")+ where+ toV v = [ ("lsbdistid" , "Debian")+ , ("operatingsystem" , "Debian")+ , ("lsbdistrelease" , v)+ , ("operatingsystemrelease" , v)+ , ("lsbmajdistrelease" , takeWhile (/='.') v)+ , ("osfamily" , "Debian")+ , ("lsbdistcodename" , codename v)+ , ("lsbdistdescription" , "Debian GNU/Linux " ++ v ++ " (" ++ codename v ++ ")")+ ]+ codename v | null v = "unknown"+ | h '7' = "wheezy"+ | h '6' = "squeeze"+ | h '5' = "lenny"+ | h '4' = "etch"+ | v == "3.1" = "sarge"+ | v == "3.0" = "woody"+ | v == "2.2" = "potato"+ | v == "2.1" = "slink"+ | v == "2.0" = "hamm"+ | otherwise = "unknown"+ where h x = head v == x++factOSLSB :: IO [(String, String)]+factOSLSB = do+ lsb <- fmap (map (break (== '=')) . lines) (readFile "/etc/lsb-release")+ let getval st | null filterd = "?"+ | otherwise = rvalue+ where filterd = filter (\(k,_) -> k == st) lsb+ value = (tail . snd . head) filterd+ rvalue | head value == '"' = read value+ | otherwise = value+ lrelease = getval "DISTRIB_RELEASE"+ distid = getval "DISTRIB_ID"+ maj | lrelease == "?" = "?"+ | otherwise = takeWhile (/= '.') lrelease+ osfam | distid == "Ubuntu" = "Debian"+ | otherwise = distid+ return [ ("lsbdistid" , distid)+ , ("operatingsystem" , distid)+ , ("lsbdistrelease" , lrelease)+ , ("operatingsystemrelease" , lrelease)+ , ("operatingsystemmajrelease" , lrelease)+ , ("lsbmajdistrelease" , maj)+ , ("lsbminordistrelease" , "")+ , ("osfamily" , osfam)+ , ("lsbdistcodename" , getval "DISTRIB_CODENAME")+ , ("lsbdistdescription" , getval "DISTRIB_DESCRIPTION")+ ]++factMountPoints :: IO [(String, String)]+factMountPoints = do+ mountinfo <- fmap (map words . lines) (readFile "/proc/mounts")+ let ignorefs = HS.fromList+ ["NFS", "nfs", "nfs4", "nfsd", "afs", "binfmt_misc", "proc", "smbfs",+ "autofs", "iso9660", "ncpfs", "coda", "devpts", "ftpfs", "devfs",+ "mfs", "shfs", "sysfs", "cifs", "lustre_lite", "tmpfs", "usbfs", "udf",+ "fusectl", "fuse.snapshotfs", "rpc_pipefs", "configfs", "devtmpfs",+ "debugfs", "securityfs", "ecryptfs", "fuse.gvfs-fuse-daemon", "rootfs"+ ]+ goodlines = filter (\x -> not $ HS.member (x !! 2) ignorefs) mountinfo+ goodfs = map (!! 1) goodlines+ return [("mountpoints", unwords goodfs)]++fversion :: IO [(String, String)]+fversion = return [("facterversion", "0.1"),("environment","test")]++factUser :: IO [(String, String)]+factUser = do+ username <- getEffectiveUserName+ return [("id",username)]++factUName :: IO [(String, String)]+factUName = do+ SystemID sn nn rl _ mc <- getSystemID+ let vparts = splitOn "." (takeWhile (/='-') rl)+ return [ ("kernel" , sn) -- Linux+ , ("kernelmajversion" , intercalate "." (take 2 vparts)) -- 3.5+ , ("kernelrelease" , rl) -- 3.5.0-45-generic+ , ("kernelversion" , intercalate "." (take 3 vparts)) -- 3.5.0+ , ("hardwareisa" , mc) -- x86_64+ , ("hardwaremodel" , mc) -- x86_64+ , ("hostname" , nn)+ ]++fenv :: IO [(String,String)]+fenv = do+ path <- getEnv "PATH"+ return [ ("path", path) ]++factProcessor :: IO [(String,String)]+factProcessor = do+ cpuinfo <- readFile "/proc/cpuinfo"+ let cpuinfos = zip [ "processor" ++ show (n :: Int) | n <- [0..]] modelnames+ modelnames = mapMaybe (fmap (dropWhile (`elem` ("\t :" :: String))) . stripPrefix "model name") (lines cpuinfo)+ return $ ("processorcount", show (length cpuinfos)) : cpuinfos++puppetDBFacts :: NodeName -> PuppetDBAPI IO -> IO (Container PValue)+puppetDBFacts node pdbapi =+ runExceptT (getFacts pdbapi (QEqual FCertname node)) >>= \case+ Right facts@(_:_) -> return (HM.fromList (map (\f -> (f ^. factInfoName, f ^. factInfoVal)) facts))+ _ -> do+ rawFacts <- fmap concat (sequence [factNET, factRAM, factOS, fversion, factMountPoints, factOS, factUser, factUName, fenv, factProcessor])+ let ofacts = genFacts $ map (T.pack *** T.pack) rawFacts+ (hostname, ddomainname) = T.break (== '.') node+ domainname = if T.null ddomainname+ then ""+ else T.tail ddomainname+ nfacts = genFacts [ ("fqdn", node)+ , ("hostname", hostname)+ , ("domain", domainname)+ , ("rootrsa", "xxx")+ , ("operatingsystem", "Ubuntu")+ , ("puppetversion", "language-puppet")+ , ("virtual", "xenu")+ , ("clientcert", node)+ , ("is_virtual", "true")+ , ("concat_basedir", "/var/lib/puppet/concat")+ ]+ allfacts = nfacts `HM.union` ofacts+ genFacts = HM.fromList+ return (allfacts & traverse %~ PString)
+ src/Hiera/Server.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++{- | 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+ -- * Query API+ , HieraQueryFunc+) where++import Puppet.Prelude++import Control.Monad.Except+import Data.Aeson (FromJSON, Value (..), (.!=), (.:),+ (.:?))+import qualified Data.Aeson as Aeson+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 Cache+import qualified Data.List as List+import Data.String (fromString)+import qualified Data.Text as Text+import qualified Data.Vector as Vector+import qualified Data.Yaml as Yaml+import qualified System.FilePath as FilePath+import System.FilePath.Lens (directory)++import Puppet.Interpreter.Types+import Puppet.PP+++data HieraConfigFile = HieraConfigFile+ { _version :: Int+ , _backends :: [Backend]+ , _hierarchy :: [InterpolableHieraString]+ } deriving (Show)+++data Backend+ = YamlBackend FilePath+ | JsonBackend FilePath+ deriving Show++newtype InterpolableHieraString+ = InterpolableHieraString+ { getInterpolableHieraString :: [HieraStringPart]+ } deriving Show++data HieraStringPart = HPString Text+ | HPVariable Text+ deriving Show++instance Pretty HieraStringPart where+ pretty (HPString t) = ttext t+ pretty (HPVariable v) = dullred (string "%{" <> ttext v <> string "}")+ prettyList = mconcat . map pretty++type Cache = Cache.FileCacheR String Value++data QRead+ = QRead+ { _qvars :: Container Text+ , _qtype :: HieraQueryType+ , _qhier :: [Value]+ }++makeClassy ''HieraConfigFile+makeLenses ''QRead++instance FromJSON HieraConfigFile where+ parseJSON =+ let+ mkHiera5 v = do+ [hierarchy_value] <- v .: "hierarchy"+ datadir <- case Object v ^? key "defaults" . key "datadir" of+ Just (String dir) -> pure dir+ Just _ -> fail ("datadir should be a string")+ Nothing -> hierarchy_value .: "datadir" .!= "hieradata"+ HieraConfigFile+ <$> pure 5+ <*> pure [ YamlBackend (toS datadir) ] -- TODO: support other backends if needed+ <*> (hierarchy_value .:? "paths" .!= [InterpolableHieraString [HPString "common.yaml"]])+ mkHiera3 v =+ HieraConfigFile+ <$> pure 3+ <*> (v .:? ":backends" .!= ["yaml"] >>= mapM mkBackend3)+ <*> (v .:? ":hierarchy" .!= [InterpolableHieraString [HPString "common"]])+ where+ mkBackend3 :: Text -> Yaml.Parser Backend+ mkBackend3 name = do+ (backendConstructor, skey) <- case name of+ "yaml" -> return (YamlBackend, ":yaml")+ "json" -> return (JsonBackend, ":json")+ _ -> fail ("Unknown backend " ++ Text.unpack name)+ datadir <- case Object v ^? key skey . key ":datadir" of+ Just (String dir) -> return dir+ Just _ -> fail ":datadir should be a string"+ Nothing -> return "/etc/puppet/hieradata"+ pure (backendConstructor (Text.unpack datadir))++ in+ Aeson.withObject "v3 or v5" $ \o -> do+ o .:? "version" >>= \case+ Just (5::Int) -> mkHiera5 o+ Just _ -> fail "Hiera configuration version different than 5 is not supported."+ Nothing -> mkHiera3 o++instance FromJSON InterpolableHieraString where+ parseJSON (String s) = case parseInterpolableString s of+ Right x -> return (InterpolableHieraString x)+ Left rr -> fail rr+ parseJSON _ = fail "Invalid value type"+++-- | An attoparsec parser that turns text into parts that are ready for interpolation+interpolableString :: AT.Parser [HieraStringPart]+interpolableString = AT.many1 (fmap HPString rawPart <|> fmap HPVariable interpPart)+ where+ rawPart = AT.takeWhile1 (/= '%')+ interpPart = AT.string "%{" *> AT.takeWhile1 (/= '}') <* AT.char '}'++parseInterpolableString :: Text -> Either String [HieraStringPart]+parseInterpolableString = AT.parseOnly interpolableString++-- | The only method you'll ever need. It runs a Hiera server and gives you a querying function.+-- | All IO exceptions are thrown directly including ParsingException.+startHiera :: FilePath -> IO (HieraQueryFunc IO)+startHiera fp =+ Yaml.decodeFileEither fp >>= \case+ Left (Yaml.AesonException "Error in $: Hiera configuration version different than 5 is not supported.") -> do+ logInfoStr ("Detect a hiera configuration format in " <> fp <> " at version 4. This format is not recognized. Using a dummy hiera.")+ pure dummyHiera+ Left ex -> panic (show ex)+ Right cfg -> do+ logInfoStr ("Detect a hiera configuration format in " <> fp <> " at version " <> show(cfg^.version))+ cache <- Cache.newFileCache+ pure (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 Nothing++resolveString :: Container Text -> InterpolableHieraString -> Maybe Text+resolveString vars = fmap Text.concat . mapM resolve . getInterpolableHieraString+ where+ resolve (HPString x) = Just x+ resolve (HPVariable v) = vars ^? ix v++query :: HieraConfigFile -> FilePath -> Cache -> HieraQueryFunc IO+query HieraConfigFile {_version, _backends, _hierarchy} fp cache vars hquery qt = do+ -- step 1, resolve hierarchies+ let searchin = do+ mhierarchy <- resolveString vars <$> _hierarchy+ Just h <- [mhierarchy]+ backend <- _backends+ let decodeInfo :: (FilePath -> IO (S.Either String Value), String, String)+ decodeInfo = do+ case backend of+ JsonBackend dir -> (fmap (strictifyEither . Aeson.eitherDecode') . BS.readFile , dir, ".json")+ YamlBackend dir -> (fmap (strictifyEither . (_Left %~ show)) . Yaml.decodeFileEither, dir, ".yaml")+ return (decodeInfo, Text.unpack h)+ -- step 2, read all the files, returning a raw data structure+ mvals <- forM searchin $ \((decodefunction, datadir, extension), h) -> do+ let extension' = if snd (FilePath.splitExtension h) == ".yaml"+ then ""+ else extension+ filename = basedir <> datadir <> "/" <> h <> extension'+ basedir = case datadir of+ '/' : _ -> mempty+ _ -> fp ^. directory <> "/"+ efilecontent <- Cache.query cache filename (decodefunction filename)+ case efilecontent of+ S.Left r -> do+ let errs = "Hiera: error when reading file " <> string filename <+> string r+ if "Yaml file not found: " `List.isInfixOf` r+ then logDebug (show errs)+ else logWarning (show errs)+ return Nothing+ S.Right val -> return (Just val)+ let vals = catMaybes mvals+ -- step 3, query through all the results+ return (strictifyEither $ runReader (runExceptT (recursiveQuery hquery [])) (QRead vars qt vals))++type QM a = ExceptT PrettyError (Reader QRead) a++checkLoop :: Text -> [Text] -> QM ()+checkLoop x xs =+ when (x `elem` xs) (throwError ("Loop in hiera: " <> fromString (Text.unpack (Text.intercalate ", " (x:xs)))))++recursiveQuery :: Text -> [Text] -> QM (Maybe PValue)+recursiveQuery curquery prevqueries = do+ checkLoop curquery prevqueries+ rawlookups <- mapMaybe (preview (key curquery)) <$> view qhier+ lookups <- mapM (resolveValue (curquery : prevqueries)) rawlookups+ case lookups of+ [] -> return Nothing+ (x:xs) -> do+ qt <- view qtype+ let evalue = foldM (mergeWith qt) x xs+ case Aeson.fromJSON <$> evalue of+ Left _ -> return Nothing+ Right (Aeson.Success o) -> return o+ Right (Aeson.Error rr) -> throwError ("Something horrible happened in recursiveQuery: " <> fromString (show rr))++resolveValue :: [Text] -> Value -> QM Value+resolveValue prevqueries value =+ case value of+ String t -> String <$> resolveText prevqueries t+ Array arr -> Array <$> mapM (resolveValue prevqueries) arr+ Object hh -> Object <$> mapM (resolveValue prevqueries) hh+ _ -> return value++resolveText :: [Text] -> Text -> QM Text+resolveText prevqueries t+ = case parseInterpolableString t of+ Right qparts -> Text.concat <$> mapM (resolveStringPart prevqueries) qparts+ Left _ -> return t++resolveStringPart :: [Text] -> HieraStringPart -> QM Text+resolveStringPart prevqueries sp+ = case sp of+ HPString s -> return s+ HPVariable varname -> do+ let varsolve = fmap PString . preview (ix varname) <$> view qvars+ r <- case Text.stripPrefix "lookup('" varname >>= Text.stripSuffix "')" of+ Just lk -> recursiveQuery lk prevqueries+ Nothing -> varsolve+ case r of+ Just (PString v) -> return v+ _ -> return mempty++mergeWith :: HieraQueryType -> Value -> Value -> Either PrettyError Value+mergeWith qt cur new+ = case qt of+ QFirst -> return cur+ QUnique ->+ let getArray x = case x of+ Array array -> Vector.toList array+ _ -> [x]+ curarray = getArray cur+ newarray = getArray new+ in case new of+ Object _ -> throwError "Tried to merge a hash"+ _ -> return (Array (Vector.fromList (List.nub (curarray ++ newarray))))+ QHash -> case (cur, new) of+ (Object curh, Object newh) -> return (Object (curh <> newh))+ _ -> throwError (PrettyError ("Tried to merge things that are not hashes: " <> text (show cur) <+> text (show new)))+ QDeep{} -> throwError "deep queries not supported"
+ src/Puppet/Daemon.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TupleSections #-}+module Puppet.Daemon (+ Daemon(..)+ , initDaemon+ -- * Utils+ , checkError+ -- * Re-exports+ , module Puppet.Interpreter.Types+ , module Puppet.PP+) where++import Puppet.Prelude++import qualified Data.Either.Strict as S+import Data.FileCache as FileCache+import qualified Data.HashMap.Strict as HM+import qualified Data.List as List+import qualified Data.Text as Text+import qualified Data.Vector as V+import Debug.Trace (traceEventIO)+import Foreign.Ruby.Safe+import qualified System.Directory as Directory+import qualified System.Log.Formatter as Log (simpleLogFormatter)+import qualified System.Log.Handler as Log (setFormatter)+import qualified System.Log.Handler.Simple as Log (streamHandler)+import qualified System.Log.Logger as Log+import qualified Text.Megaparsec as Megaparsec++import Erb.Compute+import Hiera.Server+import Puppet.Interpreter+import Puppet.Interpreter.IO+import Puppet.Interpreter.Types+import Puppet.Lens (_PrettyError)+import Puppet.Manifests+import Puppet.OptionalTests+import Puppet.Parser+import Puppet.Parser.Types+import Puppet.PP+import Puppet.Preferences+import Puppet.Stats+++{-| API for the Daemon.+The main method is `getCatalog`: given a node and a list of facts, it returns the result of the compilation.+This will be either an error, or a tuple containing:++- all the resources in this catalog+- the dependency map+- the exported resources+- a list of known resources, that might not be up to date, but are here for code coverage tests.++Notes :++* It might be buggy when top level statements that are not class\/define\/nodes are altered.+-}+data Daemon = Daemon+ { getCatalog :: NodeName -> Facts -> IO (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))+ , parserStats :: MStats+ , catalogStats :: MStats+ , templateStats :: MStats+ }++{-| Entry point to get a Daemon+It will initialize the parsing and interpretation infrastructure from the 'Preferences'.++Internally it initializes a thread for the Ruby interpreter.+It should cache the AST of every .pp file, and could use a bit of memory. As a comparison, it+fits in 60 MB with the author's manifests, but really breathes when given 300 MB+of heap space. In this configuration, even if it spawns a ruby process for every+template evaluation, it is way faster than the puppet stack.++It can optionally talk with PuppetDB, by setting an URL via the 'prefPDB'.+The recommended way to set it to http://localhost:8080 and set a SSH tunnel :++> ssh -L 8080:localhost:8080 puppet.host+-}+initDaemon :: Preferences IO+ -> IO Daemon+initDaemon pref = do+ setupLogger (pref ^. prefLogLevel)+ logDebug "Initialize daemon"+ traceEventIO "initDaemon"+ hquery <- hQueryApis pref+ fcache <- newFileCache+ intr <- startRubyInterpreter+ templStats <- newStats+ getTemplate <- initTemplateDaemon intr pref templStats+ catStats <- newStats+ parseStats <- newStats+ return (Daemon+ (getCatalog' pref (parseFunc (pref ^. prefPuppetPaths) fcache parseStats) getTemplate catStats hquery)+ parseStats+ catStats+ templStats+ )++hQueryApis :: Preferences IO -> IO (HieraQueryLayers IO)+hQueryApis pref = do+ api0 <- case pref ^. prefHieraPath of+ Just p -> startHiera p+ Nothing -> pure dummyHiera+ modapis <- getModApis pref+ pure (HieraQueryLayers api0 modapis)++getModApis :: Preferences IO -> IO (Container (HieraQueryFunc IO))+getModApis pref = do+ let ignored_modules = pref^.prefIgnoredmodules+ modpath = pref^.prefPuppetPaths.modulesPath+ dirs <- Directory.listDirectory modpath+ (HM.fromList . catMaybes) <$>+ for dirs (\dir -> runMaybeT $ do+ let modname = toS dir+ path = modpath <> "/" <> dir <> "/hiera.yaml"+ guard (modname `notElem` ignored_modules)+ guard =<< liftIO (Directory.doesFileExist path)+ liftIO $ (modname, ) <$> startHiera path)++-- | In case of a Left value, print the error and exit immediately+checkError :: Show e => Doc -> Either e a -> IO a+checkError desc = either exit return+ where+ exit = \err -> putDoc (display err) >> exitFailure+ display err = red desc <> ": " <+> (string . show) err+++-- Internal functions++getCatalog' :: Preferences IO+ -> ( TopLevelType -> Text -> IO (S.Either PrettyError Statement) )+ -> (Either Text Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text))+ -> MStats+ -> HieraQueryLayers IO+ -> NodeName+ -> Facts+ -> IO (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))+getCatalog' pref parsingfunc getTemplate stats hquery node facts = do+ logDebug ("Received query for node " <> node)+ traceEventIO ("START getCatalog' " <> Text.unpack node)+ let catalogComputation = interpretCatalog (InterpreterReader+ (pref ^. prefNatTypes)+ parsingfunc+ getTemplate+ (pref ^. prefPDB)+ (pref ^. prefExtFuncs)+ node+ hquery+ defaultImpureMethods+ (pref ^. prefIgnoredmodules)+ (pref ^. prefExternalmodules)+ (pref ^. prefStrictness == Strict)+ (pref ^. prefPuppetPaths)+ (pref ^. prefRebaseFile)+ )+ node+ facts+ (pref ^. prefPuppetSettings)+ (stmts :!: warnings) <- measure stats node catalogComputation+ mapM_ (\(p :!: m) -> Log.logM loggerName p (displayS (renderCompact (ttext node <> ":" <+> m)) "")) warnings+ traceEventIO ("STOP getCatalog' " <> Text.unpack node)+ if pref ^. prefExtraTests+ then runOptionalTests stmts+ else pure stmts+ where+ runOptionalTests stm = case stm ^? _Right._1 of+ Nothing -> pure stm+ (Just c) -> catching _PrettyError+ (do {testCatalog pref c; pure stm})+ (pure . Left)++-- | Return an HOF that would parse the file associated with a toplevel.+-- The toplevel is defined by the tuple (type, name)+-- The result of the parsing is a single Statement (which recursively contains others statements)+parseFunc :: PuppetDirPaths -> FileCache (V.Vector Statement) -> MStats -> TopLevelType -> Text -> IO (S.Either PrettyError Statement)+parseFunc ppath filecache stats = \toptype topname ->+ let nameparts = Text.splitOn "::" topname in+ let topLevelFilePath :: TopLevelType -> Text -> Either PrettyError Text+ topLevelFilePath TopNode _ = Right $ Text.pack (ppath^.manifestPath <> "/site.pp")+ topLevelFilePath _ name+ | length nameparts == 1 = Right $ Text.pack (ppath^.modulesPath) <> "/" <> name <> "/manifests/init.pp"+ | null nameparts = Left $ PrettyError ("Invalid toplevel" <+> squotes (ttext name))+ | otherwise = Right $ Text.pack (ppath^.modulesPath) <> "/" <> List.head nameparts <> "/manifests/" <> Text.intercalate "/" (List.tail nameparts) <> ".pp"+ in+ case topLevelFilePath toptype topname of+ Left rr -> return (S.Left rr)+ Right fname -> do+ let sfname = Text.unpack fname+ handleFailure :: SomeException -> IO (S.Either String (V.Vector Statement))+ handleFailure e = return (S.Left (show e))+ x <- measure stats fname (FileCache.query filecache sfname (parseFile sfname `catch` handleFailure))+ case x of+ S.Right stmts -> filterStatements toptype topname stmts+ S.Left rr -> return (S.Left (PrettyError (red (text rr))))+++parseFile :: FilePath -> IO (S.Either String (V.Vector Statement))+parseFile fname = do+ traceEventIO ("START parsing " ++ fname)+ cnt <- readFile fname+ o <- case runPParser fname cnt of+ Right r -> traceEventIO ("Stopped parsing " ++ fname) >> return (S.Right r)+ Left rr -> traceEventIO ("Stopped parsing " ++ fname ++ " (failure: " ++ Megaparsec.parseErrorPretty rr ++ ")") >> return (S.Left (Megaparsec.parseErrorPretty rr))+ traceEventIO ("STOP parsing " ++ fname)+ return o+++setupLogger :: Log.Priority -> IO ()+setupLogger p = do+ Log.updateGlobalLogger loggerName (Log.setLevel p)+ hs <- consoleLogHandler+ Log.updateGlobalLogger Log.rootLoggerName $ Log.setHandlers [hs]+ where+ consoleLogHandler = Log.setFormatter+ <$> Log.streamHandler stdout Log.DEBUG+ <*> pure (Log.simpleLogFormatter "$prio: $msg")
+ src/Puppet/Interpreter.hs view
@@ -0,0 +1,960 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+module Puppet.Interpreter+ ( interpretCatalog+ , evaluateStatement+ , computeCatalog+ ) where++import Puppet.Prelude++import Control.Monad.Operational hiding (view)+import qualified Data.Char as Char+import qualified Data.Graph as G+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.List as List+import qualified Data.Maybe.Strict as S+import Data.Semigroup (Max (..))+import qualified Data.Text as Text+import qualified Data.Tree as Tree+import qualified Data.Vector as V+import qualified System.Log.Logger as Log++import Puppet.Interpreter.IO+import Puppet.Interpreter.PrettyPrinter (containerComma)+import Puppet.Interpreter.Resolve+import Puppet.Interpreter.Types+import Puppet.Interpreter.Utils+import Puppet.Lens+import Puppet.NativeTypes+import Puppet.Parser.PrettyPrinter+import Puppet.Parser.Types+import Puppet.Parser.Utils+import Puppet.PP++{-| Call the operational 'interpretMonad' function to compute the catalog.+ Returns either an error, or a tuple containing all the resources,+ dependency map, exported resources, and defined resources alongside with+ all messages that have been generated by the compilation process.++ The later 'definedResources' (eg. all class declarations) are pulled out of the+ 'InterpreterState' and might not be up to date.+ There are only useful for coverage testing (checking dependencies for instance).+-}+interpretCatalog :: Monad m+ => InterpreterReader m -- ^ The whole environment required for computing catalog.+ -> NodeName+ -> Facts+ -> Container Text -- ^ Server settings+ -> m (Pair (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Log.Priority Doc])+interpretCatalog r node facts settings = do+ (output, _, warnings) <- interpretMonad r (initialState facts settings) (computeCatalog node)+ pure (output :!: warnings)++isParent :: Text -> CurContainerDesc -> InterpreterMonad Bool+isParent cur (ContClass possibleparent) =+ preuse (scopes . ix cur . scopeParent) >>= \case+ Nothing -> throwPosError ("Internal error: could not find scope" <+> ttext cur <+> "possible parent" <+> ttext possibleparent)+ Just S.Nothing -> return False+ Just (S.Just p) -> if p == possibleparent+ then return True+ else isParent p (ContClass possibleparent)+isParent _ _ = return False++-- | Apply resource defaults, references overrides and expand defines+finalize :: [Resource] -> InterpreterMonad [Resource]+finalize rx = do+ scp <- getScopeName+ resdefaults <- use (scopes . ix scp . scopeResDefaults)+ let getOver = use (scopes . ix scp . scopeOverrides) -- retrieves current overrides+ addResDefaults r = ifoldlM (addAttribute CantReplace) r resdefval+ where resdefval = resdefaults ^. ix (r ^. rid . itype) . resDefValues+ addOverrides r = getOver >>= foldlM addOverrides' r . view (at (r ^. rid))+ addOverrides' r (ResRefOverride _ prms p) = do+ -- we used this override, so we discard it+ scopes . ix scp . scopeOverrides . at (r ^. rid) .= Nothing+ let forb msg = throwPosError ("Override of parameters ("+ <> list (map (ttext . fst) $ itoList prms)+ <> ") of the following resource is forbidden in the current context:"+ </> pretty r+ <+> showPPos p+ </> ":"+ <+> msg)+ s <- getScope+ overrideType <- case r ^. rscope of+ [] -> forb "Could not find the current resource context" -- we could not get the current resource context+ (x:_) -> if x == s+ then return CantOverride -- we are in the same context : can't replace, but add stuff+ else isParent (scopeName s) x >>= \i ->+ if i || (r ^. rid . itype == "class")+ then return Replace -- we can override what's defined in a parent+ else forb "Can't override something that was not defined in the parent."+ ifoldlM (addAttribute overrideType) r prms+ -- step 1, apply resDefaults and resRefOverride+ withDefaults <- mapM (addOverrides >=> addResDefaults) rx+ -- There might be some overrides that could not be applied. The only+ -- valid reason is that they override something in exported resources.+ --+ -- it probably do something unexpected on defines, but let's keep it that way for now.+ let keepforlater (ResRefOverride resid resprms ropos) = resMod %= (appended : )+ where+ appended = ResourceModifier (resid ^. itype) ModifierMustMatch DontRealize (REqualitySearch "title" (PString (resid ^. iname))) overrider ropos+ overrider r = do+ -- we must define if we can override the value+ let canOverride = CantOverride -- TODO check inheritance+ ifoldlM (addAttribute canOverride) r resprms+ void $ getOver >>= mapM keepforlater+ let expandableDefine r = do+ n <- isNativeType (r ^. rid . itype)+ -- if we have a native type, or a virtual/exported resource it+ -- should not be expanded !+ if n || r ^. rvirtuality /= Normal+ then return [r]+ else expandDefine r+ -- Now that all defaults / override have been applied, the defines can+ -- finally be expanded.+ -- The reason it has to be there is that parameters of the define could+ -- be affected.+ concat <$> mapM expandableDefine withDefaults+ where+ expandDefine :: Resource -> InterpreterMonad [Resource]+ expandDefine r =+ let modulename = getModulename (r ^. rid)+ in isIgnoredModule modulename >>= \i ->+ if i+ then return mempty+ else do+ let deftype = dropInitialColons (r ^. rid . itype)+ defname = r ^. rid . iname+ curContType = ContDefine deftype defname (r ^. rpos)+ p <- use curPos+ -- we add the relations of this define to the global list of relations+ -- before dropping it, so that they are stored for the final+ -- relationship resolving+ let extr = do+ (dstid, linkset) <- itoList (r ^. rrelations)+ linktype <- toList linkset+ return (LinkInformation (r ^. rid) dstid linktype p)+ extraRelations <>= extr+ void $ enterScope SENormal curContType modulename p+ (spurious, stmt) <- interpretTopLevel TopDefine deftype+ DefineDecl _ defineParams stmts cp <- extractPrism "expandDefine" _DefineDecl stmt+ let isImported (ContImported _) = True+ isImported _ = False+ isImportedDefine <- isImported <$> getScope+ curPos .= r ^. rpos+ curscp <- getScope+ when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp ))+ pushScope curContType+ loadVariable "title" (PString defname)+ loadVariable "name" (PString defname)+ -- not done through loadvariable because of override errors+ loadParameters (r ^. rattributes) defineParams cp S.Nothing+ curPos .= cp+ res <- evaluateStatementsFoldable stmts+ out <- finalize (spurious ++ res)+ when isImportedDefine popScope+ popScope+ return out++-- | Given a toplevel (type, name),+-- return the associated parsed statement together with its evaluated resources+interpretTopLevel :: TopLevelType -> Text -> InterpreterMonad ([Resource], Statement)+interpretTopLevel toptype topname =+ -- check if this is a known toplevel+ use (nestedDeclarations . at (toptype, topname)) >>= \case+ Just x -> return ([], x) -- it is known !+ Nothing -> singleton (GetStatement toptype topname) >>= evalTopLevel+ where+ evalTopLevel :: Statement -> InterpreterMonad ([Resource], Statement)+ evalTopLevel (TopContainer tops s) = do+ pushScope ContRoot+ r <- mapM evaluateStatement tops >>= finalize . concat+ -- popScope+ (nr, ns) <- evalTopLevel s+ popScope+ return (r <> nr, ns)+ evalTopLevel x = return ([], x)++-- | Main internal entry point, this function completes the interpretation+-- TODO: add some doc here+computeCatalog :: NodeName -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource])+computeCatalog nodename = do+ (topres, stmt) <- interpretTopLevel TopNode nodename+ nd <- extractPrism "computeCatalog" _NodeDecl stmt+ let finalStep [] = return []+ finalStep allres = do+ -- collect stuff and apply thingies+ (realized :!: modified) <- realize allres+ -- we need to run it again against collected stuff, especially+ -- for custom types (defines) that have been realized+ refinalized <- finalize (toList modified) >>= finalStep+ -- replace the modified stuff+ let res = foldl' (\curm e -> curm & at (e ^. rid) ?~ e) realized refinalized+ return (toList res)++ mainstage = Resource (RIdentifier "stage" "main") mempty mempty mempty [ContRoot] Normal mempty dummyppos nodename++ evaluateNode :: NodeDecl -> InterpreterMonad [Resource]+ evaluateNode (NodeDecl _ sx inheritnode p) = do+ curPos .= p+ pushScope ContRoot+ unless (S.isNothing inheritnode) $ throwPosError "Node inheritance is not handled. It is deprecated since puppet v4"+ mapM evaluateStatement sx >>= finalize . concat++ noderes <- evaluateNode nd >>= finalStep . (++ (mainstage : topres))+ let (real :!: exported) = foldl' classify (mempty :!: mempty) noderes+ -- Classify sorts resources between exported and normal ones. It+ -- drops virtual resources, and puts in both categories resources+ -- that are at the same time exported and realized.+ classify :: Pair (HM.HashMap RIdentifier Resource) (HM.HashMap RIdentifier Resource)+ -> Resource+ -> Pair (HM.HashMap RIdentifier Resource) (HM.HashMap RIdentifier Resource)+ classify (curr :!: cure) r =+ let i curm = curm & at (r ^. rid) ?~ r+ in case r ^. rvirtuality of+ Normal -> i curr :!: cure+ Exported -> curr :!: i cure+ ExportedRealized -> i curr :!: i cure+ _ -> curr :!: cure+ verified <- HM.fromList . map (\r -> (r ^. rid, r)) <$> mapM validateNativeType (HM.elems real)+ withResourceDependentRelations <- traverse getResourceDependentRelations verified+ edgemap <- makeEdgeMap withResourceDependentRelations+ definedRes <- use definedResources+ return (withResourceDependentRelations, edgemap, exported, HM.elems definedRes)++-- | This extracts additional relationships between resources, that are+-- dependent on whether some resources are defined. A canonical example is+-- is the 'owner' field in a File, that can create problems if it's+-- defined!+--+-- For this reason, this function only adds dependencies when the resources+-- are defined.+getResourceDependentRelations :: Resource -> InterpreterMonad Resource+getResourceDependentRelations res =+ extract+ $ case res ^. rid . itype of+ "file" -> [depOn "user" "owner", depOn "group" "group"]+ "cron" -> [depOn "user" "user"]+ "exec" -> [depOn "user" "user", depOn "group" "group"]+ _ -> []+ where+ extract actions = do+ newrelations <- fmap (foldl' (HM.unionWith (<>)) (res ^. rrelations)) (sequence actions)+ return (res & rrelations .~ newrelations)+ depOn :: Text -> Text -> InterpreterMonad (HM.HashMap RIdentifier (HS.HashSet LinkType))+ depOn resType attributeName =+ case res ^? rattributes . ix attributeName of+ Just (PString usr) -> do+ let targetResourceId = RIdentifier resType usr+ existing <- has (ix targetResourceId) <$> use definedResources+ return $+ if existing+ then HM.singleton targetResourceId (HS.singleton RRequire)+ else HM.empty+ _ -> return HM.empty++makeEdgeMap :: FinalCatalog -> InterpreterMonad EdgeMap+makeEdgeMap ct = do+ -- merge the loaded classes and resources+ defs' <- HM.map (view rpos) <$> use definedResources+ clss' <- use loadedClasses+ let defs = defs' <> classes' <> aliases' <> names'+ names' = HM.map (view rpos) ct+ -- generate fake resources for all extra aliases+ aliases' = ifromList $ do+ r <- ct ^.. traversed :: [Resource]+ extraAliases <- r ^.. ralias . folded . filtered (/= r ^. rid . iname) :: [Text]+ return (r ^. rid & iname .~ extraAliases, r ^. rpos)+ classes' = ifromList $ do+ (cn, _ :!: cp) <- itoList clss'+ return (RIdentifier "class" cn, cp)+ -- Preparation step : all relations to a container become relations to+ -- the stuff that's contained. We build a map of resources, stored by+ -- container.+ -- step 1 - add relations that are stored in resources+ let reorderlink :: (RIdentifier, RIdentifier, LinkType) -> (RIdentifier, RIdentifier, LinkType)+ reorderlink (s, d, RRequire) = (d, s, RBefore)+ reorderlink (s, d, RSubscribe) = (d, s, RNotify)+ reorderlink x = x+ addRR curmap r = iunionWith (<>) curmap newmap+ where+ -- compute the explicit resources, along with the container relationship+ newmap = ifromListWith (<>) resresources+ resid = r ^. rid+ respos = r ^. rpos+ resresources :: [(RIdentifier, [LinkInformation])]+ resresources = do+ (rawdst, lts) <- itoList (r ^. rrelations)+ lt <- toList lts+ let (nsrc, ndst, nlt) = reorderlink (resid, rawdst, lt)+ return (nsrc, [LinkInformation nsrc ndst nlt respos])+ step1 :: HM.HashMap RIdentifier [LinkInformation]+ step1 = foldl' addRR mempty ct+ -- step 2 - add other relations (mainly stuff made from the "->"+ -- operator)+ let realign (LinkInformation s d t p) =+ let (ns, nd, nt) = reorderlink (s, d, t)+ in (ns, [LinkInformation ns nd nt p])+ rels <- map realign <$> use extraRelations+ let step2 = iunionWith (<>) step1 (ifromList rels)+ -- check that all resources are defined, and build graph+ let checkResDef :: (RIdentifier, [LinkInformation]) -> InterpreterMonad (RIdentifier, RIdentifier, [RIdentifier])+ checkResDef (ri, lifs) = do+ let checkExists r msg = do+ let modulename = getModulename r+ is_ignored <- isIgnoredModule modulename+ unless (has (ix r) defs || is_ignored) (throwPosError msg)+ errmsg = "Unknown resource" <+> pretty ri <+> "used in the following relationships:" <+> vcat (map pretty lifs)+ checkExists ri errmsg+ let genlnk :: LinkInformation -> InterpreterMonad RIdentifier+ genlnk lif = do+ let d = lif ^. linkdst+ checkExists d ("Unknown resource" <+> pretty d <+> "used in a relation at" <+> showPPos (lif ^. linkPos))+ return d+ ds <- mapM genlnk lifs+ return (ri, ri, ds)+ edgeList <- mapM checkResDef (itoList step2)+ let (graph, gresolver) = G.graphFromEdges' edgeList+ -- now check for scc+ let sccs = filter ((>1) . length . Tree.flatten) (G.scc graph)+ unless (null sccs) $ do+ let trees = vcat (map showtree sccs)+ showtree = indent 2 . vcat . map (mkp . gresolver) . Tree.flatten+ mkp (a,_,links) = resdesc <+> lnks+ where+ resdesc = case ct ^. at a of+ Just r -> pretty r+ _ -> pretty a+ lnks = pretty links+ throwPosError $ "Dependency error, the following resources are strongly connected!" </> trees+ -- let edgePairs = concatMap (\(_,k,ls) -> [(k,l) | l <- ls]) edgeList+ -- throwPosError (vcat (map (\(RIdentifier st sn, RIdentifier dt dn) -> "\"" <> ttext st <> ttext sn <> "\" -> \"" <> ttext dt <> ttext dn <> "\"") edgePairs))+ return step2++-- | This functions performs all the actions triggered by calls to the+-- realize function or other collectors. It returns a pair of+-- "finalcatalogs", where the first part is the new catalog, and the second+-- part the map of all modified resources. The second part is needed so+-- that we know for example which resources we should test for expansion+-- (custom types).+realize :: [Resource] -> InterpreterMonad (Pair FinalCatalog FinalCatalog)+realize rs = do+ let -- rma is the initial map of resources, indexed by resource identifier+ rma = ifromList (map (\r -> (r ^. rid, r)) rs)+ -- mutate runs all the resource modifiers (ie. realize, overrides+ -- and other collectors). It stores the modified resources on the+ -- "right" of the resulting pair.+ mutate :: Pair FinalCatalog FinalCatalog -> ResourceModifier -> InterpreterMonad (Pair FinalCatalog FinalCatalog)+ mutate (curmap :!: modified) rmod = do+ let filtrd = curmap ^.. folded . filtered fmod -- all the resources that match the selector/realize criteria+ vcheck f r = f (r ^. rvirtuality)+ (isGoodvirtuality, alterVirtuality) = case rmod ^. rmType of+ RealizeVirtual -> (vcheck (/= Exported), \r -> return (r & rvirtuality .~ Normal))+ RealizeCollected -> (vcheck (`elem` [Exported, ExportedRealized]), \r -> return (r & rvirtuality .~ ExportedRealized))+ DontRealize -> (vcheck (`elem` [Normal, ExportedRealized]), return)+ fmod r = (r ^. rid . itype == rmod ^. rmResType) && checkSearchExpression (rmod ^. rmSearch) r && isGoodvirtuality r+ mutation = alterVirtuality >=> rmod ^. rmMutation+ applyModification :: Pair FinalCatalog FinalCatalog -> Resource -> InterpreterMonad (Pair FinalCatalog FinalCatalog)+ applyModification (cma :!: cmo) r = do+ nr <- mutation r+ let i m = m & at (nr ^. rid) ?~ nr+ return $ if nr /= r+ then i cma :!: i cmo+ else cma :!: cmo+ result <- foldM applyModification (curmap :!: modified) filtrd -- apply the modifiation to all the matching resources+ when (rmod ^. rmModifierType == ModifierMustMatch && null filtrd) (throwError (PrettyError ("Could not apply this resource override :" <+> pretty rmod <> ",no matching resource was found.")))+ return result+ equalModifier (ResourceModifier a1 b1 c1 d1 _ e1) (ResourceModifier a2 b2 c2 d2 _ e2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2+ result <- use resMod >>= foldM mutate (rma :!: mempty) . reverse . List.nubBy equalModifier+ resMod .= []+ pure result++-- | Fold all attribute declarations+-- checking for duplicates key locally inside a same resource.+fromAttributeDecls :: Vector AttributeDecl -> InterpreterMonad (Container PValue)+fromAttributeDecls =+ foldM resolve mempty+ where+ resolve acc (AttributeDecl k _ v) =+ case acc ^. at k of+ Just _ -> throwPosError ("Parameter" <+> dullyellow (ttext k) <+> "already defined!")+ Nothing -> do+ pv <- resolveExpression v+ return (acc & at k ?~ pv)++saveCaptureVariables :: InterpreterMonad (HM.HashMap Text (Pair (Pair PValue PPosition) CurContainerDesc))+saveCaptureVariables = do+ scp <- getScopeName+ vars <- use (scopes . ix scp . scopeVariables)+ return $ HM.filterWithKey (\k _ -> Text.all Char.isDigit k) vars++restoreCaptureVariables :: HM.HashMap Text (Pair (Pair PValue PPosition) CurContainerDesc) -> InterpreterMonad ()+restoreCaptureVariables vars = do+ scp <- getScopeName+ scopes . ix scp . scopeVariables %= HM.union vars . HM.filterWithKey (\k _ -> not (Text.all Char.isDigit k))++evaluateStatement :: Statement -> InterpreterMonad [Resource]+evaluateStatement r@(ClassDeclaration (ClassDecl cname _ _ _ _)) =+ if "::" `Text.isInfixOf` cname+ then nestedDeclarations . at (TopClass, cname) ?= r >> return []+ else do+ scp <- getScopeName+ let rcname = if scp == "::"+ then cname+ else scp <> "::" <> cname+ nestedDeclarations . at (TopClass, rcname) ?= r+ return []+evaluateStatement r@(DefineDeclaration (DefineDecl dname _ _ _)) =+ if "::" `Text.isInfixOf` dname+ then nestedDeclarations . at (TopDefine, dname) ?= r >> return []+ else do+ scp <- getScopeName+ if scp == "::"+ then nestedDeclarations . at (TopDefine, dname) ?= r >> return []+ else nestedDeclarations . at (TopDefine, scp <> "::" <> dname) ?= r >> return []+evaluateStatement r@(ResourceCollectionDeclaration (ResCollDecl ct rtype searchexp mods p)) = do+ curPos .= p+ unless (isEmpty mods || ct == Collector)+ (throwPosError ("It doesn't seem possible to amend attributes with an exported resource collector:" </> pretty r))+ when (rtype == "class") (throwPosError "Classes cannot be collected")+ rsearch <- resolveSearchExpression searchexp+ let et = case ct of+ Collector -> RealizeVirtual+ ExportedCollector -> RealizeCollected+ resMod %= (ResourceModifier rtype ModifierCollector et rsearch (\r' -> foldM modifyCollectedAttribute r' mods) p : )+ -- Now collected from the PuppetDB !+ if et == RealizeCollected+ then do+ let q = searchExpressionToPuppetDB rtype rsearch+ fqdn <- getNodeName+ -- we must filter the resources that originated from this host+ -- here ! They are also turned into "normal" resources+ res <- toListOf (folded+ . filtered ( hasn't (rnode . only fqdn) )+ . to (rvirtuality .~ Normal)+ ) <$> singleton (PDBGetResources q)+ scpdesc <- ContImported <$> getScope+ void $ enterScope SENormal scpdesc "importing" p+ pushScope scpdesc+ o <- finalize res+ popScope+ return o+ else return []+evaluateStatement (DependencyDeclaration (DepDecl (t1 :!: n1) (t2 :!: n2) lt p)) = do+ curPos .= p+ rn1 <- map (fixResourceName t1) <$> resolveExpressionStrings n1+ rn2 <- map (fixResourceName t2) <$> resolveExpressionStrings n2+ extraRelations <>= [ LinkInformation (normalizeRIdentifier t1 an1) (normalizeRIdentifier t2 an2) lt p | an1 <- rn1, an2 <- rn2 ]+ return []+evaluateStatement (ResourceDeclaration (ResDecl t ern eargs virt p)) = do+ curPos .= p+ resnames <- resolveExpressionStrings ern+ args <- fromAttributeDecls eargs+ concat <$> mapM (\n -> registerResource t n args virt p) resnames+evaluateStatement (MainFunctionDeclaration (MainFuncDecl funcname funcargs p)) = do+ curPos .= p+ mapM resolveExpression (toList funcargs) >>= mainFunctionCall funcname+evaluateStatement (VarAssignmentDeclaration (VarAssignDecl varname varexpr p)) = do+ curPos .= p+ varval <- resolveExpression varexpr+ loadVariable varname varval+ return []+evaluateStatement (ConditionalDeclaration (ConditionalDecl conds p)) = do+ curPos .= p+ let checkCond [] = return []+ checkCond ((e :!: stmts) : xs) = do+ sv <- saveCaptureVariables+ result <- pValue2Bool <$> resolveExpression e+ if result+ then evaluateStatementsFoldable stmts <* restoreCaptureVariables sv+ else restoreCaptureVariables sv *> checkCond xs+ checkCond (toList conds)+evaluateStatement (ResourceDefaultDeclaration (ResDefaultDecl rtype decls p)) = do+ curPos .= p+ rdecls <- fromAttributeDecls decls+ scp <- getScopeName+ -- invariant that must be respected : the current scope must be created+ -- in "scopes", or nothing gets saved+ preuse (scopes . ix scp) >>= maybe (throwPosError ("INTERNAL ERROR in evaluateStatement ResourceDefaultDeclaration: scope wasn't created - " <> pretty scp)) (const (return ()))+ let newDefaults = ResDefaults rtype scp rdecls p+ addDefaults x = scopes . ix scp . scopeResDefaults . at rtype ?= x+ -- default merging with parent+ mergedDefaults curdef = newDefaults & resDefValues .~ (rdecls <> (curdef ^. resDefValues))+ preuse (scopes . ix scp . scopeResDefaults . ix rtype) >>= \case+ Nothing -> addDefaults newDefaults+ Just d -> if d ^. resDefSrcScope == scp+ then throwPosError ("Defaults for resource" <+> ttext rtype <+> "already declared at" <+> showPPos (d ^. resDefPos))+ else addDefaults (mergedDefaults d)+ return []+evaluateStatement (ResourceOverrideDeclaration (ResOverrideDecl t urn eargs p)) = do+ curPos .= p+ raassignements <- fromAttributeDecls eargs+ rn <- resolveExpressionString urn+ scp <- getScopeName+ curoverrides <- use (scopes . ix scp . scopeOverrides)+ let rident = normalizeRIdentifier t rn+ -- check that we didn't already override those values+ withAssignements <- case curoverrides ^. at rident of+ Just (ResRefOverride _ prevass prevpos) -> do+ let cm = prevass `HM.intersection` raassignements+ unless (isEmpty cm)+ (throwPosError ("The following parameters were already overriden at" <+> showPPos prevpos <+> ":" <+> containerComma cm))+ return (prevass <> raassignements)+ Nothing -> return raassignements+ scopes . ix scp . scopeOverrides . at rident ?= ResRefOverride rident withAssignements p+ return []+evaluateStatement (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl c p)) =+ curPos .= p >> evaluateHFC c+ where+ evaluateHFC :: HOLambdaCall -> InterpreterMonad [Resource]+ evaluateHFC hf = do+ varassocs <- hfGenerateAssociations hf+ let runblock :: [(Text, PValue)] -> InterpreterMonad [Resource]+ runblock assocs = do+ saved <- hfSetvars assocs+ res <- evaluateStatementsFoldable (hf ^. hoLambdaStatements)+ hfRestorevars saved+ return res+ results <- mapM runblock varassocs+ return (concat results)+evaluateStatement r = throwError (PrettyError ("Do not know how to evaluate this statement:" </> pretty r))++-----------------------------------------------------------+-- Class evaluation+-----------------------------------------------------------++loadVariable :: Text -> PValue -> InterpreterMonad ()+loadVariable varname varval = do+ curcont <- getCurContainer+ scp <- getScopeName+ p <- use curPos+ scopeDefined <- has (ix scp) <$> use scopes+ variableDefined <- preuse (scopes . ix scp . scopeVariables . ix varname)+ case (scopeDefined, variableDefined) of+ (False, _) -> throwPosError ("Internal error: trying to save a variable in unknown scope" <+> ttext scp)+ (_, Just (_ :!: pp :!: ctx)) -> isParent scp (curcont ^. cctype) >>= \case+ True -> do+ debug("The variable"+ <+> pretty (UVariableReference varname)+ <+> "had been overriden because of some arbitrary inheritance rule that was set up to emulate puppet behaviour. It was defined at"+ <+> showPPos pp+ )+ scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype)+ False -> throwPosError ("Variable" <+> pretty (UVariableReference varname) <+> "already defined at" <+> showPPos pp+ </> "Context:" <+> pretty ctx+ </> "Value:" <+> pretty varval+ </> "Current scope:" <+> ttext scp+ )+ _ -> scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype)++-- | This function loads class and define parameters into scope. It checks+-- that all mandatory parameters are set, that no extra parameter is+-- declared.+--+-- It is able to fill unset parameters with values from Hiera (for classes+-- only) or default values.+loadParameters :: Foldable f => Container PValue -> f (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression)) -> PPosition -> S.Maybe Text -> InterpreterMonad ()+loadParameters params classParams defaultPos wHiera = do+ p <- use curPos+ curPos .= defaultPos+ let classParamSet = HS.fromList (classParams ^.. folded . _1 . _1)+ spuriousParams = ikeys params `HS.difference` classParamSet+ mclassdesc = S.maybe mempty ((\x -> mempty <+> "when including class" <+> x) . ttext) wHiera++ -- the following functions `throwE (Max False)` when there is no value, and `throwE (Max True)` when this value+ -- in PUndef.+ checkUndef :: Maybe PValue -> ExceptT (Max Bool) InterpreterMonad PValue+ checkUndef Nothing = throwE (Max False)+ checkUndef (Just PUndef) = throwE (Max True)+ checkUndef (Just v) = return v++ checkHiera :: Text -> ExceptT (Max Bool) InterpreterMonad PValue+ checkHiera k = case wHiera of+ S.Nothing -> throwE (Max False)+ S.Just classname -> lift (runHiera (classname <> "::" <> k) QFirst) >>= checkUndef++ checkDef :: Text -> ExceptT (Max Bool) InterpreterMonad PValue+ checkDef k = checkUndef (params ^. at k)++ checkDefault :: S.Maybe Expression -> ExceptT (Max Bool) InterpreterMonad PValue+ checkDefault S.Nothing = throwE (Max False)+ checkDefault (S.Just expr) = lift (resolveExpression expr)++ unless (isEmpty spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ttext) $ toList spuriousParams) <> mclassdesc)++ -- try to set a value to all parameters+ -- The order of evaluation is defined / hiera / default+ unsetParams <- fmap concat $ for (toList classParams) $ \(k :!: mtype :!: defValue) -> do+ ev <- runExceptT (checkDef k <|> checkHiera k <|> checkDefault defValue)+ case ev of+ Right v -> do+ forM_ mtype $ \udt -> do+ dt <- resolveDataType udt+ unless (datatypeMatch dt v) (throwPosError ("Expected type" <+> pretty dt <+> "for parameter" <+> pretty k <+> "but its value was:" <+> pretty v))+ loadVariable k v >> return []+ Left (Max True) -> loadVariable k PUndef >> return []+ Left (Max False) -> return [k]+ curPos .= p+ unless (isEmpty unsetParams) $ throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ttext $ toList unsetParams) <> mclassdesc)++-- | Enters a new scope, checks it is not already defined, and inherits the+-- defaults from the current scope+--+-- Inheriting the defaults is necessary for non native types, because they+-- will be expanded in "finalize", so if this was not done, we would be+-- expanding the defines without the defaults applied+enterScope :: ScopeEnteringContext+ -> CurContainerDesc+ -> Text+ -> PPosition+ -> InterpreterMonad Text+enterScope secontext cont modulename p = do+ let scopename = scopeName cont+ -- This is a special hack for inheritance, because at this time we+ -- have not properly stacked the scopes.+ curcaller <- case secontext of+ SEParent l -> return (PString $ Text.takeWhile (/=':') l)+ _ -> resolveVariable "module_name"+ scopeAlreadyDefined <- has (ix scopename) <$> use scopes+ let isImported = case cont of+ ContImported _ -> True+ _ -> False+ -- it is OK to reuse a scope related to imported stuff+ unless (scopeAlreadyDefined && isImported) $ do+ when scopeAlreadyDefined (throwPosError ("Internal error: scope" <+> brackets (ttext scopename) <+> "already defined when loading scope for" <+> pretty cont))+ scp <- getScopeName+ -- TODO fill tags+ basescope <- case secontext of+ SEChild prt -> do+ parentscope <- use (scopes . at prt)+ when (isNothing parentscope) (throwPosError ("Internal error: could not find parent scope" <+> ttext prt))+ let Just psc = parentscope+ return (psc & scopeParent .~ S.Just prt)+ _ -> do+ curdefs <- use (scopes . ix scp . scopeResDefaults)+ return $ ScopeInformation mempty curdefs mempty (CurContainer cont mempty) mempty S.Nothing+ scopes . at scopename ?= basescope+ scopes . ix scopename . scopeVariables . at "caller_module_name" ?= (curcaller :!: p :!: cont)+ scopes . ix "::" . scopeVariables . at "calling_module" ?= (curcaller :!: p :!: cont)+ scopes . ix scopename . scopeVariables . at "module_name" ?= (PString modulename :!: p :!: cont)+ debug ("enterScope, scopename=" <> ttext scopename <+> "caller_module_name=" <> pretty curcaller <+> "module_name=" <> ttext modulename)+ return scopename++loadClass :: Text+ -> S.Maybe Text -- ^ Set if this is an inheritance load, so that we can set calling module properly+ -> Container PValue+ -> ClassIncludeType+ -> InterpreterMonad [Resource]+loadClass name loadedfrom params incltype = do+ let name' = dropInitialColons name+ ndn <- getNodeName+ singleton (TraceEvent ('[' : Text.unpack ndn ++ "] loadClass " ++ Text.unpack name'))+ p <- use curPos+ -- check if the class has already been loaded+ -- http://docs.puppetlabs.com/puppet/3/reference/lang_classes.html#using-resource-like-declarations+ preuse (loadedClasses . ix name' . _2) >>= \case+ Just pp -> case incltype of+ ClassIncludeLike -> return []+ _ -> throwPosError+ $ "Can't include class" <+> ttext name' <+> "twice when using the resource-like syntax (first occurence at"+ <+> showPPos pp <> ")"+ Nothing -> do+ loadedClasses . at name' ?= (incltype :!: p)+ let modulename = getModulename (RIdentifier "class" name')+ is_ignored <- isIgnoredModule modulename+ if is_ignored+ then return mempty+ else do+ -- load the actual class, note we are not changing the current position right now+ (spurious, stmt) <- interpretTopLevel TopClass name'+ ClassDecl _ classParams inh stmts cp <- extractPrism "loadClass" _ClassDecl stmt+ -- check if we need to define a resource representing the class+ -- This will be the case for the first standard include+ inhstmts <- case inh of+ S.Nothing -> return []+ S.Just ihname -> loadClass ihname (S.Just name') mempty ClassIncludeLike+ let !scopedesc = ContClass name'+ secontext = case (inh, loadedfrom) of+ (S.Just x,_) -> SEChild (dropInitialColons x)+ (_,S.Just x) -> SEParent (dropInitialColons x)+ _ -> SENormal+ void $ enterScope secontext scopedesc modulename p+ classresource <- if incltype == ClassIncludeLike+ then do+ scp <- use curScope+ fqdn <- getNodeName+ return [Resource (RIdentifier "class" name') (HS.singleton name') mempty mempty scp Normal mempty p fqdn]+ else return []+ pushScope scopedesc+ loadVariable "title" (PString name')+ loadVariable "name" (PString name')+ loadParameters params classParams cp (S.Just name')+ curPos .= cp+ res <- evaluateStatementsFoldable stmts+ out <- finalize (classresource ++ spurious ++ inhstmts ++ res)+ popScope+ return out++-----------------------------------------------------------+-- Resource stuff+-----------------------------------------------------------++addRelationship :: LinkType -> PValue -> Resource -> InterpreterMonad Resource+addRelationship lt (PResourceReference dt dn) r = return (r & rrelations %~ insertLt)+ where+ insertLt = iinsertWith (<>) (normalizeRIdentifier dt dn) (HS.singleton lt)+addRelationship lt (PArray vals) r = foldlM (flip (addRelationship lt)) r vals+addRelationship _ PUndef r = return r+addRelationship _ notrr _ = throwPosError ("Expected a resource reference, not:" <+> pretty notrr)++addTagResource :: Resource -> Text -> Resource+addTagResource r rv = r & rtags . contains rv .~ True++addAttribute :: OverrideType -> Text -> Resource -> PValue -> InterpreterMonad Resource+addAttribute _ "alias" r v = (\rv -> r & ralias . contains rv .~ True) <$> resolvePValueString v+addAttribute _ "audit" r _ = use curPos >>= \p -> warn ("Metaparameter audit ignored at" <+> showPPos p) >> return r+addAttribute _ "loglevel" r _ = use curPos >>= \p -> warn ("Metaparameter loglevel ignored at" <+> showPPos p) >> return r+addAttribute _ "schedule" r _ = use curPos >>= \p -> warn ("Metaparameter schedule ignored at" <+> showPPos p) >> return r+addAttribute _ "stage" r _ = use curPos >>= \p -> warn ("Metaparameter stage ignored at" <+> showPPos p) >> return r+addAttribute _ "tag" r (PArray v) = foldM (\cr cv -> addTagResource cr <$> resolvePValueString cv) r (toList v)+addAttribute _ "tag" r v = addTagResource r <$> resolvePValueString v+addAttribute _ "before" r d = addRelationship RBefore d r+addAttribute _ "notify" r d = addRelationship RNotify d r+addAttribute _ "require" r d = addRelationship RRequire d r+addAttribute _ "subscribe" r d = addRelationship RSubscribe d r+addAttribute b t r v = go t r v+ where+ go =+ case b of+ CantOverride -> setAttribute+ Replace -> overrideAttribute+ CantReplace -> defaultAttribute+ AppendAttribute -> appendAttribute++setAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource+setAttribute attributename res value =+ case res ^. rattributes . at attributename of+ Nothing -> return (res & rattributes . at attributename ?~ value)+ Just curval -> do+ -- we must check if the resource scope is a parent of the current scope+ curscope <- getScopeName+ i <- isParent curscope (rcurcontainer res)+ if i -- TODO check why this is set+ then return (res & rattributes . at attributename ?~ value)+ else do+ -- We will not bark if the same attribute is+ -- defined multiple times with identical values.+ let errmsg = "Attribute" <+> dullmagenta (ttext attributename) <+> "defined multiple times for" <+> pretty res+ if curval == value+ then checkStrict errmsg errmsg+ else throwPosError errmsg+ return res++overrideAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource+overrideAttribute attributename res value = return (res & rattributes . at attributename ?~ value)++appendAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource+appendAttribute attributename res value = do+ nvalue <- case (res ^. rattributes . at attributename, value) of+ (Nothing, _) -> return value+ (Just (PArray a), PArray b) -> return (PArray (a <> b))+ (Just (PArray a), b) -> return (PArray (V.snoc a b))+ (Just a, PArray b) -> return (PArray (V.cons a b))+ (Just a, b) -> return (PArray (V.fromList [a,b]))+ return (res & rattributes . at attributename ?~ nvalue)++defaultAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource+defaultAttribute attributename res value =+ return $ case res ^. rattributes . at attributename of+ Nothing -> res & rattributes . at attributename ?~ value+ Just _ -> res++modifyCollectedAttribute :: Resource -> AttributeDecl -> InterpreterMonad Resource+modifyCollectedAttribute res (AttributeDecl attributename arrowop expr) = do+ value <- resolveExpression expr+ let optype = case arrowop of+ AppendArrow -> AppendAttribute+ AssignArrow -> Replace+ addAttribute optype attributename res value++registerResource :: Text -> Text -> Container PValue -> Virtuality -> PPosition -> InterpreterMonad [Resource]+registerResource "class" _ _ Virtual p = curPos .= p >> throwPosError "Cannot declare a virtual class (or perhaps you can, but I do not know what this means)"+registerResource "class" _ _ Exported p = curPos .= p >> throwPosError "Cannot declare an exported class (or perhaps you can, but I do not know what this means)"+registerResource t rn arg vrt p = do+ curPos .= p+ CurContainer cnt tgs <- getCurContainer+ -- default tags+ -- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#automatic-tagging+ -- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#containment+ let !defaulttags = {-# SCC "rrGetTags" #-} HS.fromList (t : classtags) <> tgs+ allsegs x = x : Text.splitOn "::" x+ (!classtags, !defaultLink) = getClassTags cnt+ getClassTags (ContClass cn ) = (allsegs cn,RIdentifier "class" cn)+ getClassTags (ContDefine dt dn _) = (allsegs dt,normalizeRIdentifier dt dn)+ getClassTags ContRoot = ([],RIdentifier "class" "::")+ getClassTags (ContImported _ ) = ([],RIdentifier "class" "::")+ getClassTags (ContImport _ _ ) = ([],RIdentifier "class" "::")+ defaultRelation = HM.singleton defaultLink (HS.singleton RRequire)+ allScope <- use curScope+ fqdn <- getNodeName+ let baseresource = Resource (normalizeRIdentifier t rn) (HS.singleton rn) mempty defaultRelation allScope vrt defaulttags p fqdn+ r <- ifoldlM (addAttribute CantOverride) baseresource arg+ let resid = normalizeRIdentifier t rn+ case t of+ "class" -> {-# SCC "rrClass" #-} do+ definedResources . at resid ?= r+ let attrs = r ^. rattributes+ (r:) <$> loadClass rn S.Nothing attrs ClassResourceLike+ _ -> {-# SCC "rrGeneralCase" #-}+ use (definedResources . at resid) >>= \case+ Just otheres -> throwPosError+ $ "Resource" <+> pretty resid <+> "already defined:"+ </> pretty r </> pretty otheres+ Nothing -> do+ definedResources . at resid ?= r+ return [r]+++-- functions : this can't really be exported as it uses a lot of stuff from+-- this module ...+mainFunctionCall :: Text -> [PValue] -> InterpreterMonad [Resource]+mainFunctionCall "showscope" _ = use curScope >>= warn . pretty >> return []+-- The logging functions+mainFunctionCall "alert" a = logWithModifier Log.ALERT red a+mainFunctionCall "crit" a = logWithModifier Log.CRITICAL red a+mainFunctionCall "debug" a = logWithModifier Log.DEBUG dullwhite a+mainFunctionCall "emerg" a = logWithModifier Log.EMERGENCY red a+mainFunctionCall "err" a = logWithModifier Log.ERROR dullred a+mainFunctionCall "info" a = logWithModifier Log.INFO green a+mainFunctionCall "notice" a = logWithModifier Log.NOTICE white a+mainFunctionCall "warning" a = logWithModifier Log.WARNING dullyellow a+mainFunctionCall "contain" includes =+ concat <$> mapM doContain includes+ where+ doContain e = do+ classname <- resolvePValueString e+ use (loadedClasses . at classname) >>= \case+ Nothing -> loadClass classname S.Nothing mempty ClassIncludeLike+ Just _ -> return [] -- TODO check that this happened after class declaration+mainFunctionCall "include" includes =+ concat <$> mapM doInclude includes+ where+ doInclude e = do+ classname <- resolvePValueString e+ loadClass classname S.Nothing mempty ClassIncludeLike+mainFunctionCall "create_resources" [t, hs] = mainFunctionCall "create_resources" [t, hs, PHash mempty]+mainFunctionCall "create_resources" [PString t, PHash hs, PHash defparams] = do+ let (ats, t') = Text.span (== '@') t+ virtuality <- case Text.length ats of+ 0 -> return Normal+ 1 -> return Virtual+ 2 -> return Exported+ _ -> throwPosError "Too many @'s"+ p <- use curPos+ let genRes rname (PHash rargs) = registerResource t' rname (rargs <> defparams) virtuality p+ genRes rname x = throwPosError ("create_resource(): the value corresponding to key" <+> ttext rname <+> "should be a hash, not" <+> pretty x)+ concat . HM.elems <$> itraverse genRes hs+mainFunctionCall "create_resources" args = throwPosError ("create_resource(): expects between two and three arguments, of type [string,hash,hash], and not:" <+> pretty args)+mainFunctionCall "ensure_packages" args = ensurePackages args+mainFunctionCall "ensure_resource" args = ensureResource args+mainFunctionCall "realize" args = do+ pos <- use curPos+ let updateMod (PResourceReference t rn) =+ resMod %= (ResourceModifier t ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) return pos : )+ updateMod x = throwPosError ("realize(): all arguments must be resource references, not" <+> pretty x)+ mapM_ updateMod args+ return []+mainFunctionCall "tag" args = do+ scp <- getScopeName+ let addTag x = scopes . ix scp . scopeExtraTags . contains x .= True+ mapM_ (resolvePValueString >=> addTag) args+ return []+mainFunctionCall "fail" [x] = ("fail:" <+>) . dullred . ttext <$> resolvePValueString x >>= throwPosError+mainFunctionCall "fail" _ = throwPosError "fail(): This function takes a single argument"+-- hiera_include does a unique merge lookup for the requested key, then calls the include function on the resulting array.+mainFunctionCall "hiera_include" [x] = do+ ndname <- resolvePValueString x+ classes <- toListOf (traverse . _PArray . traverse) <$> runHiera ndname QUnique+ p <- use curPos+ curPos . _1 . lSourceName <>= " [hiera_include call]"+ o <- mainFunctionCall "include" classes+ curPos .= p+ return o+mainFunctionCall "hiera_include" _ = throwPosError "hiera_include(): This function takes a single argument"+-- dumpinfos is a debugging function specific to language-puppet+mainFunctionCall "dumpinfos" _ = do+ let prntline = logWriter Log.ALERT+ indentln = (<>) " "+ prntline "Scope stack :"+ scps <- use curScope+ mapM_ (prntline . indentln . pretty) scps+ prntline "Variables in local scope :"+ scp <- getScopeName+ vars <- use (scopes . ix scp . scopeVariables)+ forM_ (sortBy (comparing fst) (itoList vars)) $ \(idx, pv :!: _ :!: _) -> prntline $ indentln $ ttext idx <> " -> " <> pretty pv+ pure []+mainFunctionCall "assert_type" [PType dt, v] =+ if datatypeMatch dt v+ then pure []+ else throwPosError $ "assert_type(): the value " <> pretty v <> " doesn't mach type " <> pretty dt+mainFunctionCall "assert_type" _ = throwPosError "assert_type(): Expects two arguments"+mainFunctionCall fname args = do+ p <- use curPos+ let representation = MainFunctionDeclaration (MainFuncDecl 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)+ pure []++ensurePackages :: [PValue] -> InterpreterMonad [Resource]+ensurePackages [packages] = ensurePackages [packages, PHash mempty]+ensurePackages [PString p, x] = ensurePackages [ PArray (V.singleton (PString p)), x ]+ensurePackages [PArray packages, PHash defparams] = do+ checkStrict+ "The use of the 'ensure_packages' function is a code smell."+ "The 'ensure_packages' function is not allowed in strict mode."+ concat <$> for packages (resolvePValueString >=> ensureResource' "package" (HM.singleton "ensure" "present" <> defparams))+ensurePackages [PArray _,_] = throwPosError "ensure_packages(): the second argument must be a hash."+ensurePackages [_,_] = throwPosError "ensure_packages(): the first argument must be a string or an array of strings."+ensurePackages _ = throwPosError "ensure_packages(): requires one or two arguments."++-- | Takes a resource type, title, and a hash of attributes that describe the resource+-- Create the resource if it does not exist alreadyTakes a resource type, title, and a hash of attributes that describe the resource(s).+ensureResource :: [PValue] -> InterpreterMonad [Resource]+ensureResource [PString t, PString title, PHash params] = do+ checkStrict+ "The use of the 'ensure_resource' function is a code smell."+ "The 'ensure_resource' function is not allowed in strict mode."+ ensureResource' t params title+ensureResource [t, PArray arr, params] = concat <$> mapM (\r -> ensureResource [t, r, params]) (V.toList arr)+ensureResource [t,title] = ensureResource [t,title,PHash mempty]+ensureResource [_, PString _, PHash _] = throwPosError "ensureResource(): The first argument must be a string."+ensureResource [PString _, _, PHash _] = throwPosError "ensureResource(): The second argument must be a string."+ensureResource [PString _, PString _, _] = throwPosError "ensureResource(): The thrid argument must be a hash."+ensureResource _ = throwPosError "ensureResource(): expects 2 or 3 arguments."++ensureResource' :: Text -> HM.HashMap Text PValue -> Text -> InterpreterMonad [Resource]+ensureResource' t params title = do+ isdefined <- has (ix (normalizeRIdentifier t title)) <$> use definedResources+ if isdefined+ then return []+ else use curPos >>= registerResource t title params Normal+++-----------------------------------------------------------+-- Specific utils functions that depends on this modules+-----------------------------------------------------------++evaluateStatementsFoldable :: Foldable f => f Statement -> InterpreterMonad [Resource]+evaluateStatementsFoldable = fmap concat . mapM evaluateStatement . toList++-- A helper function for the various loggers+logWithModifier :: Log.Priority -> (Doc -> Doc) -> [PValue] -> InterpreterMonad [Resource]+logWithModifier prio m [v] = do+ p <- use curPos+ v' <- resolvePValueString v+ logWriter prio (m (ttext v') <+> showPPos p)+ return []+logWithModifier _ _ _ = throwPosError "This function takes a single argument"
+ src/Puppet/Interpreter/IO.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}++-- | This is an internal module.+module Puppet.Interpreter.IO (+ defaultImpureMethods+ , interpretMonad+ ) where++import Puppet.Prelude++import Control.Monad.Operational+import Control.Monad.State.Strict+import qualified Data.Either.Strict as S+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Debug.Trace (traceEventIO)++import Puppet.Interpreter.PrettyPrinter ()+import Puppet.Interpreter.Types+import Puppet.PP++defaultImpureMethods :: MonadIO m => IoMethods m+defaultImpureMethods = IoMethods (liftIO currentCallStack)+ (liftIO . file)+ (liftIO . traceEventIO)+ where+ file [] = return $ Left ""+ file (x:xs) = (Right <$> Text.readFile (Text.unpack x)) `catch` (\SomeException{} -> file xs)+++-- | The operational interpreter function+interpretMonad :: Monad m+ => InterpreterReader m+ -> InterpreterState+ -> InterpreterMonad a+ -> m (Either PrettyError a, InterpreterState, InterpreterWriter)+interpretMonad r s0 instr = let (!p, !s1) = runState (viewT instr) s0+ in eval r s1 p++-- The internal (not exposed) eval function+eval :: Monad m+ => InterpreterReader m+ -> InterpreterState+ -> ProgramViewT InterpreterInstr (State InterpreterState) a+ -> m (Either PrettyError a, InterpreterState, InterpreterWriter)+eval _ s (Return x) = return (Right x, s, mempty)+eval r s (a :>>= k) =+ let runInstr = interpretMonad r s . k -- run one instruction+ thpe = interpretMonad r s . throwPosError . getError+ pdb = r^.readerPdbApi+ strFail iof errf = iof >>= \case+ Left rr -> thpe (errf (string rr))+ Right x -> runInstr x+ canFail iof = iof >>= \case+ S.Left err -> thpe err+ S.Right x -> runInstr x+ canFailX iof = runExceptT iof >>= \case+ Left err -> thpe err+ Right x -> runInstr x+ logStuff x c = (_3 %~ (x <>)) <$> c+ in case a of+ IsStrict -> runInstr (r ^. readerIsStrict)+ ExternalFunction fname args -> case r ^. readerExternalFunc . at fname of+ Just fn -> interpretMonad r s ( fn args >>= k)+ Nothing -> thpe (PrettyError ("Unknown function: " <> ttext fname))+ GetStatement topleveltype toplevelname+ -> canFail ((r ^. readerGetStatement) topleveltype toplevelname)+ ComputeTemplate fn stt -> canFail ((r ^. readerGetTemplate) fn stt r)+ WriterTell t -> logStuff t (runInstr ())+ WriterPass _ -> thpe "WriterPass"+ WriterListen _ -> thpe "WriterListen"+ PuppetPaths -> runInstr (r ^. readerPuppetPaths)+ RebaseFile -> runInstr (r ^. readerRebaseFile)+ GetNativeTypes -> runInstr (r ^. readerNativeTypes)+ ErrorThrow d -> return (Left d, s, mempty)+ GetNodeName -> runInstr (r ^. readerNodename)+ HieraQuery scps q t -> canFail (queryHiera (r ^. readerHieraQuery) scps q t)+ PDBInformation -> pdbInformation pdb >>= runInstr+ PDBReplaceCatalog w -> canFailX (replaceCatalog pdb w)+ PDBReplaceFacts fcts -> canFailX (replaceFacts pdb fcts)+ PDBDeactivateNode nn -> canFailX (deactivateNode pdb nn)+ PDBGetFacts q -> canFailX (getFacts pdb q)+ PDBGetResources q -> canFailX (getResources pdb q)+ PDBGetNodes q -> canFailX (getNodes pdb q)+ PDBCommitDB -> canFailX (commitDB pdb)+ PDBGetResourcesOfNode nn q -> canFailX (getResourcesOfNode pdb nn q)+ GetCurrentCallStack -> (r ^. readerIoMethods . ioGetCurrentCallStack) >>= runInstr+ ReadFile fls -> strFail ((r ^. readerIoMethods . ioReadFile) fls) (const $ PrettyError ("No file found in " <> list (map ttext fls)))+ TraceEvent e -> (r ^. readerIoMethods . ioTraceEvent) e >>= runInstr+ IsIgnoredModule m -> runInstr (r ^. readerIgnoredModules . contains m)+ IsExternalModule m -> runInstr (r ^. readerExternalModules . contains m)+ -- on error, the program state is RESET and the logged messages are dropped+ ErrorCatch atry ahandle -> do+ (eres, s', w) <- interpretMonad r s atry+ case eres of+ Left rr -> interpretMonad r s (ahandle rr >>= k)+ Right x -> logStuff w (interpretMonad r s' (k x))+++-- | Query hiera layers+queryHiera :: Monad m => HieraQueryLayers m -> Container Text -> Text -> HieraQueryType -> m (S.Either PrettyError (Maybe PValue))+queryHiera layers scps q t = do+ val <- (layers^.globalLayer) scps q t+ case val of+ S.Right Nothing -> do+ let+ modname =+ case Text.splitOn "::" (Text.dropWhile (==':') q) of+ [] -> Nothing+ [_] -> Nothing+ (m:_) -> Just m+ layer = modname >>= (\n -> layers ^.moduleLayer.at n)+ maybe (pure val) (\hq -> hq scps q t) layer+ _ -> pure val
+ src/Puppet/Interpreter/PrettyPrinter.hs view
@@ -0,0 +1,188 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE GADTs #-}+module Puppet.Interpreter.PrettyPrinter(containerComma) where++import Puppet.Prelude hiding (empty, (<$>))++import Data.Aeson (ToJSON, encode)+import qualified Data.ByteString.Lazy.Char8 as BSL+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.Text as Text+import qualified Data.Vector as V+import qualified GHC.Exts as Exts+import Text.PrettyPrint.ANSI.Leijen ((<$>))++import Puppet.Interpreter.Types+import Puppet.Parser.PrettyPrinter+import Puppet.Parser.Types+import Puppet.PP++containerComma'' :: Pretty a => [(Doc, a)] -> Doc+containerComma'' x = indent 2 ins+ where+ ins = mconcat $ intersperse (comma <$> empty) (fmap showC x)+ showC (a,b) = a <+> text "=>" <+> pretty b++containerComma' :: Pretty a => [(Doc, a)] -> Doc+containerComma' = braces . containerComma''++containerComma :: Pretty a => Container a -> Doc+containerComma hm = containerComma' (fmap (\(a,b) -> (fill maxalign (pretty a), b)) hml)+ where+ hml = HM.toList hm+ maxalign = maximum (fmap (Text.length . fst) hml)++instance Pretty Text where+ pretty = ttext++instance Pretty PValue where+ pretty (PBoolean True) = dullmagenta $ text "true"+ pretty (PBoolean False) = dullmagenta $ text "false"+ pretty (PString s) = dullcyan (ttext (stringEscape s))+ pretty (PNumber n) = cyan (ttext (scientific2text n))+ pretty PUndef = dullmagenta (text "undef")+ pretty (PResourceReference t n) = capitalize t <> brackets (text (Text.unpack n))+ pretty (PArray v) = list (map pretty (V.toList v))+ pretty (PHash g) = containerComma g+ pretty (PType dt) = pretty dt++instance Pretty TopLevelType where+ pretty TopNode = dullyellow (text "node")+ pretty TopDefine = dullyellow (text "define")+ pretty TopClass = dullyellow (text "class")++instance Pretty RIdentifier where+ pretty (RIdentifier t n) = pretty (PResourceReference t n)++meta :: Resource -> Doc+meta r = showPPos (r ^. rpos) <+> green (node <+> brackets scp)+ where+ node = red (ttext (r ^. rnode))+ scp = "Scope" <+> pretty (r ^.. rscope . folded . filtered (/=ContRoot) . to pretty)++resourceBody :: Resource -> Doc+resourceBody r = virtuality <> blue (ttext (r ^. rid . iname)) <> ":" <+> meta r <$> containerComma'' insde <> ";"+ where+ virtuality = case r ^. rvirtuality of+ Normal -> empty+ Virtual -> dullred "@"+ Exported -> dullred "@@"+ ExportedRealized -> dullred "<@@>"+ insde = alignlst dullblue attriblist1 ++ alignlst dullmagenta attriblist2+ alignlst col = map (first (fill maxalign . col . ttext))+ attriblist1 = Exts.sortWith fst $ HM.toList (r ^. rattributes) ++ aliasdiff+ aliasWithoutTitle = r ^. ralias & contains (r ^. rid . iname) .~ False+ aliasPValue = aliasWithoutTitle & PArray . V.fromList . map PString . HS.toList+ aliasdiff | HS.null aliasWithoutTitle = []+ | otherwise = [("alias", aliasPValue)]+ attriblist2 = map totext (resourceRelations r)+ totext (RIdentifier t n, lt) = (rel2text lt , PResourceReference t n)+ maxalign = max (maxalign' attriblist1) (maxalign' attriblist2)+ maxalign' [] = 0+ maxalign' x = maximum . map (Text.length . fst) $ x++resourceRelations :: Resource -> [(RIdentifier, LinkType)]+resourceRelations = concatMap expandSet . HM.toList . view rrelations+ where+ expandSet (ri, lts) = [(ri, lt) | lt <- HS.toList lts]++instance Pretty Resource where+ prettyList lst =+ let grouped = HM.toList $ HM.fromListWith (++) [ (r ^. rid . itype, [r]) | r <- lst ] :: [ (Text, [Resource]) ]+ sorted = Exts.sortWith fst (map (second (Exts.sortWith (view (rid.iname)))) grouped)+ showGroup :: (Text, [Resource]) -> Doc+ showGroup (rt, res) = dullyellow (ttext rt) <+> lbrace <$> indent 2 (vcat (map resourceBody res)) <$> rbrace+ in vcat (map showGroup sorted)+ pretty r = dullyellow (ttext (r ^. rid . itype)) <+> lbrace <$> indent 2 (resourceBody r) <$> rbrace++instance Pretty CurContainerDesc where+ pretty (ContImport p x) = magenta "import" <> braces (ttext p) <> braces (pretty x)+ pretty (ContImported x) = magenta "imported" <> braces (pretty x)+ pretty ContRoot = dullyellow (text "::")+ pretty (ContClass cname) = dullyellow (text "class") <+> dullgreen (text (Text.unpack cname))+ pretty (ContDefine dtype dname _) = pretty (PResourceReference dtype dname)++instance Pretty ResDefaults where+ pretty (ResDefaults t _ v p) = capitalize t <+> showPPos p <$> containerComma v++instance Pretty ResourceModifier where+ pretty (ResourceModifier rt ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString x)) _ p) = "realize" <> parens (pretty (PResourceReference rt x)) <+> showPPos p+ -- pretty (ResourceModifier rt ModifierCollector ct (REqualitySearch _ (PString x)) _ p) = "collect" <> parens (pretty (PResourceReference rt x)) <+> showPPos p+ pretty _ = "TODO pretty ResourceModifier"++instance Pretty RSearchExpression where+ pretty (REqualitySearch a v) = ttext a <+> "==" <+> pretty v+ pretty (RNonEqualitySearch a v) = ttext a <+> "!=" <+> pretty v+ pretty (RAndSearch a b) = parens (pretty a) <+> "&&" <+> parens (pretty b)+ pretty (ROrSearch a b) = parens (pretty a) <+> "||" <+> parens (pretty b)+ pretty RAlwaysTrue = mempty++pf :: Doc -> [Doc] -> Doc+pf fn args = bold (red fn) <> tupled (map pretty args)++showQuery :: ToJSON a => Query a -> Doc+showQuery = string . BSL.unpack . encode++instance Pretty (InterpreterInstr a) where+ pretty PuppetPaths = pf "PuppetPathes" []+ pretty RebaseFile = pf "RebaseFile" []+ pretty IsStrict = pf "IsStrict" []+ pretty GetNativeTypes = pf "GetNativeTypes" []+ pretty (GetStatement tlt nm) = pf "GetStatement" [pretty tlt,ttext nm]+ pretty (ComputeTemplate fn _) = pf "ComputeTemplate" [fn']+ where+ fn' = case fn of+ Left content -> pretty (PString content)+ Right filena -> ttext filena+ pretty (ExternalFunction fn args) = pf (ttext fn) (map pretty args)+ pretty GetNodeName = pf "GetNodeName" []+ pretty (HieraQuery _ q _) = pf "HieraQuery" [ttext q]+ pretty GetCurrentCallStack = pf "GetCurrentCallStack" []+ pretty (ErrorThrow rr) = pf "ErrorThrow" [getError rr]+ pretty (ErrorCatch _ _) = pf "ErrorCatch" []+ pretty (WriterTell t) = pf "WriterTell" (map (pretty . view _2) t)+ pretty (WriterPass _) = pf "WriterPass" []+ pretty (WriterListen _) = pf "WriterListen" []+ pretty PDBInformation = pf "PDBInformation" []+ pretty (PDBReplaceCatalog _) = pf "PDBReplaceCatalog" ["..."]+ pretty (PDBReplaceFacts _) = pf "PDBReplaceFacts" ["..."]+ pretty (PDBDeactivateNode n) = pf "PDBDeactivateNode" [ttext n]+ pretty (PDBGetFacts q) = pf "PDBGetFacts" [showQuery q]+ pretty (PDBGetResources q) = pf "PDBGetResources" [showQuery q]+ pretty (PDBGetNodes q) = pf "PDBGetNodes" [showQuery q]+ pretty PDBCommitDB = pf "PDBCommitDB" []+ pretty (PDBGetResourcesOfNode n q) = pf "PDBGetResourcesOfNode" [ttext n, showQuery q]+ pretty (ReadFile f) = pf "ReadFile" (map ttext f)+ pretty (TraceEvent e) = pf "TraceEvent" [string e]+ pretty (IsIgnoredModule m) = pf "IsIgnoredModule" [ttext m]+ pretty (IsExternalModule m) = pf "IsExternalModule" [ttext m]++instance Pretty LinkInformation where+ pretty (LinkInformation lsrc ldst ltype lpos) = pretty lsrc <+> pretty ltype <+> pretty ldst <+> showPPos lpos++instance Pretty DataType where+ pretty t = case t of+ DTType -> "Type"+ DTString ma mb -> bounded "String" ma mb+ DTInteger ma mb -> bounded "Integer" ma mb+ DTFloat ma mb -> bounded "Float" ma mb+ DTBoolean -> "Boolean"+ DTArray dt mi mmx -> "Array" <> list (pretty dt : pretty mi : maybe [] (pure . pretty) mmx)+ DTHash kt dt mi mmx -> "Hash" <> list (pretty kt : pretty dt : pretty mi : maybe [] (pure . pretty) mmx)+ DTUndef -> "Undef"+ DTScalar -> "Scalar"+ DTData -> "Data"+ DTOptional o -> "Optional" <> brackets (pretty o)+ NotUndef -> "NotUndef"+ DTVariant vs -> "Variant" <> list (foldMap (pure . pretty) vs)+ DTPattern vs -> "Pattern" <> list (foldMap (pure . pretty) vs)+ DTEnum tx -> "Enum" <> list (foldMap (pure . pretty) tx)+ DTAny -> "Any"+ DTCollection -> "Collection"+ where+ bounded :: (Pretty a, Pretty b) => Doc -> Maybe a -> Maybe b -> Doc+ bounded s ma mb = s <> case (ma, mb) of+ (Just a, Nothing) -> list [pretty a]+ (Just a, Just b) -> list [pretty a, pretty b]+ _ -> mempty
+ src/Puppet/Interpreter/Pure.hs view
@@ -0,0 +1,166 @@+-- | This is a set of pure helpers for evaluation the 'InterpreterMonad'+-- function that can be found in "Puppet.Interpreter" and+-- "Puppet.Interpreter.Resolve". They are used to power some prisms from+-- "Puppet.Lens".+--+-- > > dummyEval (resolveExpression (Addition "1" "2"))+-- > Right (PString "3")+module Puppet.Interpreter.Pure (+ dummyEval+ , dummyFacts+ , pureEval+ , pureReader+) where++import Puppet.Prelude++import qualified Data.Either.Strict as S+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as Text++import Erb.Evaluate+import Erb.Parser+import Puppet.Interpreter.IO+import Puppet.Interpreter.Types+import Puppet.Interpreter.Utils+import Puppet.NativeTypes+import Puppet.Parser.Types+import Puppet.Paths+import Puppet.PP+import PuppetDB.Dummy+++-- | Worst name ever, this is a set of pure stub for the 'ImpureMethods'+-- type.+impurePure :: IoMethods Identity+impurePure = IoMethods (return []) (const (return (Left "Can't read file"))) (\_ -> return ())++-- | A pure 'InterpreterReader', that can only evaluate a subset of the+-- templates, and that can include only the supplied top level statements.+pureReader :: HM.HashMap (TopLevelType, Text) Statement -- ^ A top-level statement map+ -> InterpreterReader Identity+pureReader sttmap = InterpreterReader+ baseNativeTypes+ getstatementdummy+ templatedummy+ dummyPuppetDB+ mempty+ "dummy"+ hieradummy+ impurePure+ mempty+ mempty+ True+ (puppetPaths "/etc/puppet")+ Nothing+ where+ templatedummy (Right _) _ _ = return (S.Left "Can't interpret files")+ templatedummy (Left cnt) stt _ = return $ case extractFromState stt of+ Nothing -> S.Left "Context retrieval error (pureReader)"+ Just (ctx, scope) -> case parseErbString (Text.unpack cnt) of+ Left rr -> S.Left (PrettyError (text (show rr)))+ Right stmts -> case rubyEvaluate scope ctx stmts of+ Right x -> S.Right x+ Left rr -> S.Left (PrettyError rr)+ pure_hiera :: HieraQueryFunc Identity+ pure_hiera _ _ _ = pure (S.Right (Just "pure"))+ hieradummy = HieraQueryLayers pure_hiera mempty+ getstatementdummy tlt n = return $ case HM.lookup (tlt,n) sttmap of+ Just x -> S.Right x+ Nothing -> S.Left "Can't get statement"++-- | Evaluates an interpreter expression in a pure context.+pureEval :: Facts -- ^ A list of facts that will be used during evaluation+ -> HM.HashMap (TopLevelType, Text) Statement -- ^ A top-level map+ -> InterpreterMonad a -- ^ The action to evaluate+ -> (Either PrettyError a, InterpreterState, InterpreterWriter)+pureEval facts sttmap action = runIdentity (interpretMonad (pureReader sttmap) startingState action)+ where+ startingState = initialState facts $ HM.fromList [ ("confdir", "/etc/puppet")+ ]++-- | A bunch of facts that can be used for pure evaluation.+dummyFacts :: Facts+dummyFacts = HM.fromList+ [ ("architecture", "amd64")+ , ("augeasversion", "0.10.0")+ , ("bios_release_date", "07/06/2010")+ , ("bios_vendor", "Dell Inc.")+ , ("bios_version", "2.2.0")+ , ("boardmanufacturer", "Dell Inc.")+ , ("domain", "dummy.domain")+ , ("facterversion", "1.7.5")+ , ("filesystems", "ext2,ext3,ext4,vfat")+ , ("fqdn", "dummy.dummy.domain")+ , ("hardwareisa", "x86_64")+ , ("hardwaremodel", "x86_64")+ , ("hostname", "dummy")+ , ("id", "root")+ , ("interfaces", "eth0,lo")+ , ("ipaddress", "172.17.42.1")+ , ("ipaddress_eth0", "172.17.42.1")+ , ("ipaddress_lo", "127.0.0.1")+ , ("is_virtual", "false")+ , ("kernel", "Linux")+ , ("kernelmajversion", "3.8")+ , ("kernelrelease", "3.8.0-37-generic")+ , ("kernelversion", "3.8.0")+ , ("lsbdistcodename", "precise")+ , ("lsbdistdescription", "Ubuntu 12.04.4 LTS")+ , ("lsbdistid", "Ubuntu")+ , ("lsbdistrelease", "12.04")+ , ("lsbmajdistrelease", "12")+ , ("macaddress", "a5:cb:10:b0:9a:4b")+ , ("macaddress_eth0", "72:53:10:c1:eb:70")+ , ("manufacturer", "Dell Inc.")+ , ("memoryfree", "12.57 GB")+ , ("memoryfree_mb", "12869.89")+ , ("memorysize", "15.63 GB")+ , ("memorysize_mb", "16009.07")+ , ("memorytotal", "15.63 GB")+ , ("mtu_eth0", "1500")+ , ("mtu_lo", "65536")+ , ("netmask", "255.255.0.0")+ , ("netmask_eth0", "255.255.255.0")+ , ("netmask_lo", "255.0.0.0")+ , ("network_eth0", "172.17.42.0")+ , ("network_lo", "127.0.0.0")+ , ("operatingsystem", "Ubuntu")+ , ("operatingsystemrelease", "12.04")+ , ("osfamily", "Debian")+ , ("path", "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin")+ , ("physicalprocessorcount", "1")+ , ("processor0", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")+ , ("processor1", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")+ , ("processor2", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")+ , ("processor3", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")+ , ("processor4", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")+ , ("processor5", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")+ , ("processor6", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")+ , ("processor7", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")+ , ("processorcount", "8")+ , ("productname", "Vostro 430")+ , ("ps", "ps -ef")+ , ("puppetversion", "3.4.3")+ , ("rubysitedir", "/usr/local/lib/site_ruby/1.8")+ , ("rubyversion", "1.8.7")+ , ("selinux", "false")+ , ("serialnumber", "9L3FW4J")+ , ("swapfree", "15.96 GB")+ , ("swapfree_mb", "16340.00")+ , ("swapsize", "15.96 GB")+ , ("swapsize_mb", "16340.00")+ , ("timezone", "CEST")+ , ("type", "Desktop")+ , ("uniqueid", "007f0101")+ , ("uptime", "5:48 hours")+ , ("uptime_days", "0")+ , ("uptime_hours", "5")+ , ("uptime_seconds", "20932")+ , ("uuid", "97b75940-be55-11e3-b1b6-0800200c9a66")+ , ("virtual", "physical")+ ]++-- | A default evaluation function for arbitrary interpreter actions.+dummyEval :: InterpreterMonad a -> Either PrettyError a+dummyEval action = pureEval dummyFacts mempty action ^. _1
+ src/Puppet/Interpreter/Resolve.hs view
@@ -0,0 +1,800 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+-- | This module is all about converting and resolving foreign data into+-- the fully exploitable corresponding data type. The main use case is the+-- conversion of 'Expression' to 'PValue'.+module Puppet.Interpreter.Resolve+ ( -- * Pure resolution functions+ getVariable,+ pValue2Bool,+ -- * Monadic resolution functions+ resolveVariable,+ resolveExpression,+ resolveValue,+ resolvePValueString,+ resolvePValueNumber,+ resolveExpressionString,+ resolveExpressionStrings,+ resolveFunction',+ resolveDataType,+ runHiera,+ isNativeType,+ -- * Search expression management+ resolveSearchExpression,+ checkSearchExpression,+ searchExpressionToPuppetDB,+ -- * Higher order puppet functions handling+ hfGenerateAssociations,+ hfSetvars,+ hfRestorevars,+ toNumbers,+ fixResourceName,+ datatypeMatch,+ -- * Synonym+ NumberPair+ ) where++import Puppet.Prelude++import qualified Control.Monad.Operational as Operational+import "cryptonite" Crypto.Hash+import qualified Data.Aeson as Aeson+import Data.Aeson.Lens (_Integer, _Number)+import qualified Data.ByteArray as ByteArray+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import qualified Data.CaseInsensitive as CaseInsensitive+import qualified Data.Char as Char+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.List as List+import qualified Data.List.NonEmpty as NE+import qualified Data.Maybe.Strict as S+import qualified Data.Scientific as Scientific+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Tuple.Strict as Tuple+import qualified Data.Vector as V+import Data.Version (Version (..), parseVersion)+import Text.ParserCombinators.ReadP (readP_to_S)+import qualified Text.PrettyPrint.ANSI.Leijen as PP+import qualified Text.Regex.PCRE.ByteString.Utils as Regex++import Puppet.Interpreter.PrettyPrinter ()+import Puppet.Interpreter.Resolve.Sprintf (sprintf)+import Puppet.Interpreter.RubyRandom+import Puppet.Interpreter.Types+import Puppet.Interpreter.Utils+import Puppet.Parser.Types+import Puppet.Paths+import Puppet.PP++sha1 :: ByteString -> ByteString+sha1 = ByteArray.convert . (hash :: ByteString -> Digest SHA1)++md5 :: ByteString -> ByteString+md5 = ByteArray.convert . (hash :: ByteString -> Digest MD5)++-- | A useful type that is used when trying to perform arithmetic on Puppet numbers.+type NumberPair = Pair Scientific Scientific++-- | Converts class resource names to lowercase (fix for the jenkins plugin).+fixResourceName :: Text -- ^ Resource type+ -> Text -- ^ Resource name+ -> Text+fixResourceName "class" x = Text.toLower $ fromMaybe x $ Text.stripPrefix "::" x+fixResourceName _ x = x++-- | A hiera helper function, that will throw all Hiera errors and log+-- messages to the main monad.+runHiera :: Text -> HieraQueryType -> InterpreterMonad (Maybe PValue)+runHiera q t = do+ -- We need to merge the current scope with the top level scope+ scps <- use scopes+ ctx <- getScopeName+ let getV scp = mapMaybe toStr $ HM.toList $ fmap (view (_1 . _1)) (scps ^. ix scp . scopeVariables)+ toStr (k,v) = fmap (k,) (preview _PString v)+ toplevels = map (_1 %~ ("::" <>)) $ getV "::"+ locals = getV ctx+ vars = HM.fromList (toplevels <> locals)+ Operational.singleton (HieraQuery vars q t)++-- | The implementation of all hiera_* functions+hieraCall :: HieraQueryType -> PValue -> Maybe PValue -> Maybe DataType -> Maybe PValue -> InterpreterMonad PValue+hieraCall _ _ _ _ (Just _) = throwPosError "Overriding the hierarchy is not supported (and deprecated in puppet)"+hieraCall qt q df dt _ = do+ qs <- resolvePValueString q+ runHiera qs qt >>= \case+ Just p -> case dt of+ Just dt' | not (datatypeMatch dt' p) -> throwPosError "Datatype mismatched"+ _ -> pure p+ Nothing -> case df of+ Just d -> pure d+ Nothing -> throwPosError ("Lookup for " <> ttext qs <> " failed")++-- | Tries to convert a pair of 'PValue's into a 'NumberPair', as defined in+-- attoparsec. If the two values can be converted, it will convert them so+-- that they are of the same type+toNumbers :: PValue -> PValue -> S.Maybe NumberPair+toNumbers (PString a) b =+ case text2Scientific a of+ Just na -> toNumbers (PNumber na) b+ Nothing -> S.Nothing+toNumbers a (PString b) = toNumbers (PString b) a+toNumbers (PNumber a) (PNumber b) = S.Just (a :!: b)+toNumbers _ _ = S.Nothing++-- | This tries to run a numerical binary operation on two puppet+-- expressions. It will try to resolve them, then convert them to numbers+-- (using 'toNumbers'), and will finally apply the correct operation.+binaryOperation :: Expression -- ^ left operand+ -> Expression -- ^ right operand+ -> (Scientific -> Scientific -> Scientific) -- ^ operation+ -> InterpreterMonad PValue+binaryOperation a b opr = ((PNumber .) . opr) `fmap` resolveExpressionNumber a <*> resolveExpressionNumber b++-- 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+ rb <- resolveExpressionNumber b+ case (preview _Integer ra, preview _Integer rb) of+ (Just na, Just nb) -> pure (PNumber $ fromIntegral (opr na nb))+ _ -> throwPosError ("Expected integer values, not" <+> string (show ra) <+> "or" <+> string (show rb))++-- | Resolves a variable, or throws an error if it can't.+resolveVariable :: Text -> InterpreterMonad PValue+resolveVariable fullvar = do+ scps <- use scopes+ scp <- getScopeName+ case getVariable scps scp fullvar of+ Left rr -> throwPosError rr+ Right x -> pure x++-- | A simple helper that checks if a given type is native or a define.+isNativeType :: Text -> InterpreterMonad Bool+isNativeType t = has (ix t) `fmap` Operational.singleton GetNativeTypes++-- | A pure function for resolving variables.+getVariable :: Container ScopeInformation -- ^ The whole scope data.+ -> Text -- ^ Current scope name.+ -> Text -- ^ Full variable name.+ -> Either Doc PValue+getVariable scps scp fullvar = do+ (varscope, varname) <- case Text.splitOn "::" fullvar of+ [] -> Left "This doesn't make any sense in resolveVariable"+ [vn] -> pure (scp, vn) -- Non qualified variables+ rst -> pure (Text.intercalate "::" (filter (not . Text.null) (List.init rst)), List.last rst) -- qualified variables+ let extractVariable (varval :!: _ :!: _) = pure varval+ case scps ^? ix varscope . scopeVariables . ix varname of+ Just pp -> extractVariable pp+ Nothing -> -- check top level scope+ case scps ^? ix "::" . scopeVariables . ix varname of+ Just pp -> extractVariable pp+ Nothing -> Left ("Could not resolve variable" <+> pretty (UVariableReference fullvar) <+> "in context" <+> ttext varscope <+> "or root")++-- | A helper for numerical comparison functions.+numberCompare :: Expression -> Expression -> (Scientific -> Scientific -> Bool) -> InterpreterMonad PValue+numberCompare a b comp = ((PBoolean .) . comp) `fmap` resolveExpressionNumber a <*> resolveExpressionNumber b++-- | Handles the wonders of puppet equality checks.+puppetEquality :: PValue -> PValue -> Bool+puppetEquality ra rb =+ case toNumbers ra rb of+ (S.Just (na :!: nb)) -> na == nb+ _ -> case (ra, rb) of+ (PUndef , PBoolean x) -> not x+ (PString "true", PBoolean x) -> x+ (PString "false", PBoolean x) -> not x+ (PBoolean x, PString "true") -> x+ (PBoolean x, PString "false") -> not x+ (PString sa, PString sb) -> CaseInsensitive.mk sa == CaseInsensitive.mk sb+ -- TODO, check if array / hash equality should be recursed+ -- for case insensitive matching+ _ -> ra == rb++-- | The main resolution function : turns an 'Expression' into a 'PValue',+-- if possible.+resolveExpression :: Expression -> InterpreterMonad PValue+resolveExpression (Terminal v) = resolveValue v+resolveExpression (Not e) = fmap (PBoolean . not . pValue2Bool) (resolveExpression e)+resolveExpression (And a b) = do+ ra <- fmap pValue2Bool (resolveExpression a)+ if ra+ then do+ rb <- fmap pValue2Bool (resolveExpression b)+ pure (PBoolean (ra && rb))+ else pure (PBoolean False)+resolveExpression (Or a b) = do+ ra <- fmap pValue2Bool (resolveExpression a)+ if ra+ then pure (PBoolean True)+ else do+ rb <- fmap pValue2Bool (resolveExpression b)+ pure (PBoolean (ra || rb))+resolveExpression (LessThan a b) = numberCompare a b (<)+resolveExpression (MoreThan a b) = numberCompare a b (>)+resolveExpression (LessEqualThan a b) = numberCompare a b (<=)+resolveExpression (MoreEqualThan a b) = numberCompare a b (>=)+resolveExpression (RegexMatch a v@(Terminal (URegexp (CompRegex _ rv)))) = do+ ra <- fmap Text.encodeUtf8 (resolveExpressionString a)+ case Regex.execute' rv ra of+ Left (_,rr) -> throwPosError ("Error when evaluating" <+> pretty v <+> ":" <+> string rr)+ Right Nothing -> pure $ PBoolean False+ Right (Just matches) -> do+ -- A bit of logic to save the capture variables.+ -- Note that this will pollute the namespace, as it should only+ -- happen in conditional expressions ...+ p <- use curPos+ ctype <- view cctype <$> getCurContainer+ let captures = zip (map (Text.pack . show) [(0 :: Int)..]) (map mkMatch (toList matches))+ mkMatch (offset, len) = PString (Text.decodeUtf8 (BS.take len (BS.drop offset ra))) :!: p :!: ctype+ scp <- getScopeName+ scopes . ix scp . scopeVariables %= HM.union (HM.fromList captures)+ pure $ PBoolean True+resolveExpression (RegexMatch _ t) = throwPosError ("The regexp matching operator expects a regular expression, not" <+> pretty t)+resolveExpression (NotRegexMatch a v) = resolveExpression (Not (RegexMatch a v))+resolveExpression (Equal a b) = do+ ra <- resolveExpression a+ rb <- resolveExpression b+ pure $ PBoolean $ puppetEquality ra rb+resolveExpression (Different a b) = resolveExpression (Not (Equal a b))+resolveExpression (Contains idx a) =+ resolveExpression a >>= \case+ PHash h -> do+ ridx <- resolveExpressionString idx+ case h ^. at ridx of+ Just _ -> pure (PBoolean True)+ Nothing -> pure (PBoolean False)+ PArray ar -> do+ ridx <- resolveExpression idx+ pure (PBoolean (ridx `V.elem` ar))+ PString st -> do+ ridx <- resolveExpressionString idx+ pure (PBoolean (ridx `Text.isInfixOf` st))+ src -> throwPosError ("Can't use the 'in' operator with" <+> pretty src)+resolveExpression (Lookup a idx) =+ resolveExpression a >>= \case+ PHash h -> do+ ridx <- resolveExpressionString idx+ case h ^. at ridx of+ Just v -> pure v+ Nothing -> do+ checkStrict+ ("Look up for an hash with the unknown key '" <> ttext ridx <> "' for" <+> pretty (PHash h))+ ("Can't find index '" <> ttext ridx <> "' in" <+> pretty (PHash h))+ pure PUndef+ PArray ar -> do+ ridx <- resolveExpression idx+ i <- case ridx ^? _Integer of+ Just n -> pure (fromIntegral n)+ _ -> throwPosError ("Need an integral number for indexing an array, not" <+> pretty ridx)+ let arl = V.length ar+ if arl <= i+ then throwPosError ("Out of bound indexing, array size is" <+> int arl <+> "index is" <+> int i)+ else pure (ar V.! i)+ src -> throwPosError ("This data can't be indexed:" <+> pretty src)+resolveExpression stmt@(ConditionalValue e conds) = do+ rese <- resolveExpression e+ let checkCond [] = throwPosError ("The selector didn't match anything for input" <+> pretty rese </> pretty stmt)+ checkCond ((SelectorDefault :!: ce) : _) = resolveExpression ce+ checkCond ((SelectorValue v@(URegexp (CompRegex _ rg)) :!: ce) : xs) = do+ rs <- fmap Text.encodeUtf8 (resolvePValueString rese)+ case Regex.execute' rg rs of+ Left (_,rr) -> throwPosError ("Could not match" <+> pretty v <+> ":" <+> string rr)+ Right Nothing -> checkCond xs+ Right (Just _) -> resolveExpression ce+ checkCond ((SelectorType udt :!: ce) : xs) = do+ dt <- resolveDataType udt+ if datatypeMatch dt rese+ then resolveExpression ce+ else checkCond xs+ checkCond ((SelectorValue uv :!: ce) : xs) = do+ rv <- resolveValue uv+ if puppetEquality rese rv+ then resolveExpression ce+ else checkCond xs+ checkCond (V.toList conds)+resolveExpression (Addition a b) = do+ ra <- resolveExpression a+ rb <- resolveExpression b+ case (ra, rb) of+ (PHash ha, PHash hb) -> pure (PHash (ha <> hb))+ (PArray ha, PArray hb) -> pure (PArray (ha <> hb))+ _ -> binaryOperation a b (+)+resolveExpression (Substraction a b) = binaryOperation a b (-)+resolveExpression (Division a b) = do+ ra <- resolveExpressionNumber a+ rb <- resolveExpressionNumber b+ case rb of+ 0 -> throwPosError "Division by 0"+ _ -> case (,) `fmap` preview _Integer ra <*> preview _Integer rb of+ Just (ia, ib) -> pure $ PNumber $ fromIntegral (ia `div` ib)+ _ -> pure $ PNumber $ ra / rb+resolveExpression (Multiplication a b) = binaryOperation a b (*)+resolveExpression (Modulo a b) = integerOperation a b mod+resolveExpression (RightShift a b) = integerOperation a b (\x -> shiftR x . fromIntegral)+resolveExpression (LeftShift a b) = do+ ra <- resolveExpression a+ rb <- resolveExpression b+ case (ra, rb) of+ (PArray ha, v) -> pure (PArray (V.snoc ha v))+ _ -> integerOperation a b (\x -> shiftL x . fromIntegral)+resolveExpression a@(FunctionApplication e (Terminal (UHOLambdaCall hol))) = do+ unless (S.isNothing (hol ^. hoLambdaExpr))+ (throwPosError ("You can't combine chains of higher order functions (with .) and giving them parameters, in:" <+> pretty a))+ resolveValue (UHOLambdaCall (hol & hoLambdaExpr .~ S.Just e))+resolveExpression (FunctionApplication _ x) = throwPosError ("Expected function application here, not" <+> pretty x)+resolveExpression (Negate x) = PNumber . negate <$> resolveExpressionNumber x++-- | Resolves an 'UnresolvedValue' (terminal for the 'Expression' data type) into+-- a 'PValue'+resolveValue :: UnresolvedValue -> InterpreterMonad PValue+resolveValue (UNumber n) = pure (PNumber n)+resolveValue n@(URegexp _) = throwPosError ("Regular expressions are not allowed in this context: " <+> pretty n)+resolveValue (UBoolean x) = pure (PBoolean x)+resolveValue (UString x) = pure (PString x)+resolveValue UUndef = pure PUndef+resolveValue (UInterpolable vals) = fmap (PString . mconcat) (mapM resolveExpressionString (V.toList vals))+resolveValue (UResourceReference t e) = do+ r <- resolveExpressionStrings e+ case r of+ [s] -> pure (PResourceReference t (fixResourceName t s))+ _ -> pure (PArray (V.fromList (map (PResourceReference t . fixResourceName t) r)))+resolveValue (UArray a) = fmap PArray (V.mapM resolveExpression a)+resolveValue (UHash a) =+ fmap (PHash . HM.fromList) (mapM resPair (V.toList a))+ where+ resPair (k :!: v) = (,) `fmap` resolveExpressionString k <*> resolveExpression v+resolveValue (UVariableReference v) = resolveVariable v+resolveValue (UFunctionCall fname args) = resolveFunction fname args+resolveValue (UHOLambdaCall hol) = evaluateHFCPure hol+resolveValue (UDataType dt) = PType <$> resolveDataType dt++-- | Turns strings, numbers and booleans into 'Text', or throws an error.+resolvePValueString :: PValue -> InterpreterMonad Text+resolvePValueString (PString x) = pure x+resolvePValueString (PBoolean True) = pure "true"+resolvePValueString (PBoolean False) = pure "false"+resolvePValueString (PNumber x) = pure (scientific2text x)+resolvePValueString PUndef = do+ checkStrict+ "Resolving the keyword `undef` to the string \"undef\""+ "Strict mode won't convert the keyword `undef` to the string \"undef\""+ pure "undef"+resolvePValueString x = throwPosError ("Don't know how to convert this to a string:" PP.<$> pretty x)++-- | Turns everything it can into a number, or throws an error+resolvePValueNumber :: PValue -> InterpreterMonad Scientific+resolvePValueNumber x =+ case x ^? _Number of+ Just n -> pure n+ Nothing -> throwPosError ("Don't know how to convert this to a number:" PP.<$> pretty x)++-- | > resolveExpressionString = resolveExpression >=> resolvePValueString+resolveExpressionString :: Expression -> InterpreterMonad Text+resolveExpressionString = resolveExpression >=> resolvePValueString++-- | > resolveExpressionNumber = resolveExpression >=> resolvePValueNumber+resolveExpressionNumber :: Expression -> InterpreterMonad Scientific+resolveExpressionNumber = resolveExpression >=> resolvePValueNumber++-- | Just like 'resolveExpressionString', but accepts arrays.+resolveExpressionStrings :: Expression -> InterpreterMonad [Text]+resolveExpressionStrings x =+ resolveExpression x >>= \case+ PArray a -> mapM resolvePValueString (V.toList a)+ y -> fmap pure (resolvePValueString y)++-- | Turns a 'PValue' into a 'Bool', as explained in the reference+-- documentation.+pValue2Bool :: PValue -> Bool+pValue2Bool PUndef = False+pValue2Bool (PString "") = False+pValue2Bool (PBoolean x) = x+pValue2Bool _ = True++-- | This resolve function calls at the expression level.+resolveFunction :: Text -> V.Vector Expression -> InterpreterMonad PValue+resolveFunction "fqdn_rand" args = do+ let nbargs = V.length args+ when (nbargs < 1 || nbargs > 2) (throwPosError "fqdn_rand(): Expects one or two arguments")+ fqdn <- resolveVariable "::fqdn" >>= resolvePValueString+ (mx:targs) <- mapM resolveExpressionString (V.toList args)+ curmax <- case PString mx ^? _Integer of+ Just x -> pure x+ _ -> throwPosError ("fqdn_rand(): the first argument must be an integer, not" <+> ttext mx)+ let rargs = if null targs+ then [fqdn, ""]+ else fqdn : targs+ val = fromIntegral (fst (limitedRand (randInit myhash) (fromIntegral curmax)))+ myhash = toint (md5 (Text.encodeUtf8 fullstring)) :: Integer+ toint = BS.foldl' (\c nx -> c*256 + fromIntegral nx) 0+ fullstring = Text.intercalate ":" rargs+ pure (_Integer # val)+resolveFunction fname args =+ mapM resolveExpression (V.toList args) >>= resolveFunction' fname . map undefEmptyString+ where+ undefEmptyString PUndef = PString ""+ undefEmptyString x = x++resolveFunction' :: Text -> [PValue] -> InterpreterMonad PValue+resolveFunction' "defined" [PResourceReference "class" cn] = do+ checkStrict "The use of the 'defined' function is a code smell"+ "The 'defined' function is not allowed in strict mode."+ fmap (PBoolean . has (ix cn)) (use loadedClasses)+resolveFunction' "defined" [PResourceReference rt rn] = do+ checkStrict "The use of the 'defined' function is a code smell"+ "The 'defined' function is not allowed in strict mode."+ fmap (PBoolean . has (ix (RIdentifier rt rn))) (use definedResources)+resolveFunction' "defined" [ut] = do+ checkStrict "The use of the 'defined' function is a code smell."+ "The 'defined' function is not allowed in strict mode."+ t <- resolvePValueString ut+ if not (Text.null t) && Text.head t == '$' -- variable test+ then do+ scps <- use scopes+ scp <- getScopeName+ pure $ PBoolean $ case getVariable scps scp (Text.tail t) of+ Left _ -> False+ Right _ -> True+ else do -- resource test+ -- case 1, nested thingie+ nestedStuff <- use nestedDeclarations+ if has (ix (TopDefine, t)) nestedStuff || has (ix (TopClass, t)) nestedStuff+ then pure (PBoolean True)+ else do -- case 2, loaded class+ lc <- use loadedClasses+ if has (ix t) lc+ then pure (PBoolean True)+ else fmap PBoolean (isNativeType t)++resolveFunction' "defined" x = throwPosError ("defined(): expects a single resource reference, type or class name, and not" <+> pretty x)+resolveFunction' "fail" x = throwPosError ("fail:" <+> pretty x)+resolveFunction' "inline_template" [] = throwPosError "inline_template(): Expects at least one argument"+resolveFunction' "inline_template" templates = PString . mconcat <$> mapM (calcTemplate Left) templates+resolveFunction' "md5" [pstr] = fmap (PString . Text.decodeUtf8 . B16.encode . md5 . Text.encodeUtf8) (resolvePValueString pstr)+resolveFunction' "md5" _ = throwPosError "md5(): Expects a single argument"+resolveFunction' "regsubst" [ptarget, pregexp, preplacement] = resolveFunction' "regsubst" [ptarget, pregexp, preplacement, PString "G"]+resolveFunction' "regsubst" [ptarget, pregexp, preplacement, pflags] = do+ -- TODO handle all the flags+ -- http://docs.puppetlabs.com/references/latest/function.html#regsubst+ when (pflags /= "G") (use curPos >>= \p -> warn ("regsubst(): Currently only supports a single flag (G) " <> showPos (Tuple.fst p)))+ regexp <- fmap Text.encodeUtf8 (resolvePValueString pregexp)+ replacement <- fmap Text.encodeUtf8 (resolvePValueString preplacement)+ let sub t = do+ t' <- fmap Text.encodeUtf8 (resolvePValueString t)+ case Regex.substituteCompile' regexp t' replacement of+ Left rr -> throwPosError ("regsubst():" <+> string rr)+ Right x -> fmap PString (safeDecodeUtf8 x)+ case ptarget of+ PArray a -> fmap PArray (traverse sub a)+ s -> sub s+resolveFunction' "regsubst" _ = throwPosError "regsubst(): Expects 3 or 4 arguments"+resolveFunction' "split" [psrc, psplt] = do+ src <- fmap Text.encodeUtf8 (resolvePValueString psrc)+ splt <- fmap Text.encodeUtf8 (resolvePValueString psplt)+ case Regex.splitCompile' splt src of+ Left rr -> throwPosError ("splitCompile():" <+> string rr)+ Right x -> fmap (PArray . V.fromList) (mapM (fmap PString . safeDecodeUtf8) x)+resolveFunction' "sha1" [pstr] = fmap (PString . Text.decodeUtf8 . B16.encode . sha1 . Text.encodeUtf8) (resolvePValueString pstr)+resolveFunction' "sha1" _ = throwPosError "sha1(): Expects a single argument"+resolveFunction' "shellquote" args = do+ sargs <- for args $ \arg ->+ case arg of+ PArray vals -> mapM resolvePValueString vals+ _ -> V.singleton <$> resolvePValueString arg+ let escape str | Text.all isSafe str = str+ | not (Text.any isDangerous str) = between "\"" str+ | Text.any (== '\'') str = between "\"" (Text.concatMap escapeDangerous str)+ | otherwise = between "'" str+ isSafe x = Char.isAlphaNum x || x `elem` ("@%_+=:,./-" :: String)+ isDangerous x = x `elem` ("!\"`$\\" :: String)+ escapeDangerous x | isDangerous x = Text.snoc "\\" x+ | otherwise = Text.singleton x+ between c s = c <> s <> c+ pure $ PString $ Text.unwords $ V.toList (escape <$> mconcat sargs)++resolveFunction' "mysql_password" [pstr] = fmap (PString . Text.decodeUtf8 . B16.encode . sha1 . sha1 . Text.encodeUtf8) (resolvePValueString pstr)+resolveFunction' "mysql_password" _ = throwPosError "mysql_password(): Expects a single argument"+resolveFunction' "file" args = do+ rebasefile <- fmap Text.pack <$> Operational.singleton RebaseFile+ let fixFilePath s | Text.null s = let rr = "Empty file path passed to the 'file' function" in checkStrict rr rr >> pure s+ | Text.head s == '/' = pure (maybe s (<> s) rebasefile)+ | otherwise = case Text.splitOn "/" s of+ (md:x:rst) -> do+ moduledir <- view modulesPath <$> getPuppetPaths+ pure (Text.intercalate "/" (Text.pack moduledir : md : "files" : x : rst))+ _ -> throwPosError ("file() argument invalid: " <> ttext s)+ mapM (resolvePValueString >=> fixFilePath) args >>= fmap PString . Operational.singleton . ReadFile++resolveFunction' "tagged" ptags = do+ tags <- fmap HS.fromList (mapM resolvePValueString ptags)+ scp <- getScopeName+ scpset <- use (scopes . ix scp . scopeExtraTags)+ pure (PBoolean (scpset `HS.intersection` tags == tags))+resolveFunction' "template" [] = throwPosError "template(): Expects at least one argument"+resolveFunction' "template" templates = PString . mconcat <$> mapM (calcTemplate Right) templates+resolveFunction' "versioncmp" [pa,pb] = do+ a <- resolvePValueString pa+ b <- resolvePValueString pb+ let parser x =+ case filter (null . snd) (readP_to_S parseVersion (Text.unpack x)) of+ ( (v, _) : _ ) -> v+ _ -> Version [] [] -- fallback :(+ va = parser a+ vb = parser b+ pure $ PString $ case compare va vb of+ EQ -> "0"+ LT -> "-1"+ GT -> "1"+resolveFunction' "versioncmp" _ = throwPosError "versioncmp(): Expects two arguments"+-- | Simplified implementation of sprintf+resolveFunction' "sprintf" (PString str:args) = sprintf str args+resolveFunction' "sprintf" _ = throwPosError "sprintf(): Expects a string as its first argument"+-- some custom functions+resolveFunction' "pdbresourcequery" [q] = pdbresourcequery q Nothing+resolveFunction' "pdbresourcequery" [q,k] = fmap Just (resolvePValueString k) >>= pdbresourcequery q+resolveFunction' "pdbresourcequery" _ = throwPosError "pdbresourcequery(): Expects one or two arguments"+resolveFunction' "hiera" [q] = hieraCall QFirst q Nothing Nothing Nothing+resolveFunction' "hiera" [q,d] = hieraCall QFirst q (Just d) Nothing Nothing+resolveFunction' "hiera" [q,d,o] = hieraCall QFirst q (Just d) Nothing (Just o)+resolveFunction' "hiera_array" [q] = hieraCall QUnique q Nothing Nothing Nothing+resolveFunction' "hiera_array" [q,d] = hieraCall QUnique q (Just d) Nothing Nothing+resolveFunction' "hiera_array" [q,d,o] = hieraCall QUnique q (Just d) Nothing (Just o)+resolveFunction' "hiera_hash" [q] = hieraCall QHash q Nothing Nothing Nothing+resolveFunction' "hiera_hash" [q,d] = hieraCall QHash q (Just d) Nothing Nothing+resolveFunction' "hiera_hash" [q,d,o] = hieraCall QHash q (Just d) Nothing (Just o)+resolveFunction' "lookup" [q] = hieraCall QFirst q Nothing Nothing Nothing+resolveFunction' "lookup" [q, PType dt] = hieraCall QFirst q Nothing (Just dt) Nothing+resolveFunction' "lookup" [q, PType dt, PString t,d] = hieraCall (fromMaybe QFirst (readQueryType t)) q (Just d) (Just dt) Nothing+resolveFunction' "lookup" _ = throwPosError "lookup(): Wrong set of arguments"++-- user functions+resolveFunction' fname args = Operational.singleton (ExternalFunction fname args)++pdbresourcequery :: PValue -> Maybe Text -> InterpreterMonad PValue+pdbresourcequery q mkey = do+ rrv <- case fromJSON (toJSON q) of+ Aeson.Success rq -> Operational.singleton (PDBGetResources rq)+ Aeson.Error rr -> throwPosError ("Invalid resource query:" <+> Puppet.PP.string rr)+ rv <- case fromJSON (toJSON rrv) of+ Aeson.Success x -> pure x+ Aeson.Error rr -> throwPosError ("For some reason we could not convert a resource list to Puppet internal values!!" <+> Puppet.PP.string rr <+> pretty rrv)+ let extractSubHash :: Text -> PValue -> InterpreterMonad PValue+ extractSubHash ky (PHash h) =+ case h ^. at ky of+ Just val -> pure val+ Nothing -> throwPosError ("pdbresourcequery strange error, could not find key" <+> ttext ky <+> "in" <+> pretty (PHash h))+ extractSubHash _ x = throwPosError ("pdbresourcequery strange error, expected a hash, had" <+> pretty x)+ case mkey of+ Nothing -> pure (PArray rv)+ (Just k) -> fmap PArray (V.mapM (extractSubHash k) rv)++calcTemplate :: (Text -> Either Text Text) -> PValue -> InterpreterMonad Text+calcTemplate templatetype templatename = do+ fname <- resolvePValueString templatename+ stt <- use identity+ Operational.singleton (ComputeTemplate (templatetype fname) stt)++resolveExpressionSE :: Expression -> InterpreterMonad PValue+resolveExpressionSE e =+ resolveExpression e >>= \case+ PArray _ -> throwPosError "The use of an array in a search expression is undefined"+ PHash _ -> throwPosError "The use of an array in a search expression is undefined"+ resolved -> pure resolved++-- | Turns an unresolved 'SearchExpression' from the parser into a fully+-- resolved 'RSearchExpression'.+resolveSearchExpression :: SearchExpression -> InterpreterMonad RSearchExpression+resolveSearchExpression AlwaysTrue = pure RAlwaysTrue+resolveSearchExpression (EqualitySearch a e) = REqualitySearch `fmap` pure a <*> resolveExpressionSE e+resolveSearchExpression (NonEqualitySearch a e) = RNonEqualitySearch `fmap` pure a <*> resolveExpressionSE e+resolveSearchExpression (AndSearch e1 e2) = RAndSearch `fmap` resolveSearchExpression e1 <*> resolveSearchExpression e2+resolveSearchExpression (OrSearch e1 e2) = ROrSearch `fmap` resolveSearchExpression e1 <*> resolveSearchExpression e2++-- | Turns a resource type and 'RSearchExpression' into something that can+-- be used in a PuppetDB query.+searchExpressionToPuppetDB :: Text -> RSearchExpression -> Query ResourceField+searchExpressionToPuppetDB rtype res =+ QAnd ( QEqual RType (capitalizeRT rtype) : mkSE res )+ where+ mkSE (RAndSearch a b) = [QAnd (mkSE a ++ mkSE b)]+ mkSE (ROrSearch a b) = [QOr (mkSE a ++ mkSE b)]+ mkSE (RNonEqualitySearch a b) = fmap QNot (mkSE (REqualitySearch a b))+ mkSE (REqualitySearch a (PString b)) = [QEqual (mkFld a) b]+ mkSE _ = []+ mkFld "tag" = RTag+ mkFld "title" = RTitle+ mkFld z = RParameter z++-- | Checks whether a given 'Resource' matches a 'RSearchExpression'. Note+-- that the expression doesn't check for type, so you must filter the+-- resources by type beforehand, if needs be.+checkSearchExpression :: RSearchExpression -> Resource -> Bool+checkSearchExpression RAlwaysTrue _ = True+checkSearchExpression (RAndSearch a b) r = checkSearchExpression a r && checkSearchExpression b r+checkSearchExpression (ROrSearch a b) r = checkSearchExpression a r || checkSearchExpression b r+checkSearchExpression (REqualitySearch "tag" (PString s)) r = r ^. rtags . contains s+checkSearchExpression (REqualitySearch "tag" _) _ = False+checkSearchExpression (REqualitySearch "title" v) r =+ let nameequal = puppetEquality v (PString (r ^. rid . iname))+ aliasequal =+ case r ^. rattributes . at "alias" of+ Just a -> puppetEquality v a+ Nothing -> False+ in nameequal || aliasequal+checkSearchExpression (REqualitySearch attributename v) r =+ case r ^. rattributes . at attributename of+ Nothing -> False+ Just (PArray x) -> any (`puppetEquality` v) x+ Just x -> puppetEquality x v+checkSearchExpression (RNonEqualitySearch attributename v) r+ | attributename == "tag" = True+ | attributename == "title" = not (checkSearchExpression (REqualitySearch attributename v) r)+ | otherwise =+ case r ^. rattributes . at attributename of+ Nothing -> True+ Just (PArray x) -> not (all (`puppetEquality` v) x)+ Just x -> not (puppetEquality x v)++resolveDataType :: UDataType -> InterpreterMonad DataType+resolveDataType ud+ = case ud of+ UDTType -> pure DTType+ UDTString a b -> pure (DTString a b)+ UDTInteger a b -> pure (DTInteger a b)+ UDTFloat a b -> pure (DTFloat a b)+ UDTBoolean -> pure DTBoolean+ UDTArray dt a b -> DTArray <$> resolveDataType dt <*> pure a <*> pure b+ UDTHash dt1 dt2 a b -> DTHash <$> resolveDataType dt1 <*> resolveDataType dt2 <*> pure a <*> pure b+ UDTUndef -> pure DTUndef+ UDTScalar -> pure DTScalar+ UDTData -> pure DTData+ UDTOptional dt -> DTOptional <$> resolveDataType dt+ UNotUndef -> pure NotUndef+ UDTVariant vrs -> DTVariant <$> traverse resolveDataType vrs+ UDTPattern a -> pure (DTPattern a)+ -- will not crash as ens is nonempty+ UDTEnum ens -> DTEnum . NE.fromList . sconcat <$> traverse resolveExpressionStrings ens+ UDTAny -> pure DTAny+ UDTCollection -> pure DTCollection++-- | Generates variable associations for evaluation of blocks. Each item+-- corresponds to an iteration in the calling block.+hfGenerateAssociations :: HOLambdaCall -> InterpreterMonad [[(Text, PValue)]]+hfGenerateAssociations hol = do+ sourceexpression <- case hol ^. hoLambdaExpr of+ S.Just x -> pure x+ S.Nothing -> throwPosError ("No expression to run the function on" <+> pretty hol)+ sourcevalue <- resolveExpression sourceexpression+ let check Nothing _ = pure ()+ check (Just udtype) tocheck = do+ dtype <- resolveDataType udtype+ mapM_ (\v -> unless (datatypeMatch dtype v) (throwPosError (pretty v <+> "isn't of type" <+> pretty dtype))) tocheck+ case (sourcevalue, hol ^. hoLambdaParams) of+ (PArray pr, BPSingle (LParam mvtype varname)) -> do+ check mvtype pr+ pure (map (\x -> [(varname, x)]) (V.toList pr))+ (PArray pr, BPPair (LParam _ idx) (LParam mvtype var)) -> do+ check mvtype pr+ pure [ [(idx,PString (Text.pack (show i))),(var,v)] | (i,v) <- zip ([0..] :: [Int]) (V.toList pr) ]+ (PHash hh, BPSingle (LParam mvtype varname)) -> do+ check mvtype hh+ pure [ [(varname, PArray (V.fromList [PString k,v]))] | (k,v) <- HM.toList hh]+ (PHash hh, BPPair (LParam midxtype idx) (LParam mvtype var)) -> do+ check mvtype hh+ check midxtype (PString <$> HM.keys hh)+ pure [ [(idx,PString k),(var,v)] | (k,v) <- HM.toList hh]+ (invalid, _) -> throwPosError ("Can't iterate on this data type:" <+> pretty invalid)++-- | Sets the proper variables, and returns the scope variables the way+-- they were before being modified. This is a hack that ensures that+-- variables are local to the new scope.+--+-- It doesn't work at all like other Puppet parts, but consistency isn't+-- really expected here ...+hfSetvars :: [(Text, PValue)] -> InterpreterMonad (Container (Pair (Pair PValue PPosition) CurContainerDesc))+hfSetvars vals = do+ scp <- getScopeName+ p <- use curPos+ container <- getCurContainer+ save <- use (scopes . ix scp . scopeVariables)+ let hfSetvar (varname, varval) = scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: (container ^. cctype))+ mapM_ hfSetvar vals+ pure save++-- | Restores what needs restoring. This will erase all allocations.+hfRestorevars :: Container (Pair (Pair PValue PPosition) CurContainerDesc) -> InterpreterMonad ()+hfRestorevars save = do+ scp <- getScopeName+ scopes . ix scp . scopeVariables .= save++-- | Evaluates a statement in "pure" mode. TODO+evalPureStatement :: Statement -> InterpreterMonad ()+evalPureStatement _ = throwPosError "So called 'pure' statements are not yet supported"++-- | This extracts the final expression from an HOLambdaCall.+-- When it does not exists, it checks if the last statement is in fact+-- a function call+transformPureHf :: HOLambdaCall -> InterpreterMonad (HOLambdaCall, Expression)+transformPureHf hol =+ case hol ^. hoLambdaLastExpr of+ S.Just x -> pure (hol, x)+ S.Nothing -> do+ let statements = hol ^. hoLambdaStatements+ if V.null statements+ then throwPosError ("The statement block must not be empty" <+> pretty hol)+ else case V.last statements of+ (MainFunctionDeclaration (MainFuncDecl fn args _)) ->+ let expr = Terminal (UFunctionCall fn args)+ in pure (hol & hoLambdaStatements %~ V.init+ & hoLambdaLastExpr .~ S.Just expr+ , expr)+ _ -> throwPosError ("The statement block must end with an expression" <+> pretty hol)++-- | All the "higher order function" stuff, for "value" mode. In this case+-- we are in "pure" mode, and only a few statements are allowed.+evaluateHFCPure :: HOLambdaCall -> InterpreterMonad PValue+evaluateHFCPure hol' = do+ (hol, finalexpression) <- transformPureHf hol'+ varassocs <- hfGenerateAssociations hol+ let runblock :: [(Text, PValue)] -> InterpreterMonad PValue+ runblock assocs = do+ saved <- hfSetvars assocs+ V.mapM_ evalPureStatement (hol ^. hoLambdaStatements)+ r <- resolveExpression finalexpression+ hfRestorevars saved+ pure r+ case hol ^. hoLambdaFunc of+ LambEach -> throwPosError "The 'each' function can't be used at the value level in language-puppet. Please use map."+ LambMap -> fmap (PArray . V.fromList) (mapM runblock varassocs)+ LambFilter -> do+ res <- mapM (fmap pValue2Bool . runblock) varassocs+ sourcevalue <- case hol ^. hoLambdaExpr of+ S.Just x -> resolveExpression x+ S.Nothing -> throwPosError "Internal error evaluateHFCPure 1"+ case sourcevalue of+ PArray ar -> pure $ PArray $ V.map fst $ V.filter snd $ V.zip ar (V.fromList res)+ PHash hh -> pure $ PHash $ HM.fromList $ map fst $ filter snd $ 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)++-- | Checks that a value matches a puppet datatype+datatypeMatch :: DataType -> PValue -> Bool+datatypeMatch dt v =+ case dt of+ DTType -> has _PType v+ DTUndef -> v == PUndef+ NotUndef -> v /= PUndef+ DTString mmin mmax -> boundedBy _PString Text.length mmin mmax+ DTInteger mmin mmax -> boundedBy (_PNumber . to Scientific.toBoundedInteger . _Just) identity mmin mmax+ DTFloat mmin mmax -> boundedBy _PNumber Scientific.toRealFloat mmin mmax+ DTBoolean -> has _PBoolean v+ DTArray sdt mi mmx -> container (_PArray . to V.toList) (datatypeMatch sdt) mi mmx+ DTHash kt sdt mi mmx -> container (_PHash . to itoList) (\(k,a) -> datatypeMatch kt (PString k) && datatypeMatch sdt a) mi mmx+ DTScalar -> datatypeMatch (DTVariant (DTInteger Nothing Nothing :| [DTString Nothing Nothing, DTBoolean])) v+ DTData -> datatypeMatch (DTVariant (DTScalar :| [DTArray DTData 0 Nothing, DTHash DTScalar DTData 0 Nothing])) v+ DTOptional sdt -> datatypeMatch (DTVariant (DTUndef :| [sdt])) v+ DTVariant sdts -> any (`datatypeMatch` v) sdts+ DTEnum lst -> maybe False (`elem` lst) (v ^? _PString)+ DTAny -> True+ DTCollection -> datatypeMatch (DTVariant (DTArray DTData 0 Nothing :| [DTHash DTScalar DTData 0 Nothing])) v+ DTPattern patterns -> maybe False (\str -> any (checkPattern (Text.encodeUtf8 str)) patterns) (v ^? _PString)+ where+ checkPattern str (CompRegex _ ptrn) =+ case Regex.execute' ptrn str of+ Right (Just _) -> True+ _ -> False+ container :: Fold PValue [a] -> (a -> Bool) -> Int -> Maybe Int -> Bool+ container f c mi mmx =+ let lst = v ^. f+ ln = length lst+ in ln >= mi && (fmap (ln <=) mmx /= Just False) && all c lst+ boundedBy :: Ord b => Fold PValue a -> (a -> b) -> Maybe b -> Maybe b -> Bool+ boundedBy prm f mmin mmax =+ fromMaybe False $ do+ vr <- f <$> v ^? prm+ pure $ and (catMaybes [fmap (vr >=) mmin, fmap (vr <=) mmax])
+ src/Puppet/Interpreter/Resolve/Sprintf.hs view
@@ -0,0 +1,143 @@+module Puppet.Interpreter.Resolve.Sprintf (+ sprintf+) where++import Puppet.Prelude++import Data.Attoparsec.Text+import qualified Data.Text as Text+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TB+import qualified Data.Text.Lazy.Builder.Int as TB+import qualified Data.Text.Lazy.Builder.Scientific as TB+++import Puppet.Interpreter.Types+import Puppet.Interpreter.Utils+import Puppet.PP (pretty)+import Puppet.Interpreter.PrettyPrinter()++data Flag = Minus | Plus | Space | Zero | Hash+ deriving (Show, Eq)++data FLen = Lhh | Lh | Ll | Lll | LL | Lz | Lj | Lt+ deriving (Show, Eq)++data FType = TPct | Td | Tu | Tf | TF | Te | TE | Tg | TG | Tx | TX | To | Ts | Tc | Tp | Ta | TA+ deriving (Show, Eq)++data PrintfFormat = PrintfFormat { _pfFlags :: [Flag]+ , _pfWidth :: Maybe Int+ , _pfPrec :: Maybe Int+ , _pfLen :: Maybe FLen+ , _pfType :: FType+ } deriving (Show, Eq)++data FormatStringPart = Raw Text+ | Format PrintfFormat+ deriving (Show, Eq)++parseFormat :: Text -> [FormatStringPart]+parseFormat t | Text.null t = []+ | Text.null nxt = [Raw raw]+ | otherwise = Raw raw : rformat+ where+ (raw, nxt) = Text.break (== '%') t+ tryNext = case parseFormat (Text.tail nxt) of+ (Raw nt : nxt') -> Raw (Text.cons '%' nt) : nxt'+ nxt' -> Raw (Text.singleton '%') : nxt'+ rformat = case parse format nxt of+ Fail _ _ _ -> tryNext+ Partial _ -> tryNext+ Done remaining f -> Format f : parseFormat remaining++flag :: Parser Flag+flag = (Minus <$ char '-')+ <|> (Plus <$ char '+')+ <|> (Space <$ char ' ')+ <|> (Zero <$ char '0')+ <|> (Hash <$ char '#')++lenModifier :: Parser FLen+lenModifier = (Lhh <$ string "hh")+ <|> (Lh <$ char 'h')+ <|> (Lll <$ string "ll")+ <|> (Ll <$ char 'l')+ <|> (LL <$ char 'L')+ <|> (Lz <$ char 'z')+ <|> (Lj <$ char 'j')+ <|> (Lt <$ char 't')++ftype :: Parser FType+ftype = (TPct <$ char '%')+ <|> (Td <$ char 'd')+ <|> (Td <$ char 'i')+ <|> (Tu <$ char 'u')+ <|> (Tf <$ char 'f')+ <|> (TF <$ char 'F')+ <|> (Te <$ char 'e')+ <|> (TE <$ char 'E')+ <|> (Tg <$ char 'g')+ <|> (TG <$ char 'G')+ <|> (Tx <$ char 'x')+ <|> (TX <$ char 'X')+ <|> (To <$ char 'o')+ <|> (Ts <$ char 's')+ <|> (Tc <$ char 'c')+ <|> (Ta <$ char 'a')+ <|> (Tp <$ char 'p')+ <|> (TA <$ char 'A')++format :: Parser PrintfFormat+format = do+ void $ char '%'+ flags <- many flag+ width <- optional decimal+ prec <- optional $ do+ void $ char '.'+ decimal+ len <- optional lenModifier+ ft <- ftype+ return (PrintfFormat flags width prec len ft)++sprintf :: Text -> [PValue] -> InterpreterMonad PValue+sprintf str oargs = PString . TL.toStrict . TB.toLazyText . mconcat <$> go (parseFormat str) oargs+ where+ go (Raw x : xs) args = (TB.fromText x :) <$> go xs args+ go (Format f : _) _ | Hash `elem` _pfFlags f = throwPosError "sprintf: the # modifier is not supported"+ go (Format f : xs) (arg : args) = do+ let numeric = case arg of+ PNumber n -> pure n+ PString s -> maybe (throwError "sprintf: Don't know how to convert this to a number") return (text2Scientific s)+ _ -> throwError "sprintf: Don't know how to convert this to a number"+ flags = _pfFlags f+ sh mkBuilder n | has_ Minus = TL.justifyLeft padlen ' ' (sprefix <> content)+ | has_ Plus && has_ Zero = sprefix <> TL.justifyRight mpadlen '0' content+ | has_ Plus = TL.justifyRight padlen ' ' (sprefix <> content)+ | has_ Zero = TL.justifyRight padlen '0' content+ | otherwise = TL.justifyRight padlen ' ' content+ where+ (mpadlen, sprefix) | Plus `elem` flags && n >= 0 = (padlen - 1, "+")+ | Space `elem` flags && n >= 0 = (padlen - 1, " ")+ | otherwise = (padlen, mempty)+ padlen = maybe 0 fromIntegral (_pfWidth f)+ has_ flg = flg `elem` flags+ content = TB.toLazyText (mkBuilder n)+ baseString <- case _pfType f of+ Td -> sh (TB.formatScientificBuilder TB.Fixed (Just 0)) <$> numeric+ Tf -> sh (TB.formatScientificBuilder TB.Fixed (_pfPrec f)) <$> numeric+ TF -> sh (TB.formatScientificBuilder TB.Fixed (_pfPrec f)) <$> numeric+ Tg -> sh (TB.formatScientificBuilder TB.Generic (_pfPrec f)) <$> numeric+ TG -> sh (TB.formatScientificBuilder TB.Generic (_pfPrec f)) <$> numeric+ Te -> sh (TB.formatScientificBuilder TB.Exponent (_pfPrec f)) <$> numeric+ TE -> sh (TB.formatScientificBuilder TB.Exponent (_pfPrec f)) <$> numeric+ Tx -> sh (TB.hexadecimal . (truncate :: Scientific -> Integer)) <$> numeric+ TX -> sh (TB.hexadecimal . (truncate :: Scientific -> Integer)) <$> numeric+ Ts -> return $ case arg of+ PString s -> TL.fromStrict s+ _ -> TL.pack (show (pretty arg))+ _ -> throwPosError "sprintf: not yet supported"+ (TB.fromLazyText baseString :) <$> go xs args+ go [] [] = return []+ go _ [] = throwPosError "sprintf: not enough arguments"+ go [] _ = [] <$ let msg = "sprintf: too many arguments" in checkStrict msg msg
+ src/Puppet/Interpreter/RubyRandom.hs view
@@ -0,0 +1,120 @@+module Puppet.Interpreter.RubyRandom (rbGenrandInt32, randInit, limitedRand) where++import Puppet.Prelude++import qualified Data.Vector.Unboxed as V+import qualified Data.Vector.Unboxed.Mutable as VM+import qualified Data.List as List++data RandState = RandState { _array :: V.Vector Int+ , _left :: Int+ , _initf :: Int+ , _next :: Int+ } deriving (Show)++mixbits :: Int -> Int -> Int+mixbits u v = (u .&. 0x80000000) .|. (v .&. 0x7fffffff)++twist :: Int -> Int -> Int+twist u v = (mixbits u v `shiftR` 1) `xor` ma+ where+ ma = if (v .&. 1) == 1+ then 0x9908b0df+ else 0++valN :: Int+valN = 624+valM :: Int+valM = 397++initGenrand :: Integer -> RandState+initGenrand rseed = RandState (V.fromList (scanl genfunc seed [1..(valN - 1)])) 1 1 0+ where+ seed = fromIntegral rseed .&. 0xffffffff+ genfunc :: Int -> Int -> Int+ genfunc curval x = (1812433253 * (curval `xor` (curval `shiftR` 30)) + x) .&. 0xffffffff++nextState :: RandState -> RandState+nextState (RandState array _ initf _) = RandState narray valN 1 0+ where+ rarray = if initf == 0+ then _array (initGenrand 5489)+ else array+ narray = V.modify (\v -> twist1 v >> twist2 v >> final v) rarray+ twist1 v = mapM_ (twist' valM v) [0..(valN - valM - 1)]+ twist2 v = mapM_ (twist' (valM - valN) v) [(valN - valM) .. (valN - 2)]+ final v = do+ a <- VM.read v (valN - 1)+ b <- VM.read v 0+ pm <- VM.read v (valM - 1)+ let res = pm `xor` twist a b+ VM.write v (valN - 1) res+ twist' idx v n = do+ a <- VM.read v n+ b <- VM.read v (n+1)+ pm <- VM.read v (idx + n)+ let res = pm `xor` twist a b+ VM.write v n res++-- needs refactoring, too tedious for me+initGenrandBigint :: Integer -> RandState+initGenrandBigint seed =+ let intarray = unfoldr reduceint seed+ reduceint :: Integer -> Maybe (Integer, Integer)+ reduceint 0 = Nothing+ reduceint x = Just (x .&. 0xffffffff, x `shiftR` 32)+ initstate = _array (initGenrand 19650218)+ keylist = concat (repeat intarray)+ jlist = concat (repeat [0..(length intarray - 1)])+ kmax = max (length intarray) valN+ state1 = foldl' apply1 initstate (List.zip3 keylist jlist [1..kmax])+ apply1 :: V.Vector Int -> (Integer, Int, Int) -> V.Vector Int+ apply1 ra (initKey, j, ri) =+ let (a, i, sti, stim) = rollover ra ri+ nsti = ((sti `xor` ((stim `xor` (stim `shiftR` 30)) * 1664525)) + fromIntegral initKey + j) .&. 0xffffffff+ in a V.// [(i,nsti)]+ state2 = foldl' apply2 state1 [2..valN]+ rollover :: V.Vector Int -> Int -> (V.Vector Int, Int, Int, Int)+ rollover ra ri =+ let (a,i) = if ri >= valN+ then (ra V.// [(0, ra V.! (valN-1))],1)+ else (ra,ri)+ in (a,i,a V.! i, a V.! (i-1))+ apply2 :: V.Vector Int -> Int -> V.Vector Int+ apply2 ra ri =+ let (a, i, sti, stim) = rollover ra ri+ nsti = ((sti `xor` ((stim `xor` (stim `shiftR` 30)) * 1566083941)) - i) .&. 0xffffffff+ in a V.// [(i,nsti)]+ in RandState (state2 V.// [(0,0x80000000)]) 1 1 0+++randInit :: Integer -> RandState+randInit x = if x <= 0xffffffff+ then initGenrand x+ else initGenrandBigint x++rbGenrandInt32 :: RandState -> (Int, RandState)+rbGenrandInt32 st =+ let rst = if _left st == 1+ then nextState st+ else st { _left = _left st - 1 }+ next = _next rst+ cv = _array rst V.! next+ nst = rst { _next = next + 1 }+ y1 = cv `xor` (cv `shiftR` 11)+ y2 = y1 `xor` ((y1 `shiftL` 7) .&. 0x9d2c5680)+ y3 = y2 `xor` ((y2 `shiftL` 15) .&. 0xefc60000)+ y4 = y3 `xor` (y3 `shiftR` 18)+ in (y4,nst)++limitedRand :: RandState -> Int -> (Int, RandState)+limitedRand s n | n <= 0 = (0, s)+ | otherwise = limitedRand' s+ where+ masked = foldl' (\x pow -> x .|. (x `shiftR` pow)) (n - 1) [1,2,4,8,16,32]+ limitedRand' s' =+ let (rval, ns) = rbGenrandInt32 s'+ val = rval .&. masked+ in if n <= val+ then limitedRand' ns+ else (val, ns)
+ src/Puppet/Interpreter/Types.hs view
@@ -0,0 +1,787 @@+{-# LANGUAGE AutoDeriveTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Puppet.Interpreter.Types (+ -- * Record & lenses+ HasResource(..)+ , Resource(Resource)+ , HasResDefaults(..)+ , ResDefaults(ResDefaults)+ , HasLinkInformation(..)+ , LinkInformation(LinkInformation)+ , HasRIdentifier(..)+ , HieraQueryLayers(HieraQueryLayers)+ , HasHieraQueryLayers(..)+ , RIdentifier(RIdentifier)+ , HasScopeInformation(..)+ , ScopeInformation(ScopeInformation)+ , ScopeEnteringContext(..)+ , HasResourceModifier(..)+ , ResourceModifier(ResourceModifier)+ , HasIoMethods(..)+ , IoMethods(IoMethods)+ , HasCurContainer(..)+ , CurContainer(CurContainer)+ , HasNativeTypeMethods(..)+ , NativeTypeMethods(NativeTypeMethods)+ , NodeInfo(NodeInfo)+ , HasNodeInfo(..)+ , FactInfo(FactInfo)+ , HasFactInfo(..)+ , HasWireCatalog(..)+ -- ** Operational instructions+ , InterpreterInstr(..)+ , HasInterpreterReader(..)+ , InterpreterReader(InterpreterReader)+ , HasInterpreterState(..)+ , InterpreterState(InterpreterState)+ -- * Sum types+ -- ** PValue+ , PValue(..)+ , _PType+ , _PBoolean+ , _PString+ , _PResourceReference+ , _PArray+ , _PHash+ , _PNumber+ , _PUndef+ -- ** Misc+ , DataType(..)+ , CurContainerDesc(..)+ , ResourceCollectorType(..)+ , RSearchExpression(..)+ , Query(..)+ , ModifierType(..)+ , NodeField+ , Strictness(..)+ , HieraQueryType(..)+ , WireCatalog(..)+ , TopLevelType(..)+ , FactField(..)+ , ResRefOverride(..)+ , ResourceField(..)+ , OverrideType(..)+ , ClassIncludeType(..)+ -- ** PuppetDB+ , PuppetEdge(PuppetEdge)+ , PuppetDBAPI(..)+ -- * newtype & synonym+ , PrettyError(..)+ , InterpreterMonad+ , InterpreterWriter+ , FinalCatalog+ , NativeTypeValidate+ , NodeName+ , Container+ , HieraQueryFunc+ , Scope+ , Facts+ , EdgeMap+ -- * Classes+ , MonadThrowPos(..)+ -- * Definitions+ , metaparameters+ , showPos+) where++import Puppet.Prelude hiding (show)++import Control.Lens hiding (Strict)+import Control.Monad.Operational+import Control.Monad.State.Strict+import Control.Monad.Writer.Class+import Data.Aeson as A+import Data.Aeson.TH+import Data.Aeson.Lens+import qualified Data.Either.Strict as S+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.Maybe.Strict as S+import Data.String (IsString (..))+import qualified Data.Text as Text+import qualified Data.List as List+import Data.Time.Clock+import qualified Data.Traversable as TR+import qualified Data.Vector as V+import Foreign.Ruby.Helpers+import GHC.Show (Show (..))+import GHC.Stack+import qualified System.Log.Logger as Log+import Text.Megaparsec.Pos+import Web.HttpApiData (ToHttpApiData (..))++import Puppet.Parser.PrettyPrinter+import Puppet.Parser.Types+import Puppet.Paths+import Puppet.PP hiding (rational)++metaparameters :: HS.HashSet Text+metaparameters = HS.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"]++type NodeName = Text+type Container = HM.HashMap Text+type Scope = Text+type Facts = Container PValue++newtype PrettyError = PrettyError { getError :: Doc }++instance Show PrettyError where+ show = show . getError++instance Monoid PrettyError where+ mempty = PrettyError mempty+ mappend a b = PrettyError $ getError a <+> getError b++instance IsString PrettyError where+ fromString = PrettyError . string++instance Exception PrettyError++instance Pretty PrettyError where+ pretty = getError++data PValue = PBoolean !Bool+ | PUndef+ | PString !Text -- integers and doubles are internally serialized as strings by puppet+ | PResourceReference !Text !Text+ | PArray !(V.Vector PValue)+ | PHash !(Container PValue)+ | PNumber !Scientific+ | PType DataType+ deriving (Eq, Show)++instance IsString PValue where+ fromString = PString . Text.pack++instance AsNumber PValue where+ _Number = prism num2PValue toNumber+ where+ num2PValue :: Scientific -> PValue+ num2PValue = PNumber+ toNumber :: PValue -> Either PValue Scientific+ toNumber (PNumber n) = Right n+ toNumber p@(PString x) = case text2Scientific x of+ Just o -> Right o+ _ -> Left p+ toNumber p = Left p++-- | The different kind of hiera queries.+data HieraQueryType+ = QFirst -- ^ standard hiera query+ | QUnique -- ^ hiera_array+ | QHash -- ^ hiera_hash+ | QDeep+ { _knockoutPrefix :: Maybe Text+ , _sortMerged :: Bool+ , _mergeHashArray :: Bool+ } deriving (Show)++-- | The type of the Hiera API function associated to given hierarchy.+type HieraQueryFunc m = Container Text -- ^ Scope: all variables that Hiera can interpolate (the top level ones are prefixed with ::)+ -> Text -- ^ The query+ -> HieraQueryType+ -> m (S.Either PrettyError (Maybe PValue))++-- | All available queries including the global and module layer+-- The environment layer is not implemented+data HieraQueryLayers m+ = HieraQueryLayers+ {+ _globalLayer :: HieraQueryFunc m+ , _moduleLayer :: Container (HieraQueryFunc m)+ }+++-- | The intepreter can run in two modes : a strict mode (recommended), and+-- a permissive mode.+data Strictness = Strict | Permissive+ deriving (Show, Eq)++instance FromJSON Strictness where+ parseJSON (Bool True) = pure Strict+ parseJSON (Bool False) = pure Permissive+ parseJSON _ = mzero++data RSearchExpression = REqualitySearch !Text !PValue+ | RNonEqualitySearch !Text !PValue+ | RAndSearch !RSearchExpression !RSearchExpression+ | ROrSearch !RSearchExpression !RSearchExpression+ | RAlwaysTrue+ deriving (Show, Eq)++-- | Puppet has two main ways to declare classes: include-like and resource-like+-- See <https://docs.puppetlabs.com/puppet/latest/reference/lang_classes.html#include-like-vs-resource-like puppet reference>+data ClassIncludeType = ClassIncludeLike -- ^ using the include or contain function+ | ClassResourceLike -- ^ resource like declaration+ deriving (Eq)++-- | This type is used to differenciate the distinct top level types that are exposed by the DSL.+data TopLevelType+ -- |This is for node entries.+ = TopNode+ -- |This is for defines.+ | TopDefine+ -- |This is for classes.+ | TopClass+ deriving (Generic,Eq)++instance Hashable TopLevelType++-- | From the evaluation of Resource Default Declaration+data ResDefaults = ResDefaults+ { _resDefType :: !Text+ , _resDefSrcScope :: !Text+ , _resDefValues :: !(Container PValue)+ , _resDefPos :: !PPosition+ }++-- | From the evaluation of Resource Override Declaration+data ResRefOverride = ResRefOverride+ { _rrid :: !RIdentifier+ , _rrparams :: !(Container PValue)+ , _rrpos :: !PPosition+ } deriving (Eq)++data CurContainerDesc = ContRoot -- ^ Contained at node or root level+ | ContClass !Text -- ^ Contained in a class+ | ContDefine !Text !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, Show)++data ScopeEnteringContext = SENormal+ | SEChild !Text -- ^ We enter the scope as the child of another class+ | SEParent !Text -- ^ We enter the scope as the parent of another class++-- TODO related to Scope: explain ...+data CurContainer = CurContainer+ { _cctype :: !CurContainerDesc+ , _cctags :: !(HS.HashSet Text)+ } deriving (Eq)++data ScopeInformation = ScopeInformation+ { _scopeVariables :: !(Container (Pair (Pair PValue PPosition) CurContainerDesc))+ , _scopeResDefaults :: !(Container ResDefaults)+ , _scopeExtraTags :: !(HS.HashSet Text)+ , _scopeContainer :: !CurContainer+ , _scopeOverrides :: !(HM.HashMap RIdentifier ResRefOverride)+ , _scopeParent :: !(S.Maybe 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,Text) Statement)+ , _extraRelations :: ![LinkInformation]+ , _resMod :: ![ResourceModifier]+ }++data InterpreterReader m = InterpreterReader+ { _readerNativeTypes :: !(Container NativeTypeMethods)+ , _readerGetStatement :: TopLevelType -> Text -> m (S.Either PrettyError Statement)+ , _readerGetTemplate :: Either Text Text -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError Text)+ , _readerPdbApi :: PuppetDBAPI m+ , _readerExternalFunc :: Container ([PValue] -> InterpreterMonad PValue) -- ^ external func such as stdlib or puppetlabs+ , _readerNodename :: Text+ , _readerHieraQuery :: HieraQueryLayers m+ , _readerIoMethods :: IoMethods m+ , _readerIgnoredModules :: HS.HashSet Text+ , _readerExternalModules :: HS.HashSet Text+ , _readerIsStrict :: Bool+ , _readerPuppetPaths :: PuppetDirPaths+ , _readerRebaseFile :: Maybe FilePath+ }++data IoMethods m = IoMethods+ { _ioGetCurrentCallStack :: m [String]+ , _ioReadFile :: [Text] -> m (Either String Text)+ , _ioTraceEvent :: String -> m ()+ }++data InterpreterInstr a where+ -- Utility for using what's in "InterpreterReader"+ GetNativeTypes :: InterpreterInstr (Container NativeTypeMethods)+ GetStatement :: TopLevelType -> Text -> InterpreterInstr Statement+ ComputeTemplate :: Either Text Text -> InterpreterState -> InterpreterInstr Text+ ExternalFunction :: Text -> [PValue] -> InterpreterInstr PValue+ GetNodeName :: InterpreterInstr Text+ HieraQuery :: Container Text -> Text -> HieraQueryType -> InterpreterInstr (Maybe PValue)+ GetCurrentCallStack :: InterpreterInstr [String]+ IsIgnoredModule :: Text -> InterpreterInstr Bool+ IsExternalModule :: Text -> InterpreterInstr Bool+ IsStrict :: InterpreterInstr Bool+ PuppetPaths :: InterpreterInstr PuppetDirPaths+ RebaseFile :: InterpreterInstr (Maybe FilePath)+ -- error+ ErrorThrow :: PrettyError -> InterpreterInstr a+ ErrorCatch :: InterpreterMonad a -> (PrettyError -> InterpreterMonad a) -> InterpreterInstr a+ -- writer+ WriterTell :: InterpreterWriter -> InterpreterInstr ()+ WriterPass :: InterpreterMonad (a, InterpreterWriter -> InterpreterWriter) -> InterpreterInstr a+ WriterListen :: InterpreterMonad a -> InterpreterInstr (a, InterpreterWriter)+ -- puppetdb wrappers, see 'PuppetDBAPI' for details+ PDBInformation :: InterpreterInstr Doc+ PDBReplaceCatalog :: WireCatalog -> InterpreterInstr ()+ PDBReplaceFacts :: [(NodeName, Facts)] -> InterpreterInstr ()+ PDBDeactivateNode :: NodeName -> InterpreterInstr ()+ PDBGetFacts :: Query FactField -> InterpreterInstr [FactInfo]+ PDBGetResources :: Query ResourceField -> InterpreterInstr [Resource]+ PDBGetNodes :: Query NodeField -> InterpreterInstr [NodeInfo]+ PDBCommitDB :: InterpreterInstr ()+ PDBGetResourcesOfNode :: NodeName -> Query ResourceField -> InterpreterInstr [Resource]+ -- Reading the first file that can be read in a list+ ReadFile :: [Text] -> InterpreterInstr Text+ -- Tracing events+ TraceEvent :: String -> InterpreterInstr ()++-- | The main monad+type InterpreterMonad = ProgramT InterpreterInstr (State InterpreterState)++instance MonadError PrettyError InterpreterMonad where+ throwError = singleton . ErrorThrow+ catchError a c = singleton (ErrorCatch a c)++-- | Log+type InterpreterWriter = [Pair Log.Priority Doc]+instance MonadWriter InterpreterWriter InterpreterMonad where+ tell = singleton . WriterTell+ pass = singleton . WriterPass+ listen = singleton . WriterListen++data RIdentifier = RIdentifier+ { _itype :: !Text+ , _iname :: !Text+ } deriving (Show,Eq,Generic,Ord)++instance Hashable RIdentifier++data ResourceModifier = ResourceModifier+ { _rmResType :: !Text+ , _rmModifierType :: !ModifierType+ , _rmType :: !ResourceCollectorType+ , _rmSearch :: !RSearchExpression+ , _rmMutation :: !(Resource -> InterpreterMonad Resource)+ , _rmDeclaration :: !PPosition+ }++instance Show ResourceModifier where+ show (ResourceModifier rt mt ct se _ p) = List.unwords ["ResourceModifier", show rt, show mt, show ct, "(" ++ show se ++ ")", "???", show p]++data ModifierType = ModifierCollector -- ^ For collectors, optional resources+ | ModifierMustMatch -- ^ For stuff like realize+ deriving (Show, Eq)++data OverrideType = CantOverride -- ^ Overriding forbidden, will throw an error+ | Replace -- ^ Can silently replace+ | CantReplace -- ^ Silently ignore errors+ | AppendAttribute -- ^ Can append values+ deriving (Show, Eq)++data ResourceCollectorType = RealizeVirtual+ | RealizeCollected+ | DontRealize+ deriving (Show, Eq)++data LinkInformation = LinkInformation+ { _linksrc :: !RIdentifier+ , _linkdst :: !RIdentifier+ , _linkType :: !LinkType+ , _linkPos :: !PPosition+ } deriving Show++type EdgeMap = HM.HashMap RIdentifier [LinkInformation]++{-| A fully resolved puppet resource that will be used in the 'FinalCatalog'. -}+data Resource = Resource+ { _rid :: !RIdentifier -- ^ Resource name.+ , _ralias :: !(HS.HashSet Text) -- ^ All the resource aliases+ , _rattributes :: !(Container PValue) -- ^ Resource parameters.+ , _rrelations :: !(HM.HashMap RIdentifier (HS.HashSet LinkType)) -- ^ Resource relations.+ , _rscope :: ![CurContainerDesc] -- ^ Resource scope when it was defined, the real container will be the first item+ , _rvirtuality :: !Virtuality+ , _rtags :: !(HS.HashSet Text)+ , _rpos :: !PPosition -- ^ Source code position of the resource definition.+ , _rnode :: !NodeName -- ^ The node were this resource was created, if remote+ }+ deriving (Eq, Show)++type NativeTypeValidate = Resource -> Either PrettyError Resource++-- | Attributes (and providers) of a puppet resource type bundled with validation rules+data NativeTypeMethods = NativeTypeMethods+ { _puppetValidate :: NativeTypeValidate+ , _puppetFields :: HS.HashSet Text+ }++type FinalCatalog = HM.HashMap RIdentifier Resource++-- | Used to represent a relationship between two resources within the wired format (json).+-- See <http://docs.puppetlabs.com/puppetdb/2.3/api/wire_format/catalog_format_v5.html#data-type-edge>+data PuppetEdge = PuppetEdge RIdentifier RIdentifier LinkType deriving Show++-- | Wire format+--+-- See <http://docs.puppetlabs.com/puppetdb/1.5/api/wire_format/catalog_format.html puppet reference>.+data WireCatalog = WireCatalog+ { _wireCatalogNodename :: !NodeName+ , _wireCatalogVersion :: !Text+ , _wireCatalogEdges :: !(V.Vector PuppetEdge)+ , _wireCatalogResources :: !(V.Vector Resource)+ , _wireCatalogTransactionUUID :: !Text+ } deriving Show++data FactInfo = FactInfo+ { _factInfoNodename :: !NodeName+ , _factInfoName :: !Text+ , _factInfoVal :: !PValue+ }++data NodeInfo = NodeInfo+ { _nodeInfoName :: !NodeName+ , _nodeInfoDeactivated :: !Bool+ , _nodeInfoCatalogT :: !(S.Maybe UTCTime)+ , _nodeInfoFactsT :: !(S.Maybe UTCTime)+ , _nodeInfoReportT :: !(S.Maybe UTCTime)+ }++data PuppetDBAPI m = PuppetDBAPI+ { pdbInformation :: m Doc+ , replaceCatalog :: WireCatalog -> ExceptT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>+ , replaceFacts :: [(NodeName, Facts)] -> ExceptT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>+ , deactivateNode :: NodeName -> ExceptT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>+ , getFacts :: Query FactField -> ExceptT PrettyError m [FactInfo] -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>+ , getResources :: Query ResourceField -> ExceptT PrettyError m [Resource] -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>+ , getNodes :: Query NodeField -> ExceptT PrettyError m [NodeInfo]+ , commitDB :: ExceptT PrettyError m () -- ^ This is only here to tell the test PuppetDB to save its content to disk.+ , getResourcesOfNode :: NodeName -> Query ResourceField -> ExceptT PrettyError m [Resource]+ }++-- | Pretty straightforward way to define the various PuppetDB queries+data Query a = QEqual a Text+ | QG a Integer+ | QL a Integer+ | QGE a Integer+ | QLE a Integer+ | QMatch Text Text+ | QAnd [Query a]+ | QOr [Query a]+ | QNot (Query a)+ | QEmpty++-- | Fields for the fact endpoint+data FactField = FName+ | FValue+ | FCertname++-- | Fields for the node endpoint+data NodeField = NName | NFact Text++-- | Fields for the resource endpoint+data ResourceField = RTag+ | RCertname+ | RParameter Text+ | RType+ | RTitle+ | RExported+ | RFile+ | RLine++data DataType+ = DTType+ | DTString (Maybe Int) (Maybe Int)+ | DTInteger (Maybe Int) (Maybe Int)+ | DTFloat (Maybe Double) (Maybe Double)+ | DTBoolean+ | DTArray DataType Int (Maybe Int)+ | DTHash DataType DataType Int (Maybe Int)+ | DTUndef+ | DTScalar+ | DTData+ | DTOptional DataType+ | NotUndef+ | DTVariant (NonEmpty DataType)+ | DTPattern (NonEmpty CompRegex)+ | DTEnum (NonEmpty Text)+ | DTAny+ | DTCollection+ deriving (Show, Eq)++makeClassy ''RIdentifier+makeClassy ''ResRefOverride+makeClassy ''LinkInformation+makeClassy ''ResDefaults+makeClassy ''ResourceModifier+makeClassy ''NativeTypeMethods+makeClassy ''ScopeInformation+makeClassy ''Resource+makeClassy ''InterpreterState+makeClassy ''InterpreterReader+makeClassy ''IoMethods+makeClassy ''CurContainer+makeClassy ''NodeInfo+makeClassy ''WireCatalog+makeClassy ''FactInfo+makeClassy ''HieraQueryLayers+makePrisms ''PValue++$(deriveJSON defaultOptions ''DataType)++class Monad m => MonadThrowPos m where+ throwPosError :: Doc -> m a++-- Useful for mocking for instance in a REPL+instance MonadThrowPos (Either Doc) where+ throwPosError = Left++class MonadStack m where+ getCurrentCallStack :: m [String]++instance MonadStack InterpreterMonad where+ getCurrentCallStack = singleton GetCurrentCallStack++instance MonadThrowPos InterpreterMonad where+ throwPosError s = do+ p <- use (curPos . _1)+ stack <- getCurrentCallStack+ let dstack = if null stack+ then line+ else mempty </> string (renderStack stack)+ throwError (PrettyError (s <+> "at" <+> showPos p <> dstack))++instance ToRuby PValue where+ toRuby = toRuby . toJSON+instance FromRuby PValue where+ fromRuby = fmap chk . fromRuby+ where+ chk (Left x) = Left x+ chk (Right x) = case fromJSON x of+ Error rr -> Left rr++ Success suc -> Right suc++-- JSON INSTANCES --++instance FromJSON PValue where+ parseJSON Null = return PUndef+ parseJSON (Number n) = return $ PNumber n+ parseJSON (String s) = return (PString s)+ parseJSON (Bool b) = return (PBoolean b)+ parseJSON (Array v) = fmap PArray (V.mapM parseJSON v)+ parseJSON (Object o) = fmap PHash (TR.mapM parseJSON o)++instance ToJSON PValue where+ toJSON (PType t) = toJSON t+ toJSON (PBoolean b) = Bool b+ toJSON PUndef = Null+ toJSON (PString s) = String s+ toJSON (PResourceReference _ _) = Null -- TODO+ toJSON (PArray r) = Array (V.map toJSON r)+ toJSON (PHash x) = Object (HM.map toJSON x)+ toJSON (PNumber n) = Number n++instance ToJSON Resource where+ toJSON r = object [ ("type", String $ r ^. rid . itype)+ , ("title", String $ r ^. rid . iname)+ , ("aliases", toJSON $ r ^. ralias)+ , ("exported", Bool $ r ^. rvirtuality == Exported)+ , ("tags", toJSON $ r ^. rtags)+ , ("parameters", Object ( HM.map toJSON (r ^. rattributes) `HM.union` relations ))+ , ("sourceline", r ^. rpos . _1 . lSourceLine . to (toJSON . unPos))+ , ("sourcefile", r ^. rpos . _1 . lSourceName . to toJSON)+ ]+ where+ relations = r ^. rrelations & HM.fromListWith (V.++) . concatMap changeRelations . HM.toList & HM.map toValue+ toValue v | V.length v == 1 = V.head v+ | otherwise = Array v+ changeRelations :: (RIdentifier, HS.HashSet LinkType) -> [(Text, V.Vector Value)]+ changeRelations (k,v) = do+ c <- HS.toList v+ return (rel2text c, V.singleton (String (rid2text k)))+ rid2text :: RIdentifier -> Text+ rid2text (RIdentifier t n) = capitalizeRT t `Text.append` "[" `Text.append` capn `Text.append` "]"+ where+ capn = if t == "classe"+ then capitalizeRT n+ else n++instance FromJSON Resource where+ parseJSON (Object v) = do+ isExported <- v .: "exported"+ let virtuality = if isExported+ then Exported+ else Normal+ getResourceIdentifier :: PValue -> Maybe RIdentifier+ getResourceIdentifier (PString x) =+ let (restype, brckts) = Text.breakOn "[" x+ rna | Text.null brckts = Nothing+ | Text.null restype = Nothing+ | Text.last brckts == ']' = Just (Text.tail (Text.init brckts))+ | otherwise = Nothing+ in case rna of+ Just resname -> Just (RIdentifier (Text.toLower restype) (Text.toLower resname))+ _ -> Nothing+ getResourceIdentifier _ = Nothing+ -- TODO : properly handle metaparameters+ separate :: (Container PValue, HM.HashMap RIdentifier (HS.HashSet LinkType)) -> Text -> PValue -> (Container PValue, HM.HashMap RIdentifier (HS.HashSet LinkType))+ separate (curAttribs, curRelations) k val = case (fromJSON (String k), getResourceIdentifier val) of+ (Success rel, Just ri) -> (curAttribs, curRelations & at ri . non mempty . contains rel .~ True)+ _ -> (curAttribs & at k ?~ val, curRelations)+ (attribs,relations) <- HM.foldlWithKey' separate (mempty,mempty) <$> v .: "parameters"+ contimport <- v .:? "certname" .!= "unknown"+ Resource+ <$> (RIdentifier <$> fmap Text.toLower (v .: "type") <*> v .: "title")+ <*> v .:? "aliases" .!= mempty+ <*> pure attribs+ <*> pure relations+ <*> pure [ContImport contimport ContRoot]+ <*> pure virtuality+ <*> v .: "tags"+ <*> (toPPos <$> v .:? "sourcefile" .!= "null" <*> v .:? "sourceline" .!= 1)+ <*> pure contimport++ parseJSON _ = mempty++instance ToJSON a => ToJSON (Query a) where+ toJSON (QOr qs) = toJSON ("or" : map toJSON qs)+ toJSON (QAnd qs) = toJSON ("and" : map toJSON qs)+ toJSON (QNot q) = toJSON [ "not" , toJSON q ]+ toJSON (QEqual flds val) = toJSON [ "=", toJSON flds, toJSON val ]+ toJSON (QMatch flds val) = toJSON [ "~", toJSON flds, toJSON val ]+ toJSON (QL flds val) = toJSON [ "<", toJSON flds, toJSON val ]+ toJSON (QG flds val) = toJSON [ ">", toJSON flds, toJSON val ]+ toJSON (QLE flds val) = toJSON [ "<=", toJSON flds, toJSON val ]+ toJSON (QGE flds val) = toJSON [ ">=", toJSON flds, toJSON val ]+ toJSON QEmpty = Null++instance ToJSON a => ToHttpApiData (Query a) where+ toHeader = Control.Lens.view strict . encode+ toUrlPiece = decodeUtf8 . toHeader++instance FromJSON a => FromJSON (Query a) where+ parseJSON Null = pure QEmpty+ parseJSON (Array elems) = case V.toList elems of+ ("or":xs) -> QOr <$> mapM parseJSON xs+ ("and":xs) -> QAnd <$> mapM parseJSON xs+ ["not",x] -> QNot <$> parseJSON x+ [ "=", flds, val ] -> QEqual <$> parseJSON flds <*> parseJSON val+ [ "~", flds, val ] -> QEqual <$> parseJSON flds <*> parseJSON val+ [ ">", flds, val ] -> QG <$> parseJSON flds <*> parseJSON val+ [ "<", flds, val ] -> QL <$> parseJSON flds <*> parseJSON val+ [">=", flds, val ] -> QGE <$> parseJSON flds <*> parseJSON val+ ["<=", flds, val ] -> QLE <$> parseJSON flds <*> parseJSON val+ x -> fail ("unknown query" ++ show x)+ parseJSON _ = fail "Expected an array"++instance ToJSON FactField where+ toJSON FName = "name"+ toJSON FValue = "value"+ toJSON FCertname = "certname"++instance FromJSON FactField where+ parseJSON "name" = pure FName+ parseJSON "value" = pure FValue+ parseJSON "certname" = pure FCertname+ parseJSON _ = fail "Can't parse fact field"++instance ToJSON NodeField where+ toJSON NName = "name"+ toJSON (NFact t) = toJSON [ "fact", t ]++instance FromJSON NodeField where+ parseJSON (Array xs) = case V.toList xs of+ ["fact", x] -> NFact <$> parseJSON x+ _ -> fail "Invalid field syntax"+ parseJSON (String "name") = pure NName+ parseJSON _ = fail "invalid field"++instance ToJSON ResourceField where+ toJSON RTag = "tag"+ toJSON RCertname = "certname"+ toJSON (RParameter t) = toJSON ["parameter", t]+ toJSON RType = "type"+ toJSON RTitle = "title"+ toJSON RExported = "exported"+ toJSON RFile = "file"+ toJSON RLine = "line"++instance FromJSON ResourceField where+ parseJSON (Array xs) = case V.toList xs of+ ["parameter", x] -> RParameter <$> parseJSON x+ _ -> fail "Invalid field syntax"+ parseJSON (String "tag" ) = pure RTag+ parseJSON (String "certname") = pure RCertname+ parseJSON (String "type" ) = pure RType+ parseJSON (String "title" ) = pure RTitle+ parseJSON (String "exported") = pure RExported+ parseJSON (String "file" ) = pure RFile+ parseJSON (String "line" ) = pure RLine+ parseJSON _ = fail "invalid field"++instance FromJSON RIdentifier where+ parseJSON (Object v) = RIdentifier <$> v .: "type" <*> v .: "title"+ parseJSON _ = fail "invalid resource"++instance ToJSON RIdentifier where+ toJSON (RIdentifier t n) = object [("type", String t), ("title", String n)]++instance FromJSON PuppetEdge where+ parseJSON (Object v) = PuppetEdge <$> v .: "source" <*> v .: "target" <*> v .: "relationship"+ parseJSON _ = fail "invalid puppet edge"++instance ToJSON PuppetEdge where+ toJSON (PuppetEdge s t r) = object [("source", toJSON s), ("target", toJSON t), ("relationship", toJSON r)]++instance FromJSON WireCatalog where+ parseJSON (Object d) = d .: "data" >>= \case+ (Object v) -> WireCatalog+ <$> v .: "name"+ <*> v .: "version"+ <*> v .: "edges"+ <*> v .: "resources"+ <*> v .: "transaction-uuid"+ _ -> fail "Data is not an object"+ parseJSON _ = fail "invalid wire catalog"++instance ToJSON WireCatalog where+ toJSON (WireCatalog n v e r t) = object [("metadata", object [("api_version", Number 1)]), ("data", object d)]+ where d = [ ("name", String n)+ , ("version", String v)+ , ("edges", toJSON e)+ , ("resources", toJSON r)+ , ("transaction-uuid", String t)+ ]++instance ToJSON FactInfo where+ toJSON (FactInfo n f v) = object [("certname", String n), ("name", String f), ("value", toJSON v)]++instance FromJSON FactInfo where+ parseJSON (Object v) = FactInfo <$> v .: "certname" <*> v .: "name" <*> v .: "value"+ parseJSON _ = fail "invalid fact info"++instance ToJSON NodeInfo where+ toJSON p = object [ ("name" , toJSON (p ^. nodeInfoName))+ , ("deactivated" , toJSON (p ^. nodeInfoDeactivated))+ , ("catalog_timestamp", toJSON (p ^. nodeInfoCatalogT))+ , ("facts_timestamp" , toJSON (p ^. nodeInfoFactsT))+ , ("report_timestamp" , toJSON (p ^. nodeInfoReportT))+ ]++instance FromJSON NodeInfo where+ parseJSON (Object v) = NodeInfo <$> v .: "name"+ <*> v .:? "deactivated" .!= False+ <*> v .: "catalog_timestamp"+ <*> v .: "facts_timestamp"+ <*> v .: "report_timestamp"+ parseJSON _ = fail "invalide node info"
+ src/Puppet/Interpreter/Utils.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}++-- | The module should not depend on the Interpreter module. It is an+-- internal module and should not be used if expecting a stable API.+module Puppet.Interpreter.Utils where++import Puppet.Prelude++import Control.Monad.Operational+import Control.Monad.Writer.Class+import qualified Data.HashMap.Strict as HM+import qualified Data.List as List+import qualified Data.Maybe.Strict as S+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified System.Log.Logger as Log++import Puppet.Interpreter.Types+import Puppet.Parser.Types+import Puppet.Parser.Utils+import Puppet.Paths+import Puppet.PP+++initialState :: Facts+ -> Container Text -- ^ Server settings+ -> InterpreterState+initialState facts settings =+ InterpreterState baseVars initialclass mempty [ContRoot] dummyppos mempty [] []+ where+ callervars = HM.fromList [("caller_module_name", PString "::" :!: dummyppos :!: ContRoot), ("module_name", PString "::" :!: dummyppos :!: ContRoot)]+ factvars =+ -- add the `facts` key: https://docs.puppet.com/puppet/4.10/lang_facts_and_builtin_vars.html#accessing-facts-from-puppet-code+ let facts' = HM.insert "facts" (PHash facts) facts+ in fmap (\x -> x :!: initialPPos "facts" :!: ContRoot) facts'+ settingvars = fmap (\x -> PString x :!: initialPPos "settings" :!: ContClass "settings") settings+ baseVars = HM.fromList [ ("::", ScopeInformation (factvars `mappend` callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing)+ , ("settings", ScopeInformation settingvars mempty mempty (CurContainer (ContClass "settings") mempty) mempty S.Nothing)+ ]+ initialclass = mempty & at "::" ?~ (ClassIncludeLike :!: dummyppos)++getModulename :: RIdentifier -> Text+getModulename (RIdentifier t n) =+ let gm x =+ case Text.splitOn "::" x of+ [] -> x+ (y:_) -> y+ in case t of+ "class" -> gm n+ _ -> gm t++extractPrism :: Doc -> Prism' a b -> a -> InterpreterMonad b+extractPrism msg p a =+ case preview p a of+ Just b -> return b+ Nothing -> throwPosError ("Could not extract prism in" <+> msg)++-- Scope+popScope :: InterpreterMonad ()+popScope = curScope %= List.tail++pushScope :: CurContainerDesc -> InterpreterMonad ()+pushScope s = curScope %= (s :)++getScopeName :: InterpreterMonad Text+getScopeName = scopeName <$> getScope++scopeName :: CurContainerDesc -> Text+scopeName (ContRoot ) = "::"+scopeName (ContImported x ) = "::imported::" `Text.append` scopeName x+scopeName (ContClass x ) = x+scopeName (ContDefine dt dn _) = "#define/" `Text.append` dt `Text.append` "/" `Text.append` dn+scopeName (ContImport _ x ) = "::import::" `Text.append` scopeName x++moduleName :: CurContainerDesc -> Text+moduleName (ContRoot ) = "::"+moduleName (ContImported x ) = moduleName x+moduleName (ContClass x ) = x+moduleName (ContDefine dt _ _) = dt+moduleName (ContImport _ x ) = moduleName x++getScope :: InterpreterMonad CurContainerDesc+{-# INLINABLE getScope #-}+getScope =+ use curScope >>= \s ->+ if null s+ then throwPosError "Internal error: empty scope!"+ else pure (List.head s)++getCurContainer :: InterpreterMonad CurContainer+{-# INLINABLE getCurContainer #-}+getCurContainer = do+ scp <- getScopeName+ preuse (scopes . ix scp . scopeContainer) >>= \case+ Just x -> return x+ Nothing -> throwPosError ("Internal error: can't find the current container for" <+> green (string (Text.unpack scp)))++rcurcontainer :: Resource -> CurContainerDesc+rcurcontainer r = fromMaybe ContRoot (r ^? rscope . _head)++-- Singleton getters available in the InterpreterMonad --+getPuppetPaths :: InterpreterMonad PuppetDirPaths+getPuppetPaths = singleton PuppetPaths++getNodeName:: InterpreterMonad NodeName+getNodeName = singleton GetNodeName++isIgnoredModule :: Text -> InterpreterMonad Bool+isIgnoredModule m = singleton (IsIgnoredModule m)++-- | Throws an error if we are in strict mode+-- A warning in permissive mode+checkStrict :: Doc -- ^ The warning message.+ -> Doc -- ^ The error message.+ -> InterpreterMonad ()+checkStrict wrn err = do+ extMod <- isExternalModule+ let priority =+ if extMod+ then Log.NOTICE+ else Log.WARNING+ str <- singleton IsStrict+ if str && not extMod+ then throwPosError err+ else do+ srcname <- use (curPos . _1 . lSourceName)+ logWriter priority (wrn <+> "at" <+> string srcname)++isExternalModule :: InterpreterMonad Bool+isExternalModule =+ getScope >>= \case+ ContClass n -> isExternal n+ ContDefine n _ _ -> isExternal n+ _ -> return False+ where+ isExternal = singleton . IsExternalModule . List.head . Text.splitOn "::"++-- Logging --+warn :: MonadWriter InterpreterWriter m => Doc -> m ()+warn d = tell [Log.WARNING :!: d]++debug :: MonadWriter InterpreterWriter m => Doc -> m ()+debug d = tell [Log.DEBUG :!: d]++logWriter :: MonadWriter InterpreterWriter m => Log.Priority -> Doc -> m ()+logWriter prio d = tell [prio :!: d]++safeDecodeUtf8 :: ByteString -> InterpreterMonad Text+{-# INLINABLE safeDecodeUtf8 #-}+safeDecodeUtf8 i = return (Text.decodeUtf8 i)++normalizeRIdentifier :: Text -> Text -> RIdentifier+normalizeRIdentifier = RIdentifier . dropInitialColons++readQueryType :: Text -> Maybe HieraQueryType+readQueryType s =+ case s of+ "first" -> Just QFirst+ "unique" -> Just QUnique+ "hash" -> Just QHash+ _ -> Nothing
+ src/Puppet/Lens.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}+module Puppet.Lens+ ( -- * Pure resolution prisms+ _PResolveExpression+ , _PResolveValue+ -- * Prisms for PValues (reexport from "Puppet.Interpreter.Types")+ , _PHash+ , _PBoolean+ , _PString+ , _PNumber+ , _PResourceReference+ , _PUndef+ , _PArray+ -- * Lenses and prims for 'Statement's+ , _Statements+ , _ResDecl+ , _ResDefaultDecl+ , _ResOverrDecl+ , _ResCollDecl+ , _ConditionalDecl+ , _ClassDecl+ , _DefineDecl+ , _NodeDecl+ , _VarAssignDecl+ , _MainFuncDecl+ , _HigherOrderLambdaDecl+ , _DepDecl+ -- * Prim for 'Expression's+ , _Equal+ , _Different+ , _Not+ , _And+ , _Or+ , _LessThan+ , _MoreThan+ , _LessEqualThan+ , _MoreEqualThan+ , _RegexMatch+ , _NotRegexMatch+ , _Contains+ , _Addition+ , _Substraction+ , _Division+ , _Multiplication+ , _Modulo+ , _RightShift+ , _LeftShift+ , _Lookup+ , _Negate+ , _ConditionalValue+ , _FunctionApplication+ , _Terminal+ -- * Prisms for exceptions+ , _PrettyError+ ) where++import Puppet.Prelude++import qualified Data.HashMap.Strict as HM+import qualified Data.List as List+import qualified Data.Vector as V+import Text.Megaparsec (parse)+import Text.PrettyPrint.ANSI.Leijen (pretty)++import Puppet.Interpreter.Pure+import Puppet.Interpreter.Resolve+import Puppet.Interpreter.Types+import Puppet.Parser (puppetParser)+import qualified Puppet.Parser.PrettyPrinter ()+import Puppet.Parser.Types++makePrisms ''Expression++_PuppetParser :: Prism' Text (V.Vector Statement)+_PuppetParser = prism' (toS . List.unlines . V.toList . fmap (show . pretty)) $ \t -> case parse puppetParser "dummy" t of+ Left _ -> Nothing+ Right r -> Just r++_PrettyError :: Prism' SomeException PrettyError+_PrettyError = prism' toException fromException++_ResDecl :: Prism' Statement ResDecl+_ResDecl = prism ResourceDeclaration $ \x -> case x of+ ResourceDeclaration a -> Right a+ _ -> Left x+_ResDefaultDecl :: Prism' Statement ResDefaultDecl+_ResDefaultDecl = prism ResourceDefaultDeclaration $ \x -> case x of+ ResourceDefaultDeclaration a -> Right a+ _ -> Left x+_ResOverrDecl :: Prism' Statement ResOverrideDecl+_ResOverrDecl = prism ResourceOverrideDeclaration $ \x -> case x of+ ResourceOverrideDeclaration a -> Right a+ _ -> Left x+_ResCollDecl :: Prism' Statement ResCollDecl+_ResCollDecl = prism ResourceCollectionDeclaration $ \x -> case x of+ ResourceCollectionDeclaration a -> Right a+ _ -> Left x+_ConditionalDecl :: Prism' Statement ConditionalDecl+_ConditionalDecl = prism ConditionalDeclaration $ \x -> case x of+ ConditionalDeclaration a -> Right a+ _ -> Left x+_ClassDecl :: Prism' Statement ClassDecl+_ClassDecl = prism ClassDeclaration $ \x -> case x of+ ClassDeclaration a -> Right a+ _ -> Left x+_DefineDecl :: Prism' Statement DefineDecl+_DefineDecl = prism DefineDeclaration $ \x -> case x of+ DefineDeclaration a -> Right a+ _ -> Left x+_NodeDecl :: Prism' Statement NodeDecl+_NodeDecl = prism NodeDeclaration $ \x -> case x of+ NodeDeclaration a -> Right a+ _ -> Left x++_VarAssignDecl :: Prism' Statement VarAssignDecl+_VarAssignDecl = prism VarAssignmentDeclaration $ \x -> case x of+ VarAssignmentDeclaration a -> Right a+ _ -> Left x+_MainFuncDecl :: Prism' Statement MainFuncDecl+_MainFuncDecl = prism MainFunctionDeclaration $ \x -> case x of+ MainFunctionDeclaration a -> Right a+ _ -> Left x+_HigherOrderLambdaDecl :: Prism' Statement HigherOrderLambdaDecl+_HigherOrderLambdaDecl = prism HigherOrderLambdaDeclaration $ \x -> case x of+ HigherOrderLambdaDeclaration a -> Right a+ _ -> Left x+_DepDecl :: Prism' Statement DepDecl+_DepDecl = prism DependencyDeclaration $ \x -> case x of+ DependencyDeclaration 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++-- | Incomplete+_PResolveExpression :: Prism' Expression PValue+_PResolveExpression = prism reinject extract+ where+ extract e = case dummyEval (resolveExpression e) of+ Right x -> Right x+ Left _ -> Left e+ reinject = Terminal . review _PResolveValue++_PResolveValue :: Prism' UnresolvedValue PValue+_PResolveValue = prism toU toP+ where+ toP uv = case dummyEval (resolveValue uv) of+ Right x -> Right x+ Left _ -> Left uv+ toU (PBoolean x) = UBoolean x+ toU (PNumber x) = UNumber x+ toU PUndef = UUndef+ toU (PString s) = UString s+ 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)+ toU (PType _) = panic "TODO, _PResolveValue PType undefined"++_Statements :: Lens' Statement [Statement]+_Statements = lens (V.toList . sget) (\s v -> sset s (V.fromList v))+ where+ sget :: Statement -> V.Vector Statement+ sget (ClassDeclaration (ClassDecl _ _ _ s _)) = s+ sget (DefineDeclaration (DefineDecl _ _ s _)) = s+ sget (NodeDeclaration (NodeDecl _ s _ _)) = s+ sget (TopContainer s _) = s+ sget (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall _ _ _ s _) _)) = s+ sget _ = V.empty+ sset :: Statement -> V.Vector Statement -> Statement+ sset (ClassDeclaration (ClassDecl n args inh _ p)) s = ClassDeclaration (ClassDecl n args inh s p)+ sset (NodeDeclaration (NodeDecl ns _ nd' p)) s = NodeDeclaration (NodeDecl ns s nd' p)+ sset (DefineDeclaration (DefineDecl n args _ p)) s = DefineDeclaration (DefineDecl n args s p)+ sset (TopContainer _ p) s = TopContainer s p+ sset (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall t e pr _ e2) p)) s = HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall t e pr s e2) p)+ sset x _ = x
+ src/Puppet/Manifests.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+module Puppet.Manifests (filterStatements) where++import Puppet.Prelude++import qualified Data.Either.Strict as S+import qualified Data.HashMap.Strict as HM+import qualified Data.Text.Encoding as Text+import qualified Data.Vector as V+import Text.Regex.PCRE.ByteString.Utils++import Puppet.Interpreter.Types+import Puppet.Parser.Types+import Puppet.PP++-- TODO pre-triage stuff+filterStatements :: TopLevelType -> Text -> V.Vector Statement -> IO (S.Either PrettyError Statement)+-- the most complicated case, node matching+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@(NodeDeclaration (NodeDecl (NodeName !nm) _ _ _)) = curstuff & _2 . at nm ?~ n+ triage curstuff n@(NodeDeclaration (NodeDecl (NodeMatch (CompRegex _ !rg)) _ _ _)) = curstuff & _3 %~ (|> (rg :!: n))+ triage curstuff n@(NodeDeclaration (NodeDecl NodeDefault _ _ _)) = curstuff & _4 ?~ n+ triage curstuff x = curstuff & _1 %~ (|> x)+ bsnodename = Text.encodeUtf8 ndename+ checkRegexp :: [Pair Regex Statement] -> ExceptT PrettyError IO (Maybe Statement)+ checkRegexp [] = return Nothing+ checkRegexp ((regexp :!: s):xs) =+ case execute' regexp bsnodename of+ Left rr -> throwError (PrettyError ("Regexp match error:" <+> text (show rr)))+ Right Nothing -> checkRegexp xs+ Right (Just _) -> return (Just s)+ strictEither (Left x) = S.Left x+ strictEither (Right x) = S.Right x+ in case directnodes ^. at ndename of -- check if there is a node specifically called after my name+ Just r -> return (S.Right (TopContainer spurious r))+ Nothing -> fmap strictEither $ runExceptT $ do+ regexpMatchM <- checkRegexp (V.toList regexpmatches) -- match regexps+ case regexpMatchM <|> defaultnode of -- check for regexp matches or use the default node+ Just r -> return (TopContainer spurious r)+ Nothing -> throwError (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 (ClassDecl cname _ _ _ _)) = curstuff & _3 . at cname ?~ n+ triage curstuff n@(DefineDeclaration (DefineDecl cname _ _ _)) = curstuff & _2 . at cname ?~ n+ triage curstuff n = curstuff & _1 %~ (|> n)+ tc n = if V.null spurious+ then n+ else TopContainer spurious n+ in case x of+ TopNode -> return (S.Left "Case already covered, shoudln't happen in Puppet.Manifests")+ TopDefine -> case defines ^. at ndename of+ Just n -> return (S.Right (tc n))+ Nothing -> return (S.Left (PrettyError ("Couldn't find define " <+> ttext ndename)))+ TopClass -> case classes ^. at ndename of+ Just n -> return (S.Right (tc n))+ Nothing -> return (S.Left (PrettyError ("Couldn't find class " <+> ttext ndename)))
+ src/Puppet/NativeTypes.hs view
@@ -0,0 +1,59 @@+{-| This module holds the /native/ Puppet resource types. -}+module Puppet.NativeTypes (+ baseNativeTypes+ , validateNativeType+) where++import Puppet.Prelude++import Control.Monad.Operational+import qualified Data.HashMap.Strict as HM++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.Notify+import Puppet.NativeTypes.Package+import Puppet.NativeTypes.SshSecure+import Puppet.NativeTypes.User+import Puppet.NativeTypes.ZoneRecord++fakeTypes :: [(NativeTypeName, NativeTypeMethods)]+fakeTypes = map faketype ["class"]++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","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 NativeTypeMethods+baseNativeTypes = HM.fromList+ ( nativeConcat+ : nativeConcatFragment+ : nativeCron+ : nativeExec+ : nativeFile+ : nativeGroup+ : nativeHost+ : nativeMount+ : nativeNotify+ : nativePackage+ : nativeSshSecure+ : nativeUser+ : nativeZoneRecord+ : fakeTypes ++ defaultTypes)++-- | Contrary to the previous iteration, this will let non native types pass.+validateNativeType :: Resource -> InterpreterMonad Resource+validateNativeType r = do+ tps <- singleton GetNativeTypes+ case tps ^. at (r ^. rid . itype) of+ Just x -> case (x ^. puppetValidate) r of+ Right nr -> return nr+ Left err -> throwPosError ("Invalid resource" <+> pretty r </> getError err)+ Nothing -> return r
+ src/Puppet/NativeTypes/Concat.hs view
@@ -0,0 +1,49 @@+module Puppet.NativeTypes.Concat (+ nativeConcat+ , nativeConcatFragment+) where++import Puppet.Prelude++import Puppet.NativeTypes.Helpers+import Puppet.Interpreter.Types++nativeConcat :: (NativeTypeName, NativeTypeMethods)+nativeConcat = ("concat", nativetypemethods concatparamfunctions pure)++nativeConcatFragment :: (NativeTypeName, NativeTypeMethods)+nativeConcatFragment = ("concat::fragment", nativetypemethods fragmentparamfunctions validateSourceOrContent)++concatparamfunctions :: [(Text, [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 :: [(Text, [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])+ ]
+ src/Puppet/NativeTypes/Cron.hs view
@@ -0,0 +1,66 @@+module Puppet.NativeTypes.Cron+ (nativeCron)+where++import Puppet.Prelude++import qualified Data.Text as Text+import qualified Data.Vector as V+import qualified Text.PrettyPrint.ANSI.Leijen as P++import Puppet.Interpreter.Types+import Puppet.NativeTypes.Helpers++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.+parameterfunctions :: [(Text, [Text -> NativeTypeValidate])]+parameterfunctions =+ [("ensure" , [defaultvalue "present", string, values ["present","absent"]])+ ,("command" , [string, mandatoryIfNotAbsent])+ ,("environment" , [])+ ,("hour" , [vrange 0 23 [] ])+ ,("minute" , [vrange 0 59 [] ])+ ,("month" , [vrange 1 12 ["January","February","March","April","May","June","July","August","September","October","November","December"] ])+ ,("monthday" , [vrange 1 31 [] ])+ ,("name" , [nameval])+ ,("provider" , [defaultvalue "crontab", string, values ["crontab"]])+ ,("special" , [string])+ ,("target" , [string])+ ,("user" , [defaultvalue "root", string])+ ,("weekday" , [vrange 0 7 ["Monday","Tuesday","Wednesday","Thursday","Friday","Saturday","Sunday"]])+ ]+++vrange :: Integer -> Integer -> [Text] -> 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+ Nothing -> defaultvalue "*" param res++vrange' :: Integer -> Integer -> [Text] -> Text -> Resource -> PValue -> Either PrettyError Resource+vrange' mi ma valuelist param res y = case y of+ PString "*" -> Right res+ PString "absent" -> Right res+ PNumber n -> checkint' n mi ma param res+ PString x -> if x `elem` valuelist+ then Right res+ else parseval x mi ma param res+ x -> perror $ "Parameter" <+> paramname param <+> "value should be a valid cron declaration and not" <+> pretty x++parseval :: Text -> Integer -> Integer -> Text -> NativeTypeValidate+parseval resval mi ma pname res | "*/" `Text.isPrefixOf` resval = checkint (Text.drop 2 resval) 1 ma pname res+ | otherwise = checkint resval mi ma pname res++checkint :: Text -> Integer -> Integer -> 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 -> Text -> NativeTypeValidate+checkint' i mi ma param res =+ if (i >= fromIntegral mi) && (i <= fromIntegral ma)+ then Right res+ else perror $ "Parameter" <+> paramname param <+> "value is out of bound, should satisfy" <+> P.integer mi <+> "<=" <+> P.string (show i) <+> "<=" <+> P.integer ma
+ src/Puppet/NativeTypes/Exec.hs view
@@ -0,0 +1,40 @@+module Puppet.NativeTypes.Exec (nativeExec) where++import qualified Data.Text as Text+import Puppet.Prelude++import Puppet.Interpreter.Types+import Puppet.NativeTypes.Helpers++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.+parameterfunctions :: [(Text, [Text -> NativeTypeValidate])]+parameterfunctions =+ [("command" , [nameval])+ ,("creates" , [rarray, strings, fullyQualifieds])+ ,("cwd" , [string, fullyQualified])+ ,("environment" , [rarray, strings])+ ,("group" , [string])+ ,("logoutput" , [defaultvalue "false", string, values ["true","false","on_failure"]])+ ,("onlyif" , [string])+ ,("path" , [rarray, strings, fullyQualifieds])+ ,("provider" , [string, values ["posix","shell","windows"]])+ ,("refresh" , [string])+ ,("refreshonly" , [defaultvalue "false", string, values ["true","false"]])+ ,("returns" , [defaultvalue "0", rarray, integers])+ ,("timeout" , [defaultvalue "300", integer])+ ,("tries" , [defaultvalue "1", integer])+ ,("try_sleep" , [defaultvalue "0", integer])+ ,("unless" , [string])+ ,("user" , [string])+ ]++fullyQualifiedOrPath :: NativeTypeValidate+fullyQualifiedOrPath res =+ case (res ^. rattributes . at "path", res ^. rattributes . at "command") of+ (Nothing, Just (PString x)) -> if Text.head x == '/'+ then Right res+ else Left "Command must be fully qualified if path is not defined"+ _ -> Right res
+ src/Puppet/NativeTypes/File.hs view
@@ -0,0 +1,111 @@+module Puppet.NativeTypes.File (nativeFile) where++import Puppet.Prelude++import Control.Monad.Trans.Except+import qualified Data.Attoparsec.Text as AT+import qualified Data.Char as Char+import qualified Data.Map.Strict as M+import qualified Data.Set as Set+import qualified Data.Text as Text++import Puppet.Interpreter.Types+import Puppet.NativeTypes.Helpers++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.++parameterfunctions :: [(Text, [Text -> NativeTypeValidate])]+parameterfunctions =+ [("backup" , [string])+ ,("checksum" , [values ["md5", "md5lite", "mtime", "ctime", "none"]])+ ,("content" , [string])+ --,("ensure" , [defaultvalue "present", string, values ["directory","file","present","absent","link"]])+ ,("ensure" , [defaultvalue "present", string])+ ,("force" , [string, values ["true","false"]])+ ,("group" , [defaultvalue "root", string])+ ,("ignore" , [strings])+ ,("links" , [string])+ ,("mode" , [defaultvalue "0644", string])+ ,("owner" , [string])+ ,("path" , [nameval, fullyQualified, noTrailingSlash'])+ ,("provider" , [values ["posix","windows"]])+ ,("purge" , [string, values ["true","false"]])+ ,("recurse" , [string, values ["inf","true","false","remote"]])+ ,("recurselimit" , [integer])+ ,("replace" , [string, values ["true","false","yes","no"]])+ ,("sourceselect" , [values ["first","all"]])+ ,("seltype" , [string])+ ,("selrange" , [string])+ ,("selinux_ignore_defaults", [string, values ["true","false"]])+ ,("selrole" , [string])+ ,("target" , [string])+ ,("source" , [rarray, strings, flip runarray checkSource])+ ,("seluser" , [string])+ ,("validate_cmd" , [string])+ ,("validate_replacement" , [string])+ ]++noTrailingSlash' :: Text -> NativeTypeValidate+noTrailingSlash' param res+ | res ^? rattributes . ix "ensure" == Just "directory" = Right res+ | otherwise = noTrailingSlash param res++validateMode :: NativeTypeValidate+validateMode res = do+ modestr <- case res ^. rattributes . at "mode" of+ Just (PString s) -> return s+ Just x -> throwError $ PrettyError ("Invalide mode type, should be a string " <+> pretty x)+ Nothing -> throwError "Could not find mode!"+ (numeric modestr <|> except (ugo modestr)) & runExcept & _Right %~ ($ res)++numeric :: Text -> Except PrettyError (Resource -> Resource)+numeric modestr = do+ when ((Text.length modestr /= 3) && (Text.length modestr /= 4)) (throwError "Invalid mode size")+ unless (Text.all Char.isDigit modestr) (throwError "The mode should only be made of digits")+ return $ if Text.length modestr == 3+ then rattributes . at "mode" ?~ PString (Text.cons '0' modestr)+ else identity++checkSource :: Text -> PValue -> NativeTypeValidate+checkSource _ (PString x) res | any (`Text.isPrefixOf` x) ["puppet://", "file://", "/"] = Right res+ | otherwise = throwError "A source should start with either puppet:// or file:// or an absolute path"+checkSource _ x _ = throwError $ PrettyError ("Expected a string, not" <+> pretty x)++data PermParts = Special | User | Group | Other+ deriving (Eq, Ord)++data PermSet = R | W | X+ deriving (Ord, Eq)++ugo :: Text -> Either PrettyError (Resource -> Resource)+ugo t = AT.parseOnly (modestring <* AT.endOfInput) t+ & _Left %~ (\rr -> PrettyError $ "Could not parse the mode string: " <> text rr)+ & _Right %~ (\s -> rattributes . at "mode" ?~ PString (mkmode Special s <> mkmode User s <> mkmode Group s <> mkmode Other s))++mkmode :: PermParts -> M.Map PermParts (Set PermSet) -> Text+mkmode p m = let s = m ^. at p . non mempty+ in Text.pack $ show $ fromEnum (Set.member R s) * 4+ + fromEnum (Set.member W s) * 2+ + fromEnum (Set.member X s)++modestring :: AT.Parser (M.Map PermParts (Set.Set PermSet))+modestring = M.fromList . mconcat <$> (modepart `AT.sepBy` AT.char ',')++-- TODO suid, sticky and other funky things are not yet supported+modepart :: AT.Parser [(PermParts, Set PermSet)]+modepart = do+ let permpart = (AT.char 'u' *> pure [User])+ <|> (AT.char 'g' *> pure [Group])+ <|> (AT.char 'o' *> pure [Other])+ <|> (AT.char 'a' *> pure [User,Group,Other])+ permission = (AT.char 'r' *> pure R)+ <|> (AT.char 'w' *> pure W)+ <|> (AT.char 'x' *> pure X)+ pp <- mconcat <$> some permpart+ void $ AT.char '='+ pr <- Set.fromList <$> some permission+ return (map (\p -> (p, pr)) pp)
+ src/Puppet/NativeTypes/Group.hs view
@@ -0,0 +1,25 @@+module Puppet.NativeTypes.Group (nativeGroup) where++import Puppet.Prelude++import Puppet.Interpreter.Types+import Puppet.NativeTypes.Helpers++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.+parameterfunctions :: [(Text, [Text -> NativeTypeValidate])]+parameterfunctions =+ [("allowdupe" , [string, defaultvalue "false", values ["true","false"]])+ ,("attribute_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]])+ ,("attributes" , [strings])+ ,("auth_membership" , [defaultvalue "minimum", string, values ["inclusive","minimum"]])+ ,("ensure" , [defaultvalue "present", string, values ["present","absent"]])+ ,("gid" , [integer])+ ,("ia_load_module" , [string])+ ,("members" , [strings])+ ,("name" , [nameval])+ ,("provider" , [string, values ["aix","directoryservice","groupadd","ldap","pw","window_adsi"]])+ ,("system" , [string, defaultvalue "false", values ["true","false"]])+ ]
+ src/Puppet/NativeTypes/Helpers.hs view
@@ -0,0 +1,265 @@+{-| These are the function and data types that are used to define the Puppet+native types.+-}+module Puppet.NativeTypes.Helpers+ ( module Puppet.PP+ , ipaddr+ , nativetypemethods+ , paramname+ , rarray+ , string+ , strings+ , string_s+ , noTrailingSlash+ , fullyQualified+ , fullyQualifieds+ , values+ , defaultvalue+ , concattype+ , nameval+ , defaultValidate+ , NativeTypeName+ , parameterFunctions+ , integer+ , integers+ , mandatory+ , mandatoryIfNotAbsent+ , inrange+ , faketype+ , defaulttype+ , runarray+ , perror+ , validateSourceOrContent+ ) where++import Puppet.Prelude++import qualified Text.Read+import Data.Aeson.Lens (_Integer, _Number)+import Data.Char (isDigit)+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.Text as Text+import qualified Data.Vector as V+import Puppet.Interpreter.PrettyPrinter ()+import Puppet.Interpreter.Types+import Puppet.PP hiding (integer, string)+import qualified Text.PrettyPrint.ANSI.Leijen as P++type NativeTypeName = Text++paramname :: Text -> Doc+paramname = red . ttext++-- | Useful helper for buiding error messages+perror :: Doc -> Either PrettyError Resource+perror = Left . PrettyError++-- | Smart constructor for 'NativeTypeMethods'.+nativetypemethods :: [(Text, [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++faketype :: NativeTypeName -> (NativeTypeName, NativeTypeMethods)+faketype tname = (tname, NativeTypeMethods Right HS.empty)++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 Text -> NativeTypeValidate+defaultValidate validparameters = checkParameterList validparameters >=> addDefaults++checkParameterList :: HS.HashSet Text -> NativeTypeValidate+checkParameterList validparameters res | HS.null validparameters = Right res+ | otherwise = if HS.null setdiff+ then Right res+ else perror $ "Unknown parameters: " <+> list (map paramname $ HS.toList setdiff)+ where+ keyset = HS.fromList $ HM.keys (res ^. rattributes)+ setdiff = HS.difference keyset (metaparameters `HS.union` validparameters)++-- | This validator always accept the resources, but add the default parameters (to be defined :)+addDefaults :: NativeTypeValidate+addDefaults res = Right (res & rattributes %~ newparams)+ where+ def PUndef = False+ def _ = True+ newparams p = HM.filter def $ HM.union p defaults+ defaults = HM.empty++-- | Helper function that runs a validor on a 'PArray'+runarray :: Text -> (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+ Nothing -> Right res++{-| This checks that a given parameter is a string. If it is a 'ResolvedInt' or+'ResolvedBool' it will convert them to strings.+-}+string :: Text -> NativeTypeValidate+string param res = case res ^. rattributes . at param of+ Just x -> string' param x res+ Nothing -> Right res++strings :: Text -> NativeTypeValidate+strings param = runarray param string'++-- | Validates a string or an array of strings+string_s :: Text -> NativeTypeValidate+string_s param res = case res ^. rattributes . at param of+ Nothing -> Right res+ Just (PArray _) -> strings param res+ Just _ -> string param res++string' :: Text -> PValue -> NativeTypeValidate+string' param rev res = case rev of+ PString _ -> Right res+ PBoolean True -> Right (res & rattributes . at param ?~ PString "true")+ PBoolean False -> Right (res & rattributes . at param ?~ PString "false")+ 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 :: [Text] -> Text -> NativeTypeValidate+values valuelist param res = case res ^. rattributes . at param of+ Just (PString x) -> if x `elem` valuelist+ then Right res+ else perror $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ttext valuelist) <+> "and not" <+> ttext x+ Just x -> perror $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ttext valuelist) <+> "and not" <+> pretty x+ Nothing -> Right res++-- | This fills the default values of unset parameters.+defaultvalue :: Text -> 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 :: 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 :: Text -> NativeTypeValidate+integers param = runarray param integer''++integer'' :: 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 :: Text -> NativeTypeValidate+nameval prm res = string prm res+ >>= \r -> case r ^. rattributes . at prm of+ Just (PString al) -> Right (res & rid . iname .~ al)+ Just x -> perror ("The alias must be a string, not" <+> pretty x)+ Nothing -> Right (r & rattributes . at prm ?~ PString (r ^. rid . iname))++-- | Checks that a given parameter is set unless the resources "ensure" is set to absent+mandatoryIfNotAbsent :: Text -> NativeTypeValidate+mandatoryIfNotAbsent param res = case res ^. rattributes . at param of+ Just _ -> Right res+ Nothing -> case res ^. rattributes . at "ensure" of+ Just "absent" -> Right res+ _ -> perror $ "Parameter" <+> paramname param <+> "should be set."++-- | Checks that a given parameter is set.+mandatory :: 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 :: [(Text, [Text -> NativeTypeValidate])] -> NativeTypeValidate+parameterFunctions argrules rs = foldM parameterFunctions' rs argrules+ where+ parameterFunctions' :: Resource -> (Text, [Text -> NativeTypeValidate]) -> Either PrettyError Resource+ parameterFunctions' r (param, validationfunctions) = foldM (parameterFunctions'' param) r validationfunctions+ parameterFunctions'' :: Text -> Resource -> (Text -> NativeTypeValidate) -> Either PrettyError Resource+ parameterFunctions'' param r validationfunction = validationfunction param r++-- checks that a parameter is fully qualified+fullyQualified :: Text -> NativeTypeValidate+fullyQualified param res = case res ^. rattributes . at param of+ Just path -> fullyQualified' param path res+ Nothing -> Right res++noTrailingSlash :: Text -> NativeTypeValidate+noTrailingSlash param res = case res ^. rattributes . at param of+ Just (PString x) -> if Text.last x == '/'+ then perror ("Parameter" <+> paramname param <+> "should not have a trailing slash")+ else Right res+ _ -> Right res++fullyQualifieds :: Text -> NativeTypeValidate+fullyQualifieds param = runarray param fullyQualified'++fullyQualified' :: Text -> PValue -> NativeTypeValidate+fullyQualified' param path res = case path of+ PString ("") -> perror $ "Empty path for parameter" <+> paramname param+ PString p -> if Text.head p == '/'+ then Right res+ 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 :: 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 :: Text -> NativeTypeValidate+ipaddr param res = case res ^. rattributes . at param of+ Nothing -> Right res+ Just (PString ip) ->+ if checkipv4 ip 0+ then Right res+ else perror $ "Invalid IP address for parameter" <+> paramname param+ Just x -> perror $ "Parameter" <+> paramname param <+> "should be an IP address string, not" <+> pretty x++checkipv4 :: Text -> Int -> Bool+checkipv4 _ 4 = False -- means that there are more than 4 groups+checkipv4 "" _ = False -- should never get an empty string+checkipv4 ip v =+ let (cur, nxt) = Text.break (=='.') ip+ nextfunc = if Text.null nxt+ then v == 3+ else checkipv4 (Text.tail nxt) (v+1)+ goodcur = not (Text.null cur) && Text.all isDigit cur && (let rcur = Text.Read.read (Text.unpack cur) :: Int in (rcur >= 0) && (rcur <= 255))+ in goodcur && nextfunc++inrange :: Integer -> Integer -> Text -> NativeTypeValidate+inrange mi ma param res =+ let va = res ^. rattributes . at param+ na = va ^? traverse . _Number+ in case (va,na) of+ (Nothing, _) -> Right res+ (_,Just v) -> if (v >= fromIntegral mi) && (v <= fromIntegral ma)+ then Right res+ 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
+ src/Puppet/NativeTypes/Host.hs view
@@ -0,0 +1,48 @@+module Puppet.NativeTypes.Host (nativeHost) where++import Puppet.Prelude++import qualified Data.Char as Char+import qualified Data.Text as Text+import qualified Data.Vector as V++import Puppet.NativeTypes.Helpers+import Puppet.Interpreter.Types++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.+parameterfunctions :: [(Text, [Text -> NativeTypeValidate])]+parameterfunctions =+ [("comment" , [string, values ["true","false"]])+ ,("ensure" , [defaultvalue "present", string, values ["present","absent"]])+ ,("host_aliases" , [rarray, strings, checkhostname])+ ,("ip" , [string, mandatory, ipaddr])+ ,("name" , [nameval, checkhostname])+ ,("provider" , [string, values ["parsed"]])+ ,("target" , [string, fullyQualified])+ ]++checkhostname :: Text -> NativeTypeValidate+checkhostname param res = case res ^. rattributes . at param of+ Nothing -> Right res+ Just (PArray xs) -> V.foldM (checkhostname' param) res xs+ Just x@(PString _) -> checkhostname' param res x+ Just x -> perror $ paramname param <+> "should be an array or a single string, not" <+> pretty x++checkhostname' :: Text -> Resource -> PValue -> Either PrettyError Resource+checkhostname' prm _ (PString "") = perror $ "Empty hostname for parameter" <+> paramname prm+checkhostname' prm res (PString x ) = checkhostname'' prm res x+checkhostname' prm _ x = perror $ "Parameter " <+> paramname prm <+> "should be an string or an array of strings, but this was found :" <+> pretty x++checkhostname'' :: Text -> Resource -> Text -> Either PrettyError Resource+checkhostname'' prm _ "" = perror $ "Empty hostname part in parameter" <+> paramname prm+checkhostname'' prm res prt =+ let (cur,nxt) = Text.break (=='.') prt+ nextfunc = if Text.null nxt+ then Right res+ else checkhostname'' prm res (Text.tail nxt)+ in if Text.null cur || (Text.head cur == '-') || not (Text.all (\x -> Char.isAlphaNum x || (x=='-')) cur)+ then perror $ "Invalid hostname part for parameter" <+> paramname prm+ else nextfunc
+ src/Puppet/NativeTypes/Mount.hs view
@@ -0,0 +1,25 @@+module Puppet.NativeTypes.Mount (nativeMount) where++import Puppet.Prelude++import Puppet.NativeTypes.Helpers+import Puppet.Interpreter.Types++nativeMount :: (NativeTypeName, NativeTypeMethods)+nativeMount = ("mount", nativetypemethods parameterfunctions return)++parameterfunctions :: [(Text, [Text -> NativeTypeValidate])]+parameterfunctions =+ [("atboot" , [string, values ["true","false"]])+ ,("blockdevice" , [string])+ ,("device" , [string, mandatoryIfNotAbsent])+ ,("dump" , [integer, inrange 0 2])+ ,("ensure" , [defaultvalue "present", string, values ["present","absent","mounted"]])+ ,("fstype" , [string, mandatoryIfNotAbsent])+ ,("name" , [nameval])+ ,("options" , [string])+ ,("pass" , [defaultvalue "0", integer])+ ,("provider" , [defaultvalue "parsed", string, values ["parsed"]])+ ,("remounts" , [string, values ["true","false"]])+ ,("target" , [string, fullyQualified])+ ]
+ src/Puppet/NativeTypes/Notify.hs view
@@ -0,0 +1,15 @@+module Puppet.NativeTypes.Notify (nativeNotify) where++import Puppet.Prelude++import Puppet.Interpreter.Types+import Puppet.NativeTypes.Helpers++nativeNotify :: (NativeTypeName, NativeTypeMethods)+nativeNotify = ("notify", nativetypemethods parameterfunctions return)++parameterfunctions :: [(Text, [Text -> NativeTypeValidate])]+parameterfunctions =+ [("message" , [])+ ,("withpath" , [string, defaultvalue "false", values ["true","false"]])+ ]
+ src/Puppet/NativeTypes/Package.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE DeriveGeneric #-}+module Puppet.NativeTypes.Package (nativePackage) where++import Puppet.Prelude++import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS++import Puppet.Interpreter.Types+import Puppet.NativeTypes.Helpers++nativePackage :: (NativeTypeName, NativeTypeMethods)+nativePackage = ("package", nativetypemethods parameterfunctions (getFeature >=> checkFeatures))++-- Features are abilities that some providers may not support.+data PackagingFeatures = Holdable | InstallOptions | Installable | Purgeable | UninstallOptions | Uninstallable | Upgradeable | Versionable deriving (Show, Eq, Generic)++instance Hashable PackagingFeatures++isFeatureSupported :: HM.HashMap Text (HS.HashSet PackagingFeatures)+isFeatureSupported = HM.fromList [ ("aix", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("appdmg", HS.fromList [Installable])+ , ("apple", HS.fromList [Installable])+ , ("apt", HS.fromList [Holdable, InstallOptions, Installable, Purgeable, Uninstallable, Upgradeable, Versionable])+ , ("aptitude", HS.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable])+ , ("aptrpm", HS.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable])+ , ("blastwave", HS.fromList [Installable, Uninstallable, Upgradeable])+ , ("dpkg", HS.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable])+ , ("fink", HS.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable])+ , ("freebsd", HS.fromList [Installable, Uninstallable])+ , ("gem", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("hpux", HS.fromList [Installable, Uninstallable])+ , ("macports", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("msi", HS.fromList [InstallOptions, Installable, UninstallOptions, Uninstallable])+ , ("nim", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("openbsd", HS.fromList [Installable, Uninstallable, Versionable])+ , ("pacman", HS.fromList [Installable, Uninstallable, Upgradeable])+ , ("pip", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("pkg", HS.fromList [Holdable, Installable, Uninstallable, Upgradeable, Versionable])+ , ("pkgdmg", HS.fromList [Installable])+ , ("pkgin", HS.fromList [Installable, Uninstallable])+ , ("pkgutil", HS.fromList [Installable, Uninstallable, Upgradeable])+ , ("portage", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("ports", HS.fromList [Installable, Uninstallable, Upgradeable])+ , ("portupgrade", HS.fromList [Installable, Uninstallable, Upgradeable])+ , ("rpm", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("rug", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("sun", HS.fromList [InstallOptions, Installable, Uninstallable, Upgradeable])+ , ("sunfreeware", HS.fromList [Installable, Uninstallable, Upgradeable])+ , ("up2date", HS.fromList [Installable, Uninstallable, Upgradeable])+ , ("urpmi", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ , ("windows", HS.fromList [InstallOptions, Installable, UninstallOptions, Uninstallable])+ , ("yum", HS.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable])+ , ("zypper", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable])+ ]++parameterfunctions :: [(Text, [Text -> NativeTypeValidate])]+parameterfunctions =+ [("adminfile" , [string, fullyQualified])+ ,("allowcdrom" , [string, values ["true","false"]])+ ,("configfiles" , [string, values ["keep","replace"]])+ --,("ensure" , [defaultvalue "present", string, values ["present","absent","latest","held","purged","installed"]])+ ,("ensure" , [defaultvalue "present", string])+ ,("flavor" , [])+ ,("install_options" , [rarray])+ ,("name" , [nameval])+ ,("provider" , [defaultvalue "apt", string])+ ,("responsefile" , [string, fullyQualified])+ ,("source" , [string])+ ,("uninstall_options", [rarray])+ ]++getFeature :: Resource -> Either PrettyError (HS.HashSet PackagingFeatures, Resource)+getFeature res = case res ^. rattributes . at "provider" of+ Just (PString x) -> case HM.lookup x isFeatureSupported of+ Just s -> Right (s,res)+ Nothing -> Left $ PrettyError ("Do not know provider" <+> ttext x)+ _ -> Left "Can't happen at Puppet.NativeTypes.Package"++checkFeatures :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError Resource+checkFeatures =+ checkAdminFile+ >=> checkEnsure+ >=> checkParam "install_options" InstallOptions+ >=> checkParam "uninstall_options" UninstallOptions+ >=> decap+ where+ checkFeature :: HS.HashSet PackagingFeatures -> Resource -> PackagingFeatures -> Either PrettyError (HS.HashSet PackagingFeatures, Resource)+ checkFeature s r f = if HS.member f s+ then Right (s, r)+ else Left $ PrettyError ("Feature" <+> text (show f) <+> "is required for the current configuration")+ checkParam :: Text -> PackagingFeatures -> (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError (HS.HashSet PackagingFeatures, Resource)+ checkParam pn f (s,r) = if has (ix pn) (r ^. rattributes)+ then checkFeature s r f+ else Right (s,r)+ checkAdminFile :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError (HS.HashSet PackagingFeatures, Resource)+ checkAdminFile = Right -- TODO, check that it only works for aix+ checkEnsure :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError (HS.HashSet PackagingFeatures, Resource)+ checkEnsure (s, res) = case res ^. rattributes . at "ensure" of+ Just (PString "latest") -> checkFeature s res Installable+ Just (PString "purged") -> checkFeature s res Purgeable+ Just (PString "absent") -> checkFeature s res Uninstallable+ Just (PString "installed") -> checkFeature s res Installable+ Just (PString "present") -> checkFeature s res Installable+ Just (PString "held") -> checkFeature s res Installable >> checkFeature s res Holdable+ _ -> checkFeature s res Versionable+ decap :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError Resource+ decap = Right . snd
+ src/Puppet/NativeTypes/SshSecure.hs view
@@ -0,0 +1,32 @@+module Puppet.NativeTypes.SshSecure (nativeSshSecure) where++import Puppet.Prelude++import Puppet.Interpreter.Types+import Puppet.NativeTypes.Helpers++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.+parameterfunctions :: [(Text, [Text -> NativeTypeValidate])]+parameterfunctions =+ [("type" , [string, defaultvalue "ssh-rsa", values ["rsa","dsa","ssh-rsa","ssh-dss"]])+ ,("key" , [string])+ ,("user" , [string])+ ,("ensure" , [defaultvalue "present", string, values ["present","absent","role"]])+ ,("target" , [string])+ ,("options" , [rarray, strings])+ ]++userOrTarget :: 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 :: 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"
+ src/Puppet/NativeTypes/User.hs view
@@ -0,0 +1,47 @@+module Puppet.NativeTypes.User (nativeUser) where+++import Puppet.Prelude++import Puppet.NativeTypes.Helpers+import Puppet.Interpreter.Types++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.+parameterfunctions :: [(Text, [Text -> NativeTypeValidate])]+parameterfunctions =+ [("allowdupe" , [string, defaultvalue "false", values ["true","false"]])+ ,("attribute_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]])+ ,("attributes" , [rarray,strings])+ ,("auth_membership" , [defaultvalue "minimum", string, values ["inclusive","minimum"]])+ ,("auths" , [rarray,strings])+ ,("comment" , [string])+ ,("ensure" , [defaultvalue "present", string, values ["present","absent","role"]])+ ,("expiry" , [string])+ ,("gid" , [string])+ ,("groups" , [rarray,strings])+ ,("home" , [string, fullyQualified, noTrailingSlash])+ ,("ia_load_module" , [string])+ ,("iterations" , [integer])+ ,("key_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]])+ ,("keys" , [])+ ,("managehome" , [string, defaultvalue "false", values ["true","false"]])+ ,("membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]])+ ,("name" , [nameval])+ ,("password" , [string])+ ,("password_max_age" , [integer])+ ,("password_min_age" , [integer])+ ,("profile_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]])+ ,("profiles" , [rarray,strings])+ ,("project" , [string])+ ,("provider" , [string, values ["aix","directoryservice","hpuxuseradd","useradd","ldap","pw","user_role_add","window_adsi"]])+ ,("role_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]])+ ,("roles" , [rarray,strings])+ ,("salt" , [string])+ ,("shell" , [string, fullyQualified, noTrailingSlash])+ ,("system" , [string, defaultvalue "false", values ["true","false"]])+ ,("uid" , [integer])+ ]
+ src/Puppet/NativeTypes/ZoneRecord.hs view
@@ -0,0 +1,38 @@+module Puppet.NativeTypes.ZoneRecord (nativeZoneRecord) where++import Puppet.Prelude++import Puppet.Interpreter.Types+import Puppet.NativeTypes.Helpers++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.+parameterfunctions :: [(Text, [Text -> NativeTypeValidate])]+parameterfunctions =+ [("name" , [nameval])+ ,("owner" , [string])+ ,("dest" , [string])+ ,("ensure" , [defaultvalue "present", string, values ["present","absent"]])+ ,("rtype" , [string, defaultvalue "A", values ["SOA", "A", "AAAA", "MX", "NS", "CNAME", "PTR", "SRV"]])+ ,("rclass" , [defaultvalue "IN", string])+ ,("ttl" , [defaultvalue "2d", string])+ ,("target" , [string, mandatory])+ ,("nsname" , [string])+ ,("serial" , [string])+ ,("slave_refresh" , [string])+ ,("slave_retry" , [string])+ ,("slave_expiration" , [string])+ ,("min_ttl" , [string])+ ,("email" , [string])+ ]++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"]+ Just (PString "NS") -> foldM (flip mandatory) res ["owner", "rclass", "rtype", "dest"]+ Just (PString _) -> foldM (flip mandatory) res ["owner", "rclass", "rtype", "dest", "ttl"]+ Just x -> perror $ "Can't use this for the rtype parameter" <+> pretty x
+ src/Puppet/OptionalTests.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE LambdaCase #-}+-- | The module works in IO and throws a 'PrettyError' exception at each failure.+-- These exceptions can be caught (see the exceptions package).+module Puppet.OptionalTests (testCatalog) where++import Puppet.Prelude++import Control.Monad.Catch (throwM)+import qualified Data.HashSet as HS+import qualified Data.Text as Text+import System.Posix.Files (fileExist)++import Puppet.Interpreter.Types+import Puppet.Lens (_PString)+import Puppet.PP+import Puppet.Preferences+++-- | Entry point for all optional tests+testCatalog :: Preferences IO -> FinalCatalog -> IO ()+testCatalog prefs c =+ testFileSources (prefs ^. prefPuppetPaths.baseDir) c+ *> testUsersGroups (prefs ^. prefKnownusers) (prefs ^. prefKnowngroups) c++-- | Tests that all users and groups are defined+testUsersGroups :: [Text] -> [Text] -> FinalCatalog -> IO ()+testUsersGroups kusers kgroups c = do+ let users = HS.fromList $ "" : "0" : map (view (rid . iname)) (getResourceFrom "user") ++ kusers+ groups = HS.fromList $ "" : "0" : map (view (rid . iname)) (getResourceFrom "group") ++ kgroups+ checkResource lu lg = mapM_ (checkResource' lu lg)+ checkResource' lu lg res = do+ let msg att name = align (vsep [ "Resource" <+> ttext (res^.rid.itype)+ <+> ttext (res^.rid.iname) <+> showPos (res^.rpos._1)+ , "references the unknown" <+> string att <+> squotes (ttext name)])+ <> line+ case lu of+ Just lu' -> do+ let u = res ^. rattributes . lu' . _PString+ unless (HS.member u users) $ throwM $ PrettyError (msg "user" u)+ Nothing -> pure ()+ case lg of+ Just lg' -> do+ let g = res ^. rattributes . lg' . _PString+ unless (HS.member g groups) $ throwM $ PrettyError (msg "group" g)+ Nothing -> pure ()+ do+ checkResource (Just $ ix "owner") (Just $ ix "group") (getResourceFrom "file")+ checkResource (Just $ ix "user") (Just $ ix "group") (getResourceFrom "exec")+ checkResource (Just $ ix "user") Nothing (getResourceFrom "cron")+ checkResource (Just $ ix "user") Nothing (getResourceFrom "ssh_authorized_key")+ checkResource (Just $ ix "user") Nothing (getResourceFrom "ssh_authorized_key_secure")+ checkResource Nothing (Just $ ix "gid") (getResourceFrom "users")+ where+ getResourceFrom t = c ^.. traverse . filtered (\r -> r ^. rid . itype == t && r ^. rattributes . at "ensure" /= Just "absent")++-- | Test source for every file resources in the catalog.+testFileSources :: FilePath -> FinalCatalog -> IO ()+testFileSources basedir c = do+ let getfiles = filter presentFile . toList+ presentFile r = r ^. rid . itype == "file"+ && (r ^. rattributes . at "ensure") `elem` [Nothing, Just "present"]+ && r ^. rattributes . at "source" /= Just PUndef+ getsource = mapMaybe (\r -> (,) <$> pure r <*> r ^. rattributes . at "source")+ checkAllSources basedir $ (getsource . getfiles) c++-- | Check source for all file resources and append failures along.+checkAllSources :: FilePath -> [(Resource, PValue)] -> IO ()+checkAllSources fp fs = go fs []+ where+ go ((res, filesource):xs) es =+ runExceptT (checkFile fp filesource) >>= \case+ Right () -> go xs es+ Left err -> go xs ((PrettyError $ "Could not find " <+> pretty filesource <> semi+ <+> align (vsep [getError err, showPos (res^.rpos^._1)])):es)+ go [] [] = pure ()+ go [] es = traverse_ throwM es++testFile :: FilePath -> ExceptT PrettyError IO ()+testFile fp = do+ p <- liftIO (fileExist fp)+ unless p (throwE $ PrettyError $ "searched in" <+> squotes (string fp))++-- | Only test the `puppet:///` protocol (files managed by the puppet server)+-- we don't test absolute path (puppet client files)+checkFile :: FilePath -> PValue -> ExceptT PrettyError IO ()+checkFile basedir (PString f) = case Text.stripPrefix "puppet:///" f of+ Just stringdir -> case Text.splitOn "/" stringdir of+ ("modules":modname:rest) -> testFile (basedir <> "/modules/" <> toS modname <> "/files/" <> toS (Text.intercalate "/" rest))+ ("files":rest) -> testFile (basedir <> "/files/" <> toS (Text.intercalate "/" rest))+ ("private":_) -> pure ()+ _ -> throwE (PrettyError $ "Invalid file source:" <+> ttext f)+ Nothing -> return ()+-- source is always an array of possible paths. We only fails if none of them check.+checkFile basedir (PArray xs) = asum [checkFile basedir x | x <- toList xs]+checkFile _ x = throwE (PrettyError $ "Source was not a string, but" <+> pretty x)
+ src/Puppet/PP.hs view
@@ -0,0 +1,32 @@+module Puppet.PP+ ( ttext+ , prettyToText+ , displayNocolor+ -- * Re-exports+ , module Text.PrettyPrint.ANSI.Leijen+ ) where++import Puppet.Prelude++import qualified Data.Text as Text+import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))++ttext :: Text -> Doc+ttext = text . Text.unpack++prettyToText :: Doc -> Text+prettyToText = Text.pack . prettyToShow++prettyToShow :: Doc -> String+prettyToShow d = displayS (renderCompact d) ""++-- | A rendering function that drops colors.+displayNocolor :: Doc -> String+displayNocolor = flip displayS "" . dropEffects . renderPretty 0.4 180+ where+ dropEffects :: SimpleDoc -> SimpleDoc+ dropEffects (SSGR _ x) = dropEffects x+ dropEffects (SLine l d) = SLine l (dropEffects d)+ dropEffects (SText v t d) = SText v t (dropEffects d)+ dropEffects (SChar c d) = SChar c (dropEffects d)+ dropEffects x = x
+ src/Puppet/Parser.hs view
@@ -0,0 +1,747 @@+{-# LANGUAGE TupleSections #-}++{-| Parse puppet source code from text. -}+module Puppet.Parser (+ -- * Runner+ runPParser+ -- * Parsers+ , Parser+ , puppetParser+ , expression+ , datatype+) where++import Puppet.Prelude hiding (option, try)++import Control.Monad (fail)+import qualified Data.Char as Char+import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import qualified Data.Maybe.Strict as S+import qualified Data.Scientific as Scientific+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Vector as V+import Text.Megaparsec hiding (token)+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L+import Text.Megaparsec.Expr+import Text.Regex.PCRE.ByteString.Utils++import Puppet.Parser.Types++type Parser = Parsec Void Text++-- | Run a puppet parser against some 'Text' input.+runPParser :: String -> Text -> Either (ParseError Char Void) (V.Vector Statement)+runPParser = parse puppetParser++someSpace :: Parser ()+someSpace = L.space (skipSome spaceChar) (L.skipLineComment "#") (L.skipBlockComment "/*" "*/")++token :: Parser a -> Parser a+token = L.lexeme someSpace++integerOrDouble :: Parser (Either Integer Double)+integerOrDouble = fmap Left hex <|> (either Right Left . Scientific.floatingOrInteger <$> L.scientific)+ where+ hex = string "0x" *> L.hexadecimal++symbol :: Text -> Parser ()+symbol = void . try . L.symbol someSpace++symbolic :: Char -> Parser ()+symbolic = symbol . Text.singleton++braces :: Parser a -> Parser a+braces = between (symbol "{") (symbol "}")++parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++brackets :: Parser a -> Parser a+brackets = between (symbol "[") (symbol "]")++comma :: Parser ()+comma = symbol ","++sepComma :: Parser a -> Parser [a]+sepComma p = p `sepEndBy` comma++sepComma1 :: Parser a -> Parser [a]+sepComma1 p = p `sepEndBy1` comma++-- | Parse a collection of puppet 'Statement'.+puppetParser :: Parser (V.Vector Statement)+puppetParser = optional someSpace >> statementList++-- | Parse a puppet 'Expression'.+expression :: Parser Expression+expression = condExpression+ <|> makeExprParser (token terminal) expressionTable+ <?> "expression"+ where+ condExpression = do+ selectedExpression <- try $ do+ trm <- token terminal+ lookups <- optional indexLookupChain+ symbolic '?'+ return $ maybe trm ($ trm) lookups+ let cas = do+ c <- (SelectorDefault <$ symbol "default") -- default case+ <|> fmap SelectorType (try datatype)+ <|> fmap SelectorValue+ ( fmap UVariableReference variableReference+ <|> fmap UBoolean puppetBool+ <|> (UUndef <$ symbol "undef")+ <|> literalValue+ <|> fmap UInterpolable interpolableString+ <|> (URegexp <$> termRegexp)+ )+ void $ symbol "=>"+ e <- expression+ return (c :!: e)+ cases <- braces (sepComma1 cas)+ return (ConditionalValue selectedExpression (V.fromList cases))++variable :: Parser Expression+variable = Terminal . UVariableReference <$> variableReference++stringLiteral' :: Parser Text+stringLiteral' = char '\'' *> interior <* symbolic '\''+ where+ interior = Text.pack . concat <$> many (some (noneOf ['\'', '\\']) <|> (char '\\' *> fmap escape anyChar))+ escape '\'' = "'"+ escape x = ['\\',x]++identifier :: Parser String+identifier = some (satisfy identifierPart)++identifierPart :: Char -> Bool+identifierPart x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || (x == '_')++identl :: Parser Char -> Parser Char -> Parser Text+identl fstl nxtl = do+ f <- fstl+ nxt <- token $ many nxtl+ return $ Text.pack $ f : nxt++operator :: Text -> Parser ()+operator = void . try . symbol++reserved :: Text -> Parser ()+reserved s = try $ do+ void (string s)+ notFollowedBy (satisfy identifierPart)+ someSpace++variableName :: Parser Text+variableName = do+ let acceptablePart = Text.pack <$> many (satisfy identifierAcceptable)+ identifierAcceptable x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || (x == '_')+ out <- qualif acceptablePart+ when (out == "string") (panic "The special variable $string should never be used")+ return out++qualif :: Parser Text -> Parser Text+qualif p = token $ do+ header <- option "" (string "::")+ ( header <> ) . Text.intercalate "::" <$> p `sepBy1` string "::"++qualif1 :: Parser Text -> Parser Text+qualif1 p = try $ do+ r <- qualif p+ unless ("::" `Text.isInfixOf` r) (fail "This parser is not qualified")+ return r++className :: Parser Text+className = qualif moduleName++-- yay with reserved words+typeName :: Parser Text+typeName = className++moduleName :: Parser Text+moduleName = genericModuleName False++resourceNameRef :: Parser Text+resourceNameRef = qualif (genericModuleName True)++genericModuleName :: Bool -> Parser Text+genericModuleName isReference = do+ let acceptable x = Char.isAsciiLower x || Char.isDigit x || (x == '_')+ firstletter = if isReference+ then fmap Char.toLower (satisfy Char.isAsciiUpper)+ else satisfy Char.isAsciiLower+ identl firstletter (satisfy acceptable)++parameterName :: Parser Text+parameterName = moduleName++variableReference :: Parser Text+variableReference = char '$' *> variableName++interpolableString :: Parser (V.Vector Expression)+interpolableString = V.fromList <$> between (char '"') (symbolic '"')+ ( many (interpolableVariableReference <|> doubleQuotedStringContent <|> fmap (Terminal . UString . Text.singleton) (char '$')) )+ where+ doubleQuotedStringContent = Terminal . UString . Text.pack . concat <$>+ some ((char '\\' *> fmap stringEscape anyChar) <|> some (noneOf [ '"', '\\', '$' ]))+ stringEscape :: Char -> String+ stringEscape 'n' = "\n"+ stringEscape 't' = "\t"+ stringEscape 'r' = "\r"+ stringEscape '"' = "\""+ stringEscape '\\' = "\\"+ stringEscape '$' = "$"+ stringEscape x = ['\\',x]+ -- this is specialized because we can't be "tokenized" here+ variableAccept x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || x == '_'+ rvariableName = do+ v <- Text.concat <$> some (string "::" <|> fmap Text.pack (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 = do+ void (char '$')+ let fenced = try (simpleIndexing <* char '}')+ <|> try (rvariable <* char '}')+ <|> (expression <* char '}')+ (symbolic '{' *> fenced) <|> try rvariable <|> pure (Terminal (UString (Text.singleton '$')))++regexp :: Parser Text+regexp = do+ void (char '/')+ Text.pack . concat <$> many ( do { void (char '\\') ; x <- anyChar; return ['\\', x] } <|> some (noneOf [ '/', '\\' ]) )+ <* symbolic '/'++puppetArray :: Parser UnresolvedValue+puppetArray = fmap (UArray . V.fromList) (brackets (sepComma expression)) <?> "Array"++puppetHash :: Parser UnresolvedValue+puppetHash = fmap (UHash . V.fromList) (braces (sepComma hashPart)) <?> "Hash"+ where+ hashPart = (:!:) <$> (expression <* operator "=>")+ <*> expression++puppetBool :: Parser Bool+puppetBool = (reserved "true" >> return True)+ <|> (reserved "false" >> return False)+ <?> "Boolean"++resourceReferenceRaw :: Parser (Text, [Expression])+resourceReferenceRaw = do+ restype <- resourceNameRef <?> "Resource reference type"+ resnames <- brackets (expression `sepBy1` comma) <?> "Resource reference values"+ return (restype, resnames)++resourceReference :: Parser UnresolvedValue+resourceReference = do+ (restype, resnames) <- resourceReferenceRaw+ return $ UResourceReference restype $ case resnames of+ [x] -> x+ _ -> Terminal $ UArray (V.fromList resnames)++bareword :: Parser Text+bareword = identl (satisfy Char.isAsciiLower) (satisfy acceptable) <?> "Bare word"+ where+ acceptable x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || (x == '_') || (x == '-')++-- The first argument defines if non-parenthesized arguments are acceptable+genFunctionCall :: Bool -> Parser (Text, V.Vector Expression)+genFunctionCall nonparens = do+ fname <- moduleName <?> "Function name"+ -- this is a hack. Contrary to what the documentation says,+ -- a "bareword" can perfectly be a qualified name :+ -- include foo::bar+ let argsc sep e = (fmap (Terminal . UString) (qualif1 className) <|> e <?> "Function argument A") `sep` comma+ terminalF = terminalG (fail "function hack")+ expressionF = makeExprParser (token terminalF) expressionTable <?> "function expression"+ withparens = parens (argsc sepEndBy expression)+ withoutparens = argsc sepEndBy1 expressionF+ args <- withparens <|> if nonparens+ then withoutparens <?> "Function arguments B"+ else fail "Function arguments C"+ return (fname, V.fromList args)+++literalValue :: Parser UnresolvedValue+literalValue = token (fmap UString stringLiteral' <|> fmap UString bareword <|> fmap UNumber numericalvalue <?> "Literal Value")+ where+ numericalvalue = integerOrDouble >>= \i -> case i of+ Left x -> return (fromIntegral x)+ Right y -> return (Scientific.fromFloatDigits y)++-- this is a hack for functions :(+terminalG :: Parser Expression -> Parser Expression+terminalG g = parens expression+ <|> fmap (Terminal . UInterpolable) interpolableString+ <|> (reserved "undef" *> return (Terminal UUndef))+ <|> fmap (Terminal . URegexp) termRegexp+ <|> variable+ <|> fmap Terminal puppetArray+ <|> fmap Terminal puppetHash+ <|> fmap (Terminal . UBoolean) puppetBool+ <|> fmap (Terminal . UDataType) datatype+ <|> fmap Terminal resourceReference+ <|> g+ <|> fmap Terminal literalValue++compileRegexp :: Text -> Parser CompRegex+compileRegexp p = case compile' compBlank execBlank (Text.encodeUtf8 p) of+ Right r -> return $ CompRegex p r+ Left ms -> fail ("Can't parse regexp /" ++ Text.unpack p ++ "/ : " ++ show ms)++termRegexp :: Parser CompRegex+termRegexp = regexp >>= compileRegexp++terminal :: Parser Expression+terminal = terminalG (fmap Terminal (fmap UHOLambdaCall (try lambdaCall) <|> try funcCall))+ where+ funcCall :: Parser UnresolvedValue+ funcCall = do+ (fname, args) <- genFunctionCall False+ return $ UFunctionCall fname args++expressionTable :: [[Operator Parser Expression]]+expressionTable = [ [ Postfix indexLookupChain ] -- http://stackoverflow.com/questions/10475337/parsec-expr-repeated-prefix-postfix-operator-not-supported+ , [ Prefix ( operator "-" >> return Negate ) ]+ , [ Prefix ( operator "!" >> return Not ) ]+ , [ InfixL ( operator "." >> return FunctionApplication ) ]+ , [ InfixL ( reserved "in" >> return Contains ) ]+ , [ InfixL ( operator "/" >> return Division )+ , InfixL ( operator "*" >> return Multiplication )+ ]+ , [ InfixL ( operator "+" >> return Addition )+ , InfixL ( operator "-" >> return Substraction )+ ]+ , [ InfixL ( operator "<<" >> return LeftShift )+ , InfixL ( operator ">>" >> return RightShift )+ ]+ , [ InfixL ( operator "==" >> return Equal )+ , InfixL ( operator "!=" >> return Different )+ ]+ , [ InfixL ( operator "=~" >> return RegexMatch )+ , InfixL ( operator "!~" >> return NotRegexMatch )+ ]+ , [ InfixL ( operator ">=" >> return MoreEqualThan )+ , InfixL ( operator "<=" >> return LessEqualThan )+ , InfixL ( operator ">" >> return MoreThan )+ , InfixL ( operator "<" >> return LessThan )+ ]+ , [ InfixL ( reserved "and" >> return And )+ , InfixL ( reserved "or" >> return Or )+ ]+ ]++indexLookupChain :: Parser (Expression -> Expression)+indexLookupChain = List.foldr1 (flip (.)) <$> some checkLookup+ where+ checkLookup = flip Lookup <$> between (operator "[") (operator "]") expression++stringExpression :: Parser Expression+stringExpression = fmap (Terminal . UInterpolable) interpolableString <|> (reserved "undef" *> return (Terminal UUndef)) <|> fmap (Terminal . UBoolean) puppetBool <|> variable <|> fmap Terminal literalValue++varAssign :: Parser VarAssignDecl+varAssign = do+ p <- getPosition+ v <- variableReference+ void $ symbolic '='+ e <- expression+ when (Text.all Char.isDigit v) (fail "Can't assign fully numeric variables")+ pe <- getPosition+ return (VarAssignDecl v e (p :!: pe))++nodeDecl :: Parser [NodeDecl]+nodeDecl = do+ p <- getPosition+ reserved "node"+ let toString (UString s) = s+ toString (UNumber n) = scientific2text n+ toString _ = panic "Can't happen at nodeDecl"+ nodename = (reserved "default" >> return NodeDefault) <|> fmap (NodeName . toString) literalValue+ ns <- (fmap NodeMatch termRegexp <|> nodename) `sepBy1` comma+ inheritance <- option S.Nothing (fmap S.Just (reserved "inherits" *> nodename))+ st <- braces statementList+ pe <- getPosition+ return [NodeDecl n st inheritance (p :!: pe) | n <- ns]++defineDecl :: Parser DefineDecl+defineDecl = do+ p <- getPosition+ reserved "define"+ name <- typeName+ -- TODO check native type+ params <- option V.empty puppetClassParameters+ st <- braces statementList+ pe <- getPosition+ return (DefineDecl name params st (p :!: pe))++puppetClassParameters :: Parser (V.Vector (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression)))+puppetClassParameters = V.fromList <$> parens (sepComma var)+ where+ toStrictMaybe (Just x) = S.Just x+ toStrictMaybe Nothing = S.Nothing+ var :: Parser (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression))+ var = do+ tp <- toStrictMaybe <$> optional datatype+ n <- variableReference+ df <- toStrictMaybe <$> optional (symbolic '=' *> expression)+ return (n :!: tp :!: df)++puppetIfStyleCondition :: Parser (Pair Expression (V.Vector Statement))+puppetIfStyleCondition = (:!:) <$> expression <*> braces statementList++unlessCondition :: Parser ConditionalDecl+unlessCondition = do+ p <- getPosition+ reserved "unless"+ (cond :!: stmts) <- puppetIfStyleCondition+ pe <- getPosition+ return (ConditionalDecl (V.singleton (Not cond :!: stmts)) (p :!: pe))++ifCondition :: Parser ConditionalDecl+ifCondition = do+ p <- getPosition+ reserved "if"+ maincond <- puppetIfStyleCondition+ others <- many (reserved "elsif" *> puppetIfStyleCondition)+ elsecond <- option V.empty (reserved "else" *> braces statementList)+ let ec = if V.null elsecond+ then []+ else [Terminal (UBoolean True) :!: elsecond]+ pe <- getPosition+ return (ConditionalDecl (V.fromList (maincond : others ++ ec)) (p :!: pe))++caseCondition :: Parser ConditionalDecl+caseCondition = do+ let puppetRegexpCase = Terminal . URegexp <$> termRegexp+ defaultCase = Terminal (UBoolean True) <$ try (reserved "default")+ matchesToExpression e (x, stmts) = f x :!: stmts+ where f = case x of+ (Terminal (UBoolean _)) -> identity+ (Terminal (URegexp _)) -> RegexMatch e+ _ -> Equal e+ cases = do+ matches <- (puppetRegexpCase <|> defaultCase <|> expression) `sepBy1` comma+ void $ symbolic ':'+ stmts <- braces statementList+ return $ map (,stmts) matches+ p <- getPosition+ reserved "case"+ expr1 <- expression+ condlist <- concat <$> braces (some cases)+ pe <- getPosition+ return (ConditionalDecl (V.fromList (map (matchesToExpression expr1) condlist)) (p :!: pe) )++data OperatorChain a = OperatorChain a LinkType (OperatorChain a)+ | EndOfChain a++instance Foldable OperatorChain where+ foldMap f (EndOfChain x) = f x+ foldMap f (OperatorChain a _ nx) = f a <> foldMap f nx++operatorChainStatement :: OperatorChain a -> a+operatorChainStatement (OperatorChain a _ _) = a+operatorChainStatement (EndOfChain x) = x++zipChain :: OperatorChain a -> [ ( a, a, LinkType ) ]+zipChain (OperatorChain a d nx) = (a, operatorChainStatement nx, d) : zipChain nx+zipChain (EndOfChain _) = []++depOperator :: Parser LinkType+depOperator = (operator "->" *> pure RBefore)+ <|> (operator "~>" *> pure RNotify)++++assignment :: Parser AttributeDecl+assignment = AttributeDecl <$> key <*> arrowOp <*> expression+ where+ key = identl (satisfy Char.isAsciiLower) (satisfy acceptable) <?> "Assignment key"+ acceptable x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || (x == '_') || (x == '-')+ arrowOp =+ (symbol "=>" *> pure AssignArrow)+ <|> (symbol "+>" *> pure AppendArrow)++searchExpression :: Parser SearchExpression+searchExpression = makeExprParser (token searchterm) searchTable+ where+ searchTable :: [[Operator Parser SearchExpression]]+ searchTable = [ [ InfixL ( reserved "and" >> return AndSearch )+ , InfixL ( reserved "or" >> return OrSearch )+ ] ]+ searchterm = parens searchExpression <|> check+ check = do+ attrib <- parameterName+ opr <- (operator "==" *> return EqualitySearch) <|> (operator "!=" *> return NonEqualitySearch)+ term <- stringExpression+ return (opr attrib term)++resCollDecl :: Position -> Text -> Parser ResCollDecl+resCollDecl p restype = do+ openchev <- some (char '<')+ when (length openchev > 2) (fail "Too many brackets")+ void $ symbolic '|'+ e <- option AlwaysTrue searchExpression+ void (char '|')+ void (count (length openchev) (char '>'))+ someSpace+ overrides <- option [] $ braces (sepComma assignment)+ let collectortype = if length openchev == 1+ then Collector+ else ExportedCollector+ pe <- getPosition+ return (ResCollDecl collectortype restype e (V.fromList overrides) (p :!: pe) )++classDecl :: Parser ClassDecl+classDecl = do+ p <- getPosition+ reserved "class"+ ClassDecl <$> className+ <*> option V.empty puppetClassParameters+ <*> option S.Nothing (fmap S.Just (reserved "inherits" *> className))+ <*> braces statementList+ <*> ( (p :!:) <$> getPosition )++mainFuncDecl :: Parser MainFuncDecl+mainFuncDecl = do+ p <- getPosition+ (fname, args) <- genFunctionCall True+ pe <- getPosition+ return (MainFuncDecl fname args (p :!: pe))++hoLambdaDecl :: Parser HigherOrderLambdaDecl+hoLambdaDecl = do+ p <- getPosition+ fc <- try lambdaCall+ pe <- getPosition+ return (HigherOrderLambdaDecl fc (p :!: pe))++dotLambdaDecl :: Parser HigherOrderLambdaDecl+dotLambdaDecl = do+ p <- getPosition+ ex <- expression+ pe <- getPosition+ hf <- case ex of+ FunctionApplication e (Terminal (UHOLambdaCall hf)) -> do+ unless (S.isNothing (hf ^. hoLambdaExpr)) (fail "Can't call a function with . and ()")+ return (hf & hoLambdaExpr .~ S.Just e)+ Terminal (UHOLambdaCall hf) -> do+ when (S.isNothing (hf ^. hoLambdaExpr)) (fail "This function needs data to operate on")+ return hf+ _ -> fail "A method chained by dots."+ unless (hf ^. hoLambdaFunc == LambEach) (fail "Expected 'each', the other types of method calls are not supported by language-puppet at the statement level.")+ return (HigherOrderLambdaDecl hf (p :!: pe))+++resDefaultDecl :: Parser ResDefaultDecl+resDefaultDecl = do+ p <- getPosition+ rnd <- resourceNameRef+ let assignmentList = V.fromList <$> sepComma1 assignment+ asl <- braces assignmentList+ pe <- getPosition+ return (ResDefaultDecl rnd asl (p :!: pe))++resOverrideDecl :: Parser [ResOverrideDecl]+resOverrideDecl = do+ p <- getPosition+ restype <- resourceNameRef+ names <- brackets (expression `sepBy1` comma) <?> "Resource reference values"+ assignments <- V.fromList <$> braces (sepComma assignment)+ pe <- getPosition+ return [ ResOverrideDecl restype n assignments (p :!: pe) | n <- names ]++-- | Heterogeneous chain (interleaving resource declarations with+-- resource references)needs to be supported:+--+-- class { 'docker::service': } ->+-- Class['docker']+chainableResources :: Parser [Statement]+chainableResources = 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 <$> resCollDecl p restype+ chain <- parseRelationships $ pure <$> try withresname <|> map ChainResDecl <$> resDeclGroup+ let relations = do+ (g1, g2, lt) <- zipChain chain+ (rt1, rn1, _ :!: pe1) <- concatMap extractResRef g1+ (rt2, rn2, ps2 :!: _ ) <- concatMap extractResRef g2+ return (DepDecl (rt1 :!: rn1) (rt2 :!: rn2) lt (pe1 :!: ps2))+ return $ map DependencyDeclaration relations <> (chain ^.. folded . folded . to extractChainStatement . folded)+ where+ extractResRef :: ChainableRes -> [(Text, Expression, PPosition)]+ extractResRef (ChainResColl _) = []+ extractResRef (ChainResDecl (ResDecl rt rn _ _ pp)) = [(rt,rn,pp)]+ extractResRef (ChainResRefr rt rns pp) = [(rt,rn,pp) | rn <- rns]++ extractChainStatement :: ChainableRes -> [Statement]+ extractChainStatement (ChainResColl r) = [ResourceCollectionDeclaration r]+ extractChainStatement (ChainResDecl d) = [ResourceDeclaration d]+ extractChainStatement ChainResRefr{} = []++ parseRelationships :: Parser a -> Parser (OperatorChain a)+ parseRelationships p = do+ g <- p+ o <- optional depOperator+ case o of+ Just o' -> OperatorChain g o' <$> parseRelationships p+ Nothing -> pure (EndOfChain g)++ resDeclGroup :: Parser [ResDecl]+ resDeclGroup = do+ let resourceName = expression+ resourceDeclaration = do+ p <- getPosition+ names <- brackets (sepComma1 resourceName) <|> fmap return resourceName+ void $ symbolic ':'+ vals <- fmap V.fromList (sepComma assignment)+ pe <- getPosition+ return [(n, vals, p :!: pe) | n <- names ]+ groupDeclaration = (,) <$> many (char '@') <*> typeName <* symbolic '{'+ (virts, rtype) <- try groupDeclaration -- for matching reasons, this gets a try until the opening brace+ let sep = symbolic ';' <|> comma+ x <- resourceDeclaration `sepEndBy1` sep+ void $ symbolic '}'+ virtuality <- case virts of+ "" -> return Normal+ "@" -> return Virtual+ "@@" -> return Exported+ _ -> fail "Invalid virtuality"+ return [ ResDecl rtype rname conts virtuality pos | (rname, conts, pos) <- concat x ]++statement :: Parser [Statement]+statement =+ (pure . HigherOrderLambdaDeclaration <$> try dotLambdaDecl)+ <|> (pure . VarAssignmentDeclaration <$> varAssign)+ <|> (map NodeDeclaration <$> nodeDecl)+ <|> (pure . DefineDeclaration <$> defineDecl)+ <|> (pure . ConditionalDeclaration <$> unlessCondition)+ <|> (pure . ConditionalDeclaration <$> ifCondition)+ <|> (pure . ConditionalDeclaration <$> caseCondition)+ <|> (pure . ResourceDefaultDeclaration <$> try resDefaultDecl)+ <|> (map ResourceOverrideDeclaration <$> try resOverrideDecl)+ <|> chainableResources+ <|> (pure . ClassDeclaration <$> classDecl)+ <|> (pure . HigherOrderLambdaDeclaration <$> hoLambdaDecl)+ <|> (pure . MainFunctionDeclaration <$> mainFuncDecl)+ <?> "Statement"++datatype :: Parser UDataType+datatype = dtString+ <|> dtInteger+ <|> dtFloat+ <|> dtNumeric+ <|> (UDTBoolean <$ reserved "Boolean")+ <|> (UDTScalar <$ reserved "Scalar")+ <|> (UDTData <$ reserved "Data")+ <|> (UDTAny <$ reserved "Any")+ <|> (UDTCollection <$ reserved "Collection")+ <|> dtArray+ <|> dtHash+ <|> (UDTUndef <$ reserved "Undef")+ <|> (reserved "Optional" *> (UDTOptional <$> brackets datatype))+ <|> (UNotUndef <$ reserved "NotUndef")+ <|> (reserved "Variant" *> (UDTVariant . NE.fromList <$> brackets (datatype `sepBy1` symbolic ',')))+ -- while all the other cases are straightforward, it seems that the+ -- following syntax is a valid regexp for puppet:+ -- '^dqsqsdqs$'+ -- instead of:+ -- /^dqsqsdqs$/+ --+ -- That is the reason there is a "quotedRegexp" case+ <|> (reserved "Pattern" *> (UDTPattern . NE.fromList <$> brackets ( (termRegexp <|> quotedRegexp) `sepBy1` symbolic ',')))+ <|> (reserved "Enum" *> (UDTEnum . NE.fromList <$> brackets (expression `sepBy1` symbolic ',')))+ <|> dtExternal+ <?> "UDataType"+ where+ quotedRegexp = stringLiteral' >>= compileRegexp+ integer = integerOrDouble >>= either (return . fromIntegral) (\d -> fail ("Integer value expected, instead of " ++ show d))+ float = either fromIntegral identity <$> integerOrDouble+ dtArgs str def parseArgs = do+ void $ reserved str+ fromMaybe def <$> optional (brackets parseArgs)+ dtbounded s constructor parser = dtArgs s (constructor Nothing Nothing) $ do+ lst <- parser `sepBy1` symbolic ','+ case lst of+ [minlen] -> return $ constructor (Just minlen) Nothing+ [minlen,maxlen] -> return $ constructor (Just minlen) (Just maxlen)+ _ -> fail ("Too many arguments to datatype " ++ Text.unpack s)+ dtString = dtbounded "String" UDTString integer+ dtInteger = dtbounded "Integer" UDTInteger integer+ dtFloat = dtbounded "Float" UDTFloat float+ dtNumeric = dtbounded "Numeric" (\ma mb -> UDTVariant (UDTFloat ma mb :| [UDTInteger (truncate <$> ma) (truncate <$> mb)])) float+ dtArray = do+ reserved "Array"+ ml <- optional $ brackets $ do+ tp <- datatype+ rst <- optional (symbolic ',' *> integer `sepBy1` symbolic ',')+ return (tp, rst)+ case ml of+ Nothing -> return (UDTArray UDTData 0 Nothing)+ Just (t, Nothing) -> return (UDTArray t 0 Nothing)+ Just (t, Just [mi]) -> return (UDTArray t mi Nothing)+ Just (t, Just [mi, mx]) -> return (UDTArray t mi (Just mx))+ Just (_, Just _) -> fail "Too many arguments to datatype Array"+ dtHash = do+ reserved "Hash"+ ml <- optional $ brackets $ do+ tk <- datatype+ symbolic ','+ tv <- datatype+ rst <- optional (symbolic ',' *> integer `sepBy1` symbolic ',')+ return (tk, tv, rst)+ case ml of+ Nothing -> return (UDTHash UDTScalar UDTData 0 Nothing)+ Just (tk, tv, Nothing) -> return (UDTHash tk tv 0 Nothing)+ Just (tk, tv, Just [mi]) -> return (UDTHash tk tv mi Nothing)+ Just (tk, tv, Just [mi, mx]) -> return (UDTHash tk tv mi (Just mx))+ Just (_, _, Just _) -> fail "Too many arguments to datatype Hash"+ dtExternal =+ reserved "Stdlib::HTTPUrl" $> UDTData+ <|> reserved "Stdlib::Absolutepath" $> UDTData+ <|> reserved "Stdlib::Unixpath" $> UDTData+ <|> reserved "Nginx::ErrorLogSeverity" $> UDTData+++statementList :: Parser (V.Vector Statement)+statementList = (V.fromList . concat) <$> many statement++lambdaCall :: Parser HOLambdaCall+lambdaCall = do+ let tostrict (Just x) = S.Just x+ tostrict Nothing = S.Nothing+ HOLambdaCall <$> lambFunc+ <*> fmap (tostrict . join) (optional (parens (optional expression)))+ <*> lambParams+ <*> (symbolic '{' *> fmap (V.fromList . concat) (many (try statement)))+ <*> fmap tostrict (optional expression) <* symbolic '}'+ where+ lambFunc :: Parser LambdaFunc+ lambFunc = (reserved "each" *> pure LambEach)+ <|> (reserved "map" *> pure LambMap )+ <|> (reserved "reduce" *> pure LambReduce)+ <|> (reserved "filter" *> pure LambFilter)+ <|> (reserved "slice" *> pure LambSlice)+ <|> (reserved "lookup" *> pure LambLookup)+ lambParams :: Parser LambdaParameters+ lambParams = between (symbolic '|') (symbolic '|') hp+ where+ acceptablePart = Text.pack <$> identifier+ lambdaParameter :: Parser LambdaParameter+ lambdaParameter = LParam <$> optional datatype <*> (char '$' *> acceptablePart)+ hp = do+ vars <- lambdaParameter `sepBy1` comma+ case vars of+ [a] -> return (BPSingle a)+ [a,b] -> return (BPPair a b)+ _ -> fail "Invalid number of variables between the pipes"
+ src/Puppet/Parser/PrettyPrinter.hs view
@@ -0,0 +1,240 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Puppet.Parser.PrettyPrinter where++import Puppet.Prelude hiding (empty, (<$>))++import qualified Data.Maybe.Strict as S+import qualified Data.Text as Text+import qualified Data.Tuple.Strict as Tuple+import qualified Data.Vector as V+import Text.PrettyPrint.ANSI.Leijen ((<$>))++import Puppet.Parser.Types+import Puppet.PP++capitalize :: Text -> Doc+capitalize = dullyellow . text . Text.unpack . capitalizeRT++parensList :: Pretty a => V.Vector a -> Doc+parensList = tupled . fmap pretty . V.toList++hashComma :: (Pretty a, Pretty b) => V.Vector (Pair a b) -> Doc+hashComma = encloseSep lbrace rbrace comma . fmap showC . V.toList+ where+ showC (a :!: b) = pretty a <+> text "=>" <+> pretty b++-- Extremely hacky escaping system+stringEscape :: Text -> Text+stringEscape = Text.concatMap escapeChar+ where+ escapeChar '"' = "\\\""+ escapeChar '\n' = "\\n"+ escapeChar '\t' = "\\t"+ escapeChar '\r' = "\\r"+ escapeChar x = Text.singleton x+{-# INLINE stringEscape #-}++instance Pretty UDataType where+ pretty t = case t of+ UDTType -> "Type"+ UDTString ma mb -> bounded "String" ma mb+ UDTInteger ma mb -> bounded "Integer" ma mb+ UDTFloat ma mb -> bounded "Float" ma mb+ UDTBoolean -> "Boolean"+ UDTArray dt mi mmx -> "Array" <> list (pretty dt : pretty mi : maybe [] (pure . pretty) mmx)+ UDTHash kt dt mi mmx -> "Hash" <> list (pretty kt : pretty dt : pretty mi : maybe [] (pure . pretty) mmx)+ UDTUndef -> "Undef"+ UDTScalar -> "Scalar"+ UDTData -> "Data"+ UDTOptional o -> "Optional" <> brackets (pretty o)+ UNotUndef -> "NotUndef"+ UDTVariant vs -> "Variant" <> list (foldMap (pure . pretty) vs)+ UDTPattern vs -> "Pattern" <> list (foldMap (pure . pretty) vs)+ UDTEnum tx -> "Enum" <> list (foldMap (pure . pretty) tx)+ UDTAny -> "Any"+ UDTCollection -> "Collection"+ where+ bounded :: (Pretty a, Pretty b) => Doc -> Maybe a -> Maybe b -> Doc+ bounded s ma mb = s <> case (ma, mb) of+ (Just a, Nothing) -> list [pretty a]+ (Just a, Just b) -> list [pretty a, pretty b]+ _ -> mempty++instance Pretty Expression where+ pretty (Equal a b) = parens (pretty a <+> text "==" <+> pretty b)+ pretty (Different a b) = parens (pretty a <+> text "!=" <+> pretty b)+ pretty (And a b) = parens (pretty a <+> text "and" <+> pretty b)+ pretty (Or a b) = parens (pretty a <+> text "or" <+> pretty b)+ pretty (LessThan a b) = parens (pretty a <+> text "<" <+> pretty b)+ pretty (MoreThan a b) = parens (pretty a <+> text ">" <+> pretty b)+ pretty (LessEqualThan a b) = parens (pretty a <+> text "<=" <+> pretty b)+ pretty (MoreEqualThan a b) = parens (pretty a <+> text ">=" <+> pretty b)+ pretty (RegexMatch a b) = parens (pretty a <+> text "=~" <+> pretty b)+ pretty (NotRegexMatch a b) = parens (pretty a <+> text "!~" <+> pretty b)+ pretty (Contains a b) = parens (pretty a <+> text "in" <+> pretty b)+ pretty (Addition a b) = parens (pretty a <+> text "+" <+> pretty b)+ pretty (Substraction a b) = parens (pretty a <+> text "-" <+> pretty b)+ pretty (Division a b) = parens (pretty a <+> text "/" <+> pretty b)+ pretty (Multiplication a b) = parens (pretty a <+> text "*" <+> pretty b)+ pretty (Modulo a b) = parens (pretty a <+> text "%" <+> pretty b)+ pretty (RightShift a b) = parens (pretty a <+> text ">>" <+> pretty b)+ pretty (LeftShift a b) = parens (pretty a <+> text "<<" <+> pretty b)+ pretty (Lookup a b) = pretty a <> brackets (pretty b)+ pretty (ConditionalValue a b) = parens (pretty a <+> text "?" <+> hashComma b)+ pretty (Negate a) = text "-" <+> parens (pretty a)+ pretty (Not a) = text "!" <+> parens (pretty a)+ pretty (Terminal a) = pretty a+ pretty (FunctionApplication e1 e2) = parens (pretty e1) <> text "." <> pretty e2++instance Pretty LambdaFunc where+ pretty LambEach = bold $ red $ text "each"+ pretty LambMap = bold $ red $ text "map"+ pretty LambReduce = bold $ red $ text "reduce"+ pretty LambFilter = bold $ red $ text "filter"+ pretty LambSlice = bold $ red $ text "slice"+ pretty LambLookup = bold $ red $ text "lookup"++instance Pretty LambdaParameters where+ pretty b = magenta (char '|') <+> vars <+> magenta (char '|')+ where+ pmspace = foldMap ((<> " ") . pretty)+ vars = case b of+ BPSingle (LParam mt v) -> pmspace mt <> pretty (UVariableReference v)+ BPPair (LParam mt1 v1) (LParam mt2 v2) -> pmspace mt1 <> pretty (UVariableReference v1) <> comma <+> pmspace mt2 <> pretty (UVariableReference v2)++instance Pretty SearchExpression where+ pretty (EqualitySearch t e) = text (Text.unpack t) <+> text "==" <+> pretty e+ pretty (NonEqualitySearch t e) = text (Text.unpack t) <+> text "!=" <+> pretty e+ pretty AlwaysTrue = empty+ pretty (AndSearch s1 s2) = parens (pretty s1) <+> text "and" <+> parens (pretty s2)+ pretty (OrSearch s1 s2) = parens (pretty s1) <+> text "and" <+> parens (pretty s2)++instance Pretty UnresolvedValue where+ pretty (UBoolean True) = dullmagenta $ text "true"+ pretty (UBoolean False) = dullmagenta $ text "false"+ pretty (UString s) = char '"' <> dullcyan (ttext (stringEscape s)) <> char '"'+ pretty (UNumber n) = cyan (ttext (scientific2text n))+ pretty (UInterpolable v) = char '"' <> hcat (map specific (V.toList v)) <> char '"'+ where+ specific (Terminal (UString s)) = dullcyan (ttext (stringEscape s))+ specific (Terminal (UVariableReference vr)) = dullblue (text "${" <> text (Text.unpack vr) <> char '}')+ specific (Lookup (Terminal (UVariableReference vr)) (Terminal x)) = dullblue (text "${" <> text (Text.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) = pretty r+ pretty (UVariableReference v) = dullblue (char '$' <> text (Text.unpack v))+ pretty (UFunctionCall f args) = showFunc f args+ pretty (UHOLambdaCall c) = pretty c+ pretty (UDataType dt) = pretty dt++instance Pretty CompRegex where+ pretty (CompRegex r _) = char '/' <> text (Text.unpack r) <> char '/'++instance Pretty HOLambdaCall where+ pretty (HOLambdaCall hf me bp stts mee) = pretty hf <> mme <+> pretty bp <+> nest 2 (char '{' <$> ppStatements stts <> mmee) <$> char '}'+ where+ mme = case me of+ S.Just x -> mempty <+> pretty x+ S.Nothing -> mempty+ mmee = case mee of+ S.Just x -> mempty </> pretty x+ S.Nothing -> mempty+instance Pretty SelectorCase where+ pretty SelectorDefault = dullmagenta (text "default")+ pretty (SelectorType t) = pretty t+ pretty (SelectorValue v) = pretty v++instance Pretty LinkType where+ pretty RNotify = "~>"+ pretty RRequire = "<-"+ pretty RBefore = "->"+ pretty RSubscribe = "<~"++instance Pretty ArrowOp where+ pretty AssignArrow = "=>"+ pretty AppendArrow = "+>"++showPos :: Position -> Doc+showPos p = green (char '#' <+> string (show p))++showPPos :: PPosition -> Doc+showPPos p = green (char '#' <+> string (show (Tuple.fst p)))++showAss :: V.Vector AttributeDecl -> Doc+showAss vx = folddoc (\a b -> a <> char ',' <$> b) prettyDecl (V.toList vx)+ where+ folddoc _ _ [] = empty+ folddoc acc docGen (x:xs) = foldl acc (docGen x) (map docGen xs)+ maxlen = maximum (fmap (\(AttributeDecl k _ _) -> Text.length k) vx)+ prettyDecl (AttributeDecl k op v) = dullblue (fill maxlen (ttext k)) <+> pretty op <+> pretty v++showArgs :: V.Vector (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression)) -> Doc+showArgs vec = tupled (map ra lst)+ where+ lst = V.toList vec+ maxlen = maximum (map (Text.length . Tuple.fst . Tuple.fst) lst)+ ra (argname :!: mtype :!: rval)+ = dullblue (char '$' <> foldMap (\t -> pretty t <+> empty) mtype+ <> fill maxlen (text (Text.unpack argname)))+ <> foldMap (\v -> empty <+> char '=' <+> pretty v) rval++showFunc :: Text -> V.Vector Expression -> Doc+showFunc funcname args = bold (red (text (Text.unpack funcname))) <> parensList args+braceStatements :: V.Vector Statement -> Doc+braceStatements stts = nest 2 (char '{' <$> ppStatements stts) <$> char '}'++instance Pretty NodeDesc where+ pretty NodeDefault = dullmagenta (text "default")+ pretty (NodeName n) = pretty (UString n)+ pretty (NodeMatch r) = pretty (URegexp r)++instance Pretty Statement where+ pretty (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl c p)) = pretty c <+> showPPos p+ pretty (ConditionalDeclaration (ConditionalDecl 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 (Terminal (UBoolean True) :!: st) = text "else" <+> braceStatements st+ rendernexts (c :!: st) | V.null st = empty+ | otherwise = text "elsif" <+> pretty c <+> braceStatements st+ pretty (MainFunctionDeclaration (MainFuncDecl funcname args p)) = showFunc funcname args <+> showPPos p+ pretty (ResourceDefaultDeclaration (ResDefaultDecl rtype defaults p)) = capitalize rtype <+> nest 2 (char '{' <+> showPPos p <$> showAss defaults) <$> char '}'+ pretty (ResourceOverrideDeclaration (ResOverrideDecl rtype rnames overs p)) = pretty (UResourceReference rtype rnames) <+> nest 2 (char '{' <+> showPPos p <$> showAss overs) <$> char '}'+ pretty (ResourceDeclaration (ResDecl rtype rname args virt p)) = nest 2 (red vrt <> dullgreen (text (Text.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 (DefineDecl 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 (Text.unpack cname)) <> showArgs args <> inheritance <+> showPPos p+ <$> braceStatements stts+ where+ inheritance = case inherit of+ S.Nothing -> empty+ S.Just x -> empty <+> text "inherits" <+> text (Text.unpack x)+ pretty (VarAssignmentDeclaration (VarAssignDecl a b p)) = dullblue (char '$' <> text (Text.unpack a)) <+> char '=' <+> pretty b <+> showPPos p+ pretty (NodeDeclaration (NodeDecl 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 (DependencyDeclaration (DepDecl (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 (ResourceCollectionDeclaration (ResCollDecl coltype restype search overrides p)) = capitalize restype <> enc (pretty search) <+> overs+ where+ overs | V.null overrides = showPPos p+ | otherwise = nest 2 (char '{' <+> showPPos p <$> showAss overrides) <$> char '}'+ enc = case coltype of+ Collector -> enclose (text "<|") (text "|>")+ ExportedCollector -> enclose (text "<<|") (text "|>>")++ppStatements :: V.Vector Statement -> Doc+ppStatements = vcat . map pretty . V.toList
+ src/Puppet/Parser/Types.hs view
@@ -0,0 +1,394 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+-- | All the types used for parsing, and helpers working on these types.+module Puppet.Parser.Types+ ( -- * Position management+ Position,+ PPosition,+ initialPPos,+ toPPos,+ -- ** Lenses+ lSourceName,+ lSourceLine,+ lSourceColumn,+ -- * Helpers+ capitalizeRT,+ rel2text,+ -- * Types+ -- ** Expressions+ Expression(..),+ SelectorCase(..),+ UnresolvedValue(..),+ LambdaFunc(..),+ HOLambdaCall(..),+ ChainableRes(..),+ HasHOLambdaCall(..),+ LambdaParameter(..),+ LambdaParameters(..),+ CompRegex(..),+ CollectorType(..),+ Virtuality(..),+ NodeDesc(..),+ LinkType(..),+ -- ** Datatypes+ UDataType(..),+ -- ** Search Expressions+ SearchExpression(..),+ -- ** Statements+ ArrowOp(..),+ AttributeDecl(..),+ ConditionalDecl(..),+ ClassDecl(..),+ ResDefaultDecl(..),+ DepDecl(..),+ Statement(..),+ ResDecl(..),+ ResOverrideDecl(..),+ DefineDecl(..),+ NodeDecl(..),+ VarAssignDecl(..),+ vadname,+ vadpos,+ vadvalue,+ MainFuncDecl(..),+ HigherOrderLambdaDecl(..),+ ResCollDecl(..)+ ) where++import Puppet.Prelude hiding (show)++import Data.Aeson+import qualified Data.Char as Char+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Maybe.Strict as S+import Data.String+import qualified Data.Text as Text+import qualified Data.Vector as V+import qualified GHC.Exts as Exts+import GHC.Show (Show (..))+import Text.Megaparsec.Pos++-- | Properly capitalizes resource types.+capitalizeRT :: Text -> Text+capitalizeRT = Text.intercalate "::" . map capitalize' . Text.splitOn "::"+ where+ capitalize' :: Text -> Text+ capitalize' t | Text.null t = Text.empty+ | otherwise = Text.cons (Char.toUpper (Text.head t)) (Text.tail t)++-- | A pair containing the start and end of a given token.+type PPosition = Pair Position Position++-- | Position in a puppet file. Currently an alias to 'SourcePos'.+type Position = SourcePos++lSourceName :: Lens' Position String+lSourceName = lens sourceName (\s n -> s { sourceName = n })++lSourceLine :: Lens' Position Pos+lSourceLine = lens sourceLine (\s l -> s { sourceLine = l })++lSourceColumn :: Lens' Position Pos+lSourceColumn = lens sourceColumn (\s c -> s { sourceColumn = c })++-- | Generates an initial position based on a filename.+initialPPos :: Text -> PPosition+initialPPos x =+ let i = initialPos (toS x)+ in (i :!: i)++-- | Generates a 'PPosition' based on a filename and line number.+toPPos :: Text -> Int -> PPosition+toPPos fl ln =+ let p = (initialPos (toS fl)) { sourceLine = mkPos $ fromIntegral (max 1 ln) }+ in (p :!: p)++-- | /High Order lambdas/.+data LambdaFunc+ = LambEach+ | LambMap+ | LambReduce+ | LambFilter+ | LambSlice+ | LambLookup+ deriving (Eq, Show)++-- | Lambda block parameters:+--+-- Currently only two types of block parameters are supported:+-- single values and pairs.+data LambdaParameters+ = BPSingle !LambdaParameter -- ^ @|k|@+ | BPPair !LambdaParameter !LambdaParameter -- ^ @|k,v|@+ deriving (Eq, Show)++data LambdaParameter+ = LParam !(Maybe UDataType) !Text+ deriving (Eq, Show)++-- The description of the /higher level lambda/ call.+data HOLambdaCall = HOLambdaCall+ { _hoLambdaFunc :: !LambdaFunc+ , _hoLambdaExpr :: !(S.Maybe Expression)+ , _hoLambdaParams :: !LambdaParameters+ , _hoLambdaStatements :: !(V.Vector Statement)+ , _hoLambdaLastExpr :: !(S.Maybe Expression)+ } deriving (Eq,Show)++data ChainableRes+ = ChainResColl !ResCollDecl+ | ChainResDecl !ResDecl+ | ChainResRefr !Text [Expression] !PPosition+ deriving (Show, Eq)++data AttributeDecl = AttributeDecl !Text !ArrowOp !Expression+ deriving (Show, Eq)+data ArrowOp+ = AppendArrow -- ^ `+>`+ | AssignArrow -- ^ `=>`+ deriving (Show, Eq)++data CompRegex = CompRegex !Text !Regex+instance Show CompRegex where+ show (CompRegex t _) = show t+instance Eq CompRegex where+ (CompRegex a _) == (CompRegex b _) = a == b+instance FromJSON CompRegex where+ parseJSON = panic "Can't deserialize a regular expression"+instance ToJSON CompRegex where+ toJSON (CompRegex t _) = toJSON t++-- | An unresolved value, typically the parser's output.+data UnresolvedValue+ = UBoolean !Bool -- ^ Special tokens generated when parsing the @true@ or @false@ literals.+ | UString !Text -- ^ Raw string.+ | 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 !Text !Expression -- ^ A Resource[reference]+ | UArray !(V.Vector Expression)+ | UHash !(V.Vector (Pair Expression Expression))+ | URegexp !CompRegex -- ^ The regular expression compilation is performed during parsing.+ | UVariableReference !Text+ | UFunctionCall !Text !(V.Vector Expression)+ | UHOLambdaCall !HOLambdaCall+ | UNumber !Scientific+ | UDataType UDataType+ deriving (Show, Eq)++instance Exts.IsList UnresolvedValue where+ type Item UnresolvedValue = Expression+ fromList = UArray . V.fromList+ toList u = case u of+ UArray lst -> V.toList lst+ _ -> [Terminal u]++instance IsString UnresolvedValue where+ fromString = UString . Text.pack++data SelectorCase+ = SelectorValue !UnresolvedValue+ | SelectorType !UDataType+ | SelectorDefault+ deriving (Eq, Show)++-- | The 'Expression's+data Expression+ = Equal !Expression !Expression+ | Different !Expression !Expression+ | Not !Expression+ | And !Expression !Expression+ | Or !Expression !Expression+ | LessThan !Expression !Expression+ | MoreThan !Expression !Expression+ | LessEqualThan !Expression !Expression+ | MoreEqualThan !Expression !Expression+ | RegexMatch !Expression !Expression+ | NotRegexMatch !Expression !Expression+ | Contains !Expression !Expression+ | Addition !Expression !Expression+ | Substraction !Expression !Expression+ | Division !Expression !Expression+ | Multiplication !Expression !Expression+ | Modulo !Expression !Expression+ | RightShift !Expression !Expression+ | LeftShift !Expression !Expression+ | Lookup !Expression !Expression+ | Negate !Expression+ | ConditionalValue !Expression !(V.Vector (Pair SelectorCase Expression)) -- ^ All conditionals are stored in this format.+ | FunctionApplication !Expression !Expression -- ^ This is for /higher order functions/.+ | Terminal !UnresolvedValue -- ^ Terminal object contains no expression+ deriving (Eq, Show)++data UDataType+ = UDTType+ | UDTString (Maybe Int) (Maybe Int)+ | UDTInteger (Maybe Int) (Maybe Int)+ | UDTFloat (Maybe Double) (Maybe Double)+ | UDTBoolean+ | UDTArray UDataType Int (Maybe Int)+ | UDTHash UDataType UDataType Int (Maybe Int)+ | UDTUndef+ | UDTScalar+ | UDTData+ | UDTOptional UDataType+ | UNotUndef+ | UDTVariant (NonEmpty UDataType)+ | UDTPattern (NonEmpty CompRegex)+ | UDTEnum (NonEmpty Expression)+ | UDTAny+ | UDTCollection+ -- Tuple (NonEmpty DataType) Integer Integer+ -- DTDefault+ -- Struct TODO+ deriving (Eq, Show)++instance Exts.IsList Expression where+ type Item Expression = Expression+ fromList = Terminal . Exts.fromList+ toList u = case u of+ Terminal t -> Exts.toList t+ _ -> [u]++instance Num Expression where+ (+) = Addition+ (-) = Substraction+ (*) = Multiplication+ 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)])+ ])++instance Fractional Expression where+ (/) = Division+ recip x = 1 / x+ fromRational = Terminal . UNumber . fromRational++instance IsString Expression where+ fromString = Terminal . fromString++-- | Search expression inside collector `<| searchexpr |>`+data SearchExpression+ = EqualitySearch !Text !Expression+ | NonEqualitySearch !Text !Expression+ | AndSearch !SearchExpression !SearchExpression+ | OrSearch !SearchExpression !SearchExpression+ | AlwaysTrue+ deriving (Eq, Show)++data CollectorType+ = Collector+ | ExportedCollector+ deriving (Eq, Show)++data Virtuality+ = Normal -- ^ Normal resource, that will be included in the catalog.+ | Virtual -- ^ Type for virtual resources.+ | Exported -- ^ Type for exported resources.+ | ExportedRealized -- ^ These are resources that are exported AND included in the catalogderiving (Generic, Eq, Show).+ deriving (Eq, Show)++data NodeDesc+ = NodeName !Text+ | NodeMatch !CompRegex+ | NodeDefault+ deriving (Show, Eq)++-- | Relationship link type.+data LinkType+ = RNotify+ | RRequire+ | RBefore+ | RSubscribe+ deriving(Show, Eq,Generic)+instance Hashable LinkType++rel2text :: LinkType -> Text+rel2text RNotify = "notify"+rel2text RRequire = "require"+rel2text RBefore = "before"+rel2text RSubscribe = "subscribe"++instance FromJSON LinkType where+ parseJSON (String "require") = return RRequire+ parseJSON (String "notify") = return RNotify+ parseJSON (String "subscribe") = return RSubscribe+ parseJSON (String "before") = return RBefore+ parseJSON _ = panic "invalid linktype"++instance ToJSON LinkType where+ toJSON = String . rel2text++-- | Resource declaration:+--+-- @ file { mode => 755} @+data ResDecl = ResDecl !Text !Expression !(V.Vector AttributeDecl) !Virtuality !PPosition deriving (Eq, Show)++-- | Resource default:+--+-- @ File { mode => 755 } @+--+-- <https://docs.puppetlabs.com/puppet/latest/reference/lang_defaults.html#language:-resource-default-statements puppet reference>.+data ResDefaultDecl = ResDefaultDecl !Text !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show)++-- | Resource override:+--+-- @ File['title'] { mode => 755} @+--+-- See <https://docs.puppetlabs.com/puppet/latest/reference/lang_resources_advanced.html#amending-attributes-with-a-resource-reference puppet reference>.+data ResOverrideDecl = ResOverrideDecl !Text !Expression !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show)++-- | All types of conditional statements : @case@, @if@, ...+--+-- Stored as an ordered list of pair @ (condition, statements) @.+-- Interpreted as "if first cond is true, choose first statements, else take the next pair, check the condition ..."+data ConditionalDecl = ConditionalDecl !(V.Vector (Pair Expression (V.Vector Statement))) !PPosition deriving (Eq, Show)++data ClassDecl = ClassDecl !Text !(V.Vector (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression))) !(S.Maybe Text) !(V.Vector Statement) !PPosition deriving (Eq, Show)+data DefineDecl = DefineDecl !Text !(V.Vector (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression))) !(V.Vector Statement) !PPosition deriving (Eq, Show)++-- | A node is a collection of statements + maybe an inherit node.+data NodeDecl = NodeDecl !NodeDesc !(V.Vector Statement) !(S.Maybe NodeDesc) !PPosition deriving (Eq, Show)++-- | @ $newvar = 'world' @+data VarAssignDecl+ = VarAssignDecl+ { _vadname :: !Text+ , _vadvalue :: !Expression+ , _vadpos :: !PPosition+ } deriving (Eq, Show)++data MainFuncDecl = MainFuncDecl !Text !(V.Vector Expression) !PPosition deriving (Eq, Show)++-- | /Higher order function/ call.+data HigherOrderLambdaDecl = HigherOrderLambdaDecl !HOLambdaCall !PPosition deriving (Eq, Show)++-- | Resource Collector including exported collector (`\<\<| |>>`)+--+-- @ User \<| title == 'jenkins' |> { groups +> "docker"} @+--+-- See <https://docs.puppetlabs.com/puppet/latest/reference/lang_collectors.html#language:-resource-collectors puppet reference>+data ResCollDecl = ResCollDecl !CollectorType !Text !SearchExpression !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show)++data DepDecl = DepDecl !(Pair Text Expression) !(Pair Text Expression) !LinkType !PPosition deriving (Eq, Show)++-- | All possible statements.+data Statement+ = ResourceDeclaration !ResDecl+ | ResourceDefaultDeclaration !ResDefaultDecl+ | ResourceOverrideDeclaration !ResOverrideDecl+ | ResourceCollectionDeclaration !ResCollDecl+ | ClassDeclaration !ClassDecl+ | DefineDeclaration !DefineDecl+ | NodeDeclaration !NodeDecl+ | ConditionalDeclaration !ConditionalDecl+ | VarAssignmentDeclaration !VarAssignDecl+ | MainFunctionDeclaration !MainFuncDecl+ | HigherOrderLambdaDeclaration !HigherOrderLambdaDecl+ | DependencyDeclaration !DepDecl+ | TopContainer !(V.Vector Statement) !Statement -- ^ Special statement used to include the expressions that are top level. Certainly buggy, but probably just like the original implementation.+ deriving (Eq, Show)++makeClassy ''HOLambdaCall+makeLenses ''VarAssignDecl
+ src/Puppet/Parser/Utils.hs view
@@ -0,0 +1,12 @@+module Puppet.Parser.Utils where++import Text.Megaparsec.Pos++import Puppet.Parser.Types+++dummyppos :: PPosition+dummyppos = initialPPos "dummy"++dummypos :: Position+dummypos = initialPos "dummy"
+ src/Puppet/Paths.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TemplateHaskell #-}+module Puppet.Paths where++import Puppet.Prelude++data PuppetDirPaths = PuppetDirPaths+ { _baseDir :: FilePath -- ^ Puppet base working directory+ , _manifestPath :: FilePath -- ^ The path to the manifests.+ , _modulesPath :: FilePath -- ^ The path to the modules.+ , _templatesPath :: FilePath -- ^ The path to the template.+ , _testPath :: FilePath -- ^ The path to a tests folders to hold tests files such as the pdbfiles.+ }++makeClassy ''PuppetDirPaths++puppetPaths :: FilePath -> PuppetDirPaths+puppetPaths basedir = PuppetDirPaths basedir manifestdir modulesdir templatedir testdir+ where+ manifestdir = basedir <> "/manifests"+ modulesdir = basedir <> "/modules"+ templatedir = basedir <> "/templates"+ testdir = basedir <> "/tests"
+ src/Puppet/Preferences.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Puppet.Preferences (+ dfPreferences+ , HasPreferences(..)+ , Preferences(Preferences)+ , PuppetDirPaths+ , HasPuppetDirPaths(..)+) where++import Puppet.Prelude++import Data.Aeson+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.Text as Text+import qualified Data.Yaml as Yaml+import qualified System.Log.Logger as LOG+import System.Posix (fileExist)++import Puppet.Interpreter.Types+import Puppet.NativeTypes+import Puppet.NativeTypes.Helpers+import Puppet.Paths+import qualified Puppet.Puppetlabs as Puppetlabs+import Puppet.Stdlib+import PuppetDB.Dummy++data Preferences m = Preferences+ { _prefPuppetPaths :: PuppetDirPaths+ , _prefPDB :: PuppetDBAPI m+ , _prefNatTypes :: Container NativeTypeMethods -- ^ The list of native types.+ , _prefExtFuncs :: Container ( [PValue] -> InterpreterMonad PValue )+ , _prefHieraPath :: Maybe FilePath+ , _prefIgnoredmodules :: HS.HashSet Text+ , _prefStrictness :: Strictness+ , _prefExtraTests :: Bool+ , _prefKnownusers :: [Text]+ , _prefKnowngroups :: [Text]+ , _prefExternalmodules :: HS.HashSet Text+ , _prefPuppetSettings :: Container Text+ , _prefFactsOverride :: Container PValue+ , _prefFactsDefault :: Container PValue+ , _prefLogLevel :: LOG.Priority+ , _prefRebaseFile :: Maybe FilePath -- ^ Make all calls to file() with absolute pathes relative to the given path.+ }++data Defaults = Defaults+ { _dfKnownusers :: Maybe [Text]+ , _dfKnowngroups :: Maybe [Text]+ , _dfIgnoredmodules :: Maybe [Text]+ , _dfStrictness :: Maybe Strictness+ , _dfExtratests :: Maybe Bool+ , _dfExternalmodules :: Maybe [Text]+ , _dfPuppetSettings :: Maybe (Container Text)+ , _dfFactsDefault :: Maybe (Container PValue)+ , _dfFactsOverride :: Maybe (Container PValue)+ , _dfRebaseFile :: Maybe FilePath+ } deriving Show+++makeClassy ''Preferences++instance FromJSON Defaults where+ parseJSON (Object v) = Defaults+ <$> v .:? "knownusers"+ <*> v .:? "knowngroups"+ <*> v .:? "ignoredmodules"+ <*> v .:? "strict"+ <*> v .:? "extratests"+ <*> v .:? "externalmodules"+ <*> v .:? "settings"+ <*> v .:? "factsdefault"+ <*> v .:? "factsoverride"+ <*> v .:? "rebasefile"+ parseJSON _ = mzero++-- | generate default preferences+dfPreferences :: FilePath+ -> IO (Preferences IO)+dfPreferences basedir = do+ let dirpaths = puppetPaths basedir+ modulesdir = dirpaths ^. modulesPath+ testdir = dirpaths ^. testPath+ hierafile = basedir <> "/hiera.yaml"+ defaultfile = testdir <> "/defaults.yaml"+ defaults <- ifM (fileExist defaultfile) (Yaml.decodeFile defaultfile) (pure Nothing)+ hieradir <- ifM (fileExist hierafile) (pure $ Just hierafile) (pure Nothing)+ loadedtypes <- loadedTypes modulesdir+ labsFunctions <- Puppetlabs.extFunctions modulesdir+ return $ Preferences dirpaths+ dummyPuppetDB+ (baseNativeTypes `HM.union` loadedtypes)+ (HM.union stdlibFunctions labsFunctions)+ hieradir+ (getIgnoredmodules defaults)+ (getStrictness defaults)+ (getExtraTests defaults)+ (getKnownusers defaults)+ (getKnowngroups defaults)+ (getExternalmodules defaults)+ (getPuppetSettings dirpaths defaults)+ (getFactsOverride defaults)+ (getFactsDefault defaults)+ LOG.NOTICE -- good default as INFO is quite noisy+ Nothing++loadedTypes :: FilePath -> IO (HM.HashMap NativeTypeName NativeTypeMethods)+loadedTypes modulesdir = do+ typenames <- fmap (map takeBaseName) (getFiles (Text.pack modulesdir) "lib/puppet/type" ".rb")+ pure $ HM.fromList (map defaulttype typenames)++-- Utilities for getting default values from the yaml file+-- It provides (the same) static defaults (see the 'Nothing' case) when+-- no default yaml file or+-- not key/value for the option has been provided+getKnownusers :: Maybe Defaults -> [Text]+getKnownusers = fromMaybe ["mysql", "vagrant","nginx", "nagios", "postgres", "puppet", "root", "syslog", "www-data"] . (>>= _dfKnownusers)++getKnowngroups :: Maybe Defaults -> [Text]+getKnowngroups = fromMaybe ["adm", "syslog", "mysql", "nagios","postgres", "puppet", "root", "www-data", "postfix"] . (>>= _dfKnowngroups)++getStrictness :: Maybe Defaults -> Strictness+getStrictness = fromMaybe Permissive . (>>= _dfStrictness)++getIgnoredmodules :: Maybe Defaults -> HS.HashSet Text+getIgnoredmodules = maybe mempty HS.fromList . (>>= _dfIgnoredmodules)++getExtraTests :: Maybe Defaults -> Bool+getExtraTests = fromMaybe True . (>>= _dfExtratests)++getExternalmodules :: Maybe Defaults -> HS.HashSet Text+getExternalmodules = maybe mempty HS.fromList . (>>= _dfExternalmodules)++getPuppetSettings :: PuppetDirPaths -> Maybe Defaults -> Container Text+getPuppetSettings dirpaths = fromMaybe df . (>>= _dfPuppetSettings)+ where+ df :: Container Text+ df = HM.fromList [ ("confdir", Text.pack $ dirpaths^.baseDir)+ , ("strict_variables", "true")+ ]++getFactsOverride :: Maybe Defaults -> Container PValue+getFactsOverride = fromMaybe mempty . (>>= _dfFactsOverride)++getFactsDefault :: Maybe Defaults -> Container PValue+getFactsDefault = fromMaybe mempty . (>>= _dfFactsDefault)
+ src/Puppet/Prelude.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+-- | General specific prelude for language-puppet+-- | Customization of the Protolude with extra specific utilities+module Puppet.Prelude (+ module Exports+ , String+ , isEmpty+ , dropInitialColons+ , textElem+ , getDirectoryContents+ , takeBaseName+ , takeDirectory+ , strictifyEither+ , scientific2text+ , text2Scientific+ , getFiles+ , loggerName+ , logDebug+ , logInfo+ , logInfoStr+ , logWarning+ , logError+ , logDebugStr+ , ifromList, ikeys, isingleton, ifromListWith, iunionWith, iinsertWith+) where++import Protolude as Exports hiding (Down,+ Infix, Prefix,+ Selector, State,+ StateT, Strict,+ break, check,+ evalState,+ evalStateT,+ execState,+ execStateT, from,+ hash, list,+ moduleName,+ runState,+ runStateT,+ sourceColumn,+ sourceLine, to,+ uncons, unsnoc,+ withState, (%),+ (<&>), (<.>))++import Control.Exception.Lens as Exports (catching)+import Control.Lens as Exports hiding (Strict,+ argument, noneOf,+ op)+import Control.Monad.Trans.Except as Exports (throwE)+import Control.Monad.Trans.Maybe as Exports (runMaybeT)+import Data.Aeson as Exports (fromJSON, toJSON)+import Data.Scientific as Exports (Scientific)+import Data.Set as Exports (Set)+import Data.Tuple.Strict as Exports (Pair (..))+import Data.Vector as Exports (Vector)+import Text.Regex.PCRE.ByteString.Utils as Exports (Regex)++import Data.Attoparsec.Text (parseOnly, rational)+import qualified Data.ByteString as BS+import qualified Data.Either.Strict as S+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.List as List+import qualified Data.Scientific as Scientific+import Data.String (String)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified System.Log.Logger as Log+import System.Posix.Directory.ByteString++text2Scientific :: Text -> Maybe Scientific+text2Scientific t =+ case parseOnly rational t of+ Left _ -> Nothing+ Right s -> Just s++scientific2text :: Scientific -> Text+scientific2text n =+ Text.pack $ case Scientific.floatingOrInteger n of+ Left r -> show (r :: Double)+ Right i -> show (i :: Integer)++strictifyEither :: Either a b -> S.Either a b+strictifyEither (Left x) = S.Left x+strictifyEither (Right x) = S.Right x++textElem :: Char -> Text -> Bool+textElem c = Text.any (==c)+++-- | See System.FilePath.Posix+takeBaseName :: Text -> Text+takeBaseName fullname =+ let afterLastSlash = List.last $ Text.splitOn "/" fullname+ splitExtension = List.init $ Text.splitOn "." afterLastSlash+ in Text.intercalate "." splitExtension++-- | See System.FilePath.Posix+takeDirectory :: Text -> Text+takeDirectory "" = "."+takeDirectory "/" = "/"+takeDirectory x =+ let res = Text.dropWhileEnd (== '/') file+ file = dropFileName x+ in if Text.null res && not (Text.null file)+ then file+ else res++-- | Drop the filename.+--+-- > dropFileName x == fst (splitFileName x)+--+-- (See System.FilePath.Posix)+dropFileName :: Text -> Text+dropFileName = fst . splitFileName++-- | Split a filename into directory and file. 'combine' is the inverse.+--+-- > Valid x => uncurry (</>) (splitFileName x) == x || fst (splitFileName x) == "./"+-- > Valid x => isValid (fst (splitFileName x))+-- > splitFileName "file/bob.txt" == ("file/", "bob.txt")+-- > splitFileName "file/" == ("file/", "")+-- > splitFileName "bob" == ("./", "bob")+-- > Posix: splitFileName "/" == ("/","")+-- > Windows: splitFileName "c:" == ("c:","")+--+-- (See System.FilePath.Posix)+splitFileName :: Text -> (Text, Text)+splitFileName x =+ (if Text.null dir then "./" else dir, name)+ where+ (dir, name) = splitFileName_ x+ splitFileName_ y =+ let (a,b) = Text.break (=='/') $ Text.reverse y+ in (Text.reverse b, Text.reverse a)++-- | helper for hashmap, in case we want another kind of map ..+ifromList :: (Monoid m, At m, Foldable f) => f (Index m, IxValue m) -> m+{-# INLINABLE ifromList #-}+ifromList = foldl' (\curm (k,v) -> curm & at k ?~ v) mempty++ikeys :: (Eq k, Hashable k) => HM.HashMap k v -> HS.HashSet k+{-# INLINABLE ikeys #-}+ikeys = HS.fromList . HM.keys++isingleton :: (Monoid b, At b) => Index b -> IxValue b -> b+{-# INLINABLE isingleton #-}+isingleton k v = mempty & at k ?~ v++ifromListWith :: (Monoid m, At m, Foldable f) => (IxValue m -> IxValue m -> IxValue m) -> f (Index m, IxValue m) -> m+{-# INLINABLE ifromListWith #-}+ifromListWith f = foldl' (\curmap (k,v) -> iinsertWith f k v curmap) mempty++iinsertWith :: At m => (IxValue m -> IxValue m -> IxValue m) -> Index m -> IxValue m -> m -> m+{-# INLINABLE iinsertWith #-}+iinsertWith f k v m =+ m & at k %~ mightreplace+ where+ mightreplace Nothing = Just v+ mightreplace (Just x) = Just (f v x)++iunionWith :: (Hashable k, Eq k) => (v -> v -> v) -> HM.HashMap k v -> HM.HashMap k v -> HM.HashMap k v+{-# INLINABLE iunionWith #-}+iunionWith = HM.unionWith++getFiles :: Text -> Text -> Text -> IO [Text]+getFiles moduledir subdir extension =+ fmap concat+ $ getDirContents moduledir+ >>= mapM ( checkForSubFiles extension . (\x -> moduledir <> "/" <> x <> "/" <> subdir))++checkForSubFiles :: Text -> Text -> IO [Text]+checkForSubFiles extension dir =+ catch (fmap Right (getDirContents dir)) (\e -> return $ Left (e :: IOException)) >>= \case+ Right o -> return ((map (\x -> dir <> "/" <> x) . filter (Text.isSuffixOf extension)) o )+ Left _ -> return []++getDirContents :: Text -> IO [Text]+getDirContents x = fmap (filter (not . Text.all (=='.'))) (getDirectoryContents x)++getDirectoryContents :: Text -> IO [Text]+getDirectoryContents fpath = do+ h <- openDirStream (Text.encodeUtf8 fpath)+ let readHandle = do+ fp <- readDirStream h+ if BS.null fp+ then return []+ else fmap (Text.decodeUtf8 fp :) readHandle+ out <- readHandle+ closeDirStream h+ pure out++isEmpty :: (Eq x, Monoid x) => x -> Bool+isEmpty = (== mempty)++-- | remove the '::' token from a text if any+dropInitialColons :: Text -> Text+dropInitialColons t = fromMaybe t (Text.stripPrefix "::" t)++loggerName :: String+loggerName = "language-puppet"++logDebug :: Text -> IO ()+logDebug = Log.debugM "language-puppet" . toS++logInfo :: Text -> IO ()+logInfo = Log.infoM "language-puppet" . toS++logInfoStr :: String -> IO ()+logInfoStr = Log.infoM "language-puppet"++logWarning :: Text -> IO ()+logWarning = Log.warningM "language-puppet" . toS++logError :: Text -> IO ()+logError = Log.errorM "language-puppet" . toS++logDebugStr :: String -> IO ()+logDebugStr = Log.debugM "language-puppet"
+ src/Puppet/Puppetlabs.hs view
@@ -0,0 +1,124 @@+-- | Contains an Haskell implementation (or mock implementation) of some ruby functions found in puppetlabs modules+module Puppet.Puppetlabs (extFunctions) where++import Puppet.Prelude++import Crypto.Hash as Crypto+import Data.ByteString (ByteString)+import Data.Foldable (foldlM)+import qualified Data.HashMap.Strict as HM+import Data.Scientific as Sci+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Vector (Vector)+import Formatting (scifmt, sformat, (%), (%.))+import qualified Formatting as FMT+import System.Posix.Files (fileExist)+import System.Random (mkStdGen, randomRs)++import Puppet.Interpreter.PrettyPrinter ()+import Puppet.Interpreter.Types+import Puppet.PP++md5 :: Text -> Text+md5 = Text.pack . show . (Crypto.hash :: ByteString -> Digest MD5) . Text.encodeUtf8++extFun :: [(FilePath, Text, [PValue] -> InterpreterMonad PValue)]+extFun = [ ("/apache", "bool2httpd", apacheBool2httpd)+ , ("/docker", "docker_run_flags", mockDockerRunFlags)+ , ("/jenkins", "jenkins_port", mockJenkinsPort)+ , ("/jenkins", "jenkins_prefix", mockJenkinsPrefix)+ , ("/postgresql", "postgresql_acls_to_resources_hash", pgAclsToHash)+ , ("/postgresql", "postgresql_password", pgPassword)+ , ("/extlib", "random_password", randomPassword)+ , ("/extlib", "cache_data", mockCacheData)+ ]++-- | Build the map of available ext functions+-- If the ruby file is not found on the local filesystem the record is ignored. This is to avoid potential namespace conflict+extFunctions :: FilePath -> IO (Container ( [PValue] -> InterpreterMonad PValue))+extFunctions modpath = foldlM f HM.empty extFun+ where+ f acc (modname, fname, fn) = do+ test <- testFile modname fname+ if test+ then return $ HM.insert fname fn acc+ else return acc+ testFile modname fname = fileExist (modpath <> modname <> "/lib/puppet/parser/functions/" <> Text.unpack fname <>".rb")++apacheBool2httpd :: MonadThrowPos m => [PValue] -> m PValue+apacheBool2httpd [PBoolean True] = return $ PString "On"+apacheBool2httpd [PString "true"] = return $ PString "On"+apacheBool2httpd [_] = return $ PString "Off"+apacheBool2httpd arg@_ = throwPosError $ "expect one single argument" <+> pretty arg++pgPassword :: MonadThrowPos m => [PValue] -> m PValue+pgPassword [PString username, PString pwd] =+ return $ PString $ "md5" <> md5 (pwd <> username)+pgPassword _ = throwPosError "expects 2 string arguments"++-- | The function is pure and always return the same "random" password+randomPassword :: MonadThrowPos m => [PValue] -> m PValue+randomPassword [PNumber s] =+ PString . Text.pack . randomChars <$> scientificToInt s+ where+ randomChars n = take n $ randomRs ('a', 'z') (mkStdGen 1)++randomPassword _ = throwPosError "expect one single string arguments"+++-- | To be implemented if needed+mockJenkinsPrefix :: MonadThrowPos m => [PValue] -> m PValue+mockJenkinsPrefix [] = return $ PString ""+mockJenkinsPrefix arg@_ = throwPosError $ "expect no argument" <+> pretty arg++-- | To be implemented if needed+mockJenkinsPort :: MonadThrowPos m => [PValue] -> m PValue+mockJenkinsPort [] = return $ PString "8080"+mockJenkinsPort arg@_ = throwPosError $ "expect no argument" <+> pretty arg++mockCacheData :: MonadThrowPos m => [PValue] -> m PValue+mockCacheData [_, _, b] = return b+mockCacheData arg@_ = throwPosError $ "expect 3 string arguments" <+> pretty arg++-- | Simple implemenation that does not handle all cases.+-- For instance 'auth_option' is currently not implemented.+-- Please add cases as needed.+pgAclsToHash :: MonadThrowPos m => [PValue] -> m PValue+pgAclsToHash [PArray as, PString ident, PNumber offset] = do+ x <- aclsToHash as ident offset+ return $ PHash x+pgAclsToHash _ = throwPosError "expects 3 arguments; one array one string and one number"++aclsToHash :: MonadThrowPos m => Vector PValue -> Text -> Scientific -> m (Container PValue)+aclsToHash vec ident offset = ifoldlM f HM.empty vec+ where+ f :: MonadThrowPos m => Int -> Container PValue -> PValue -> m (Container PValue)+ f idx acc (PString acl) = do+ let order = offset + scientific (toInteger idx) 0+ keymsg = sformat ("postgresql class generated rule " % FMT.stext % " " % FMT.int) ident idx+ x <- aclToHash (Text.words acl) order+ return $ HM.insert keymsg x acc+ f _ _ pval = throwPosError $ "expect a string as acl but get" <+> pretty pval++aclToHash :: (MonadThrowPos m) => [Text] -> Scientific -> m PValue+aclToHash [typ, db, usr, addr, auth] order =+ return $ PHash $ HM.fromList [ ("type", PString typ)+ , ("database", PString db )+ , ("user", PString usr)+ , ("order", PString (sformat (FMT.left 3 '0' %. scifmt Sci.Fixed (Just 0)) order))+ , ("address", PString addr)+ , ("auth_method", PString auth)+ ]+aclToHash acl _ = throwPosError $ "Unable to parse acl line" <+> squotes (ttext (Text.unwords acl))++-- faked implementation, replace by the correct one if you need so.+mockDockerRunFlags :: MonadThrowPos m => [PValue] -> m PValue+mockDockerRunFlags arg@[PHash _]= (return . PString . Text.pack . displayNocolor . pretty . head) arg+mockDockerRunFlags arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg++-- utils+scientificToInt :: MonadThrowPos m => Scientific -> m Int+scientificToInt s = maybe (throwPosError $ "Unable to convert" <+> string (show s) <+> "into an int.")+ return+ (Sci.toBoundedInteger s)
+ src/Puppet/Stats.hs view
@@ -0,0 +1,63 @@+{-| A quickly done module that exports utility functions used to collect various+statistics. All statistics are stored in a MVar holding a HashMap.++This is not accurate in the presence of lazy evaluation. Nothing is forced.+-}+module Puppet.Stats (measure, newStats, getStats, StatsTable, StatsPoint(..), MStats) where++import Puppet.Prelude++import Data.Time.Clock.POSIX (getPOSIXTime)+import qualified Data.HashMap.Strict as HM++data StatsPoint = StatsPoint { _statspointCount :: !Int -- ^ Total number of calls to a computation+ , _statspointTotal :: !Double -- ^ Total time spent during this computation+ , _statspointMin :: !Double -- ^ Minimum execution time+ , _statspointMax :: !Double -- ^ Maximum execution time+ } deriving(Show)++-- | A table where keys are the names of the computations, and values are+-- 'StatsPoint's.+type StatsTable = HM.HashMap Text StatsPoint++newtype MStats = MStats { unMStats :: MVar StatsTable }+-- | Returns the actual statistical values.+getStats :: MStats -> IO StatsTable+getStats = readMVar . unMStats++-- | Create a new statistical container.+newStats :: IO MStats+newStats = MStats `fmap` newMVar HM.empty++-- | Wraps a computation, and measures related execution statistics.+measure :: MStats -- ^ Statistics container+ -> Text -- ^ Action identifier+ -> IO a -- ^ Computation+ -> IO a+measure (MStats mtable) statsname action = do+ (!tm, !out) <- time action+ !stats <- takeMVar mtable+ let nstats :: StatsTable+ !nstats = case stats ^. at statsname of+ Nothing -> stats & at statsname ?~ StatsPoint 1 tm tm tm+ Just (StatsPoint sc st smi sma) ->+ let !nmax = if tm > sma+ then tm+ else sma+ !nmin = if tm < smi+ then tm+ else smi+ in stats & at statsname ?~ StatsPoint (sc+1) (st+tm) nmin nmax+ putMVar mtable nstats+ return $! out++getTime :: IO Double+getTime = realToFrac `fmap` getPOSIXTime++time :: IO a -> IO (Double, a)+time action = do+ start <- getTime+ !result <- action+ end <- getTime+ let !delta = end - start+ return (delta, result)
+ src/Puppet/Stdlib.hs view
@@ -0,0 +1,494 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+module Puppet.Stdlib (stdlibFunctions) where++import GHC.Show (Show (..))+import Puppet.Prelude hiding (show, sort)++import Data.Aeson.Lens+import qualified Data.ByteString.Base16 as B16+import qualified Data.Char as Char+import qualified Data.HashMap.Strict as HM+import qualified Data.List as List+import qualified Data.List.Split as List (chunksOf)+import qualified Data.Scientific as Scientific+import qualified Data.Text as Text+import qualified Data.Vector as V+import Data.Vector.Lens (toVectorOf)+import qualified Text.PrettyPrint.ANSI.Leijen as PP+import qualified Text.Regex.PCRE.ByteString.Utils as Regex++import Puppet.Interpreter.Resolve+import Puppet.Interpreter.Types+import Puppet.Interpreter.Utils+import Puppet.PP++-- | Contains the implementation of the StdLib functions.+stdlibFunctions :: Container ( [PValue] -> InterpreterMonad PValue )+stdlibFunctions = HM.fromList [ singleArgument "abs" puppetAbs+ , ("any2array", any2array)+ , ("assert_private", assertPrivate)+ , ("base64", base64)+ -- basename+ , singleArgument "bool2num" bool2num+ -- bool2str+ -- camelcase+ , ("capitalize", stringArrayFunction (safeEmptyString (\t -> Text.cons (Char.toUpper (Text.head t)) (Text.tail t))))+ -- ceiling+ , ("chomp", stringArrayFunction (Text.dropWhileEnd (\c -> c == '\n' || c == '\r')))+ , ("chop", stringArrayFunction (safeEmptyString Text.init))+ -- clamp+ , ("concat", puppetConcat)+ -- convert_base+ , ("count", puppetCount)+ -- deep_merge+ , ("defined_with_params", const (throwPosError "defined_with_params can't be implemented with language-puppet"))+ , ("delete", delete)+ , ("delete_at", deleteAt)+ , singleArgument "delete_undef_values" deleteUndefValues+ -- delete_values+ -- difference+ -- dirname+ -- dos2unix+ , ("downcase", stringArrayFunction Text.toLower)+ , singleArgument "empty" _empty+ -- ensure_packages (in main interpreter module)+ -- ensure_resource (in main interpreter module)+ , singleArgument "flatten" flatten+ -- floor+ -- fqdn_rand_string+ -- fqdn_rotate+ -- get_module_path+ , ("getparam", const $ throwPosError "The getparam function is uncool and shall not be implemented in language-puppet")+ , singleArgument "getvar" getvar+ , ("grep", _grep)+ , ("hash", hash)+ -- has_interface_with+ -- has_ip_address+ -- has_ip_network+ , ("has_key", hasKey)+ -- intersection+ -- is_absolute_path+ , singleArgument "is_array" isArray+ , singleArgument "is_bool" isBool+ , singleArgument "is_domain_name" isDomainName+ -- is_float+ -- is_function_available+ , singleArgument "is_hash" isHash+ , singleArgument "is_integer" isInteger+ -- is_ip_address+ -- is_mac_address+ -- is_numeric+ , singleArgument "is_string" isString+ , ("join", puppetJoin)+ , ("join_keys_to_values", joinKeysToValues)+ , singleArgument "keys" keys+ -- load_module_metadata+ -- loadyaml+ , ("lstrip", stringArrayFunction Text.stripStart)+ -- max+ , ("member", member)+ , ("merge", merge)+ -- min+ -- num2bool+ -- parsejson+ -- parseyaml+ , ("pick", pick)+ , ("pick_default", pickDefault)+ -- prefix+ -- private+ -- pw_hash+ -- range+ -- reject+ -- reverse+ , ("rstrip", stringArrayFunction Text.stripEnd)+ -- seeded_rand+ -- shuffle+ , singleArgument "size" size+ , singleArgument "sort" sort+ -- squeeze+ , singleArgument "str2bool" str2Bool+ -- strtosaltedshar512+ -- strftime+ , ("strip", stringArrayFunction Text.strip)+ -- suffix+ -- swapcase+ -- time+ -- to_bytes+ -- try_get_value+ -- type3x+ -- type+ -- union+ -- unique+ -- unix2dos+ , ("upcase", stringArrayFunction Text.toUpper)+ -- uriescape+ , ("validate_absolute_path", validateAbsolutePath)+ , ("validate_array", validateArray)+ -- validate_augeas+ , ("validate_bool", validateBool)+ -- validate_cmd+ , ("validate_hash", validateHash)+ , ("validate_integer", validateInteger)+ -- validate_ip_address+ -- validate_ipv4_address+ -- validate_ipv6_address+ , ("validate_numeric", validateNumeric)+ , ("validate_re", validateRe)+ -- validate_slength+ , ("validate_string", validateString)+ -- validate_x509_rsa_key_pair+ -- values_at+ , singleArgument "values" pvalues+ -- zip+ ]++singleArgument :: Text -> (PValue -> InterpreterMonad PValue) -> (Text, [PValue] -> InterpreterMonad PValue )+singleArgument fname ifunc = (fname, ofunc)+ where+ ofunc [x] = ifunc x+ ofunc _ = throwPosError (ttext fname <> "(): Expects a single argument.")++safeEmptyString :: (Text -> Text) -> Text -> Text+safeEmptyString _ "" = ""+safeEmptyString f x = f x++stringArrayFunction :: (Text -> Text) -> [PValue] -> InterpreterMonad PValue+stringArrayFunction f [PString s] = return (PString (f s))+stringArrayFunction f [PArray xs] = fmap PArray (V.mapM (fmap (PString . f) . resolvePValueString) xs)+stringArrayFunction _ [a] = throwPosError ("function expects a string or an array of strings, not" <+> pretty a)+stringArrayFunction _ _ = throwPosError "function expects a single argument"++compileRE :: Text -> InterpreterMonad Regex+compileRE r = case Regex.compile' Regex.compBlank Regex.execBlank (encodeUtf8 r) of+ Left rr -> throwPosError ("Could not compile" <+> ttext r <+> ":" <+> string (show rr))+ Right x -> return x++matchRE :: Regex -> Text -> InterpreterMonad Bool+matchRE r t = case Regex.execute' r (encodeUtf8 t) of+ Left rr -> throwPosError ("Could not match:" <+> string (show rr))+ Right m -> return (has _Just m)++puppetAbs :: PValue -> InterpreterMonad PValue+puppetAbs y = case y ^? _Number of+ Just x -> return $ _Number # abs x+ Nothing -> throwPosError ("abs(): Expects a number, not" <+> pretty y)++assertPrivate :: [PValue] -> InterpreterMonad PValue+assertPrivate args = case args of+ [] -> go Nothing+ [t] -> resolvePValueString t >>= go . Just+ _ -> throwPosError "assert_private: expects no or a single string argument"+ where+ go msg = do+ scp <- use curScope+ case scp of+ funScope : callerScope : _ ->+ let takeModule = Text.takeWhile (/= ':') . moduleName+ in if takeModule funScope == takeModule callerScope+ then return PUndef+ else throwPosError $ maybe ("assert_private: failed: " <> pretty funScope <> " is private") ttext msg+ _ -> return PUndef++any2array :: [PValue] -> InterpreterMonad PValue+any2array [PArray v] = return (PArray v)+any2array [PHash h] = return (PArray lst)+ where lst = V.fromList $ concatMap arraypair $ HM.toList h+ arraypair (a,b) = [PString a, b]+any2array [x] = return (PArray (V.singleton x))+any2array x = return (PArray (V.fromList x))++base64 :: [PValue] -> InterpreterMonad PValue+base64 [pa,pb] = do+ b <- encodeUtf8 <$> (resolvePValueString pb)+ r <- resolvePValueString pa >>= \case+ "encode" -> return (B16.encode b)+ "decode" -> case B16.decode b of+ (x, "") -> return x+ _ -> throwPosError ("base64(): could not decode" <+> pretty pb)+ a -> throwPosError ("base64(): the first argument must be either 'encode' or 'decode', not" <+> ttext a)+ fmap PString (safeDecodeUtf8 r)+base64 _ = throwPosError "base64(): Expects 2 arguments"++bool2num :: PValue -> InterpreterMonad PValue+bool2num (PString "") = return (PBoolean False)+bool2num (PString "1") = return (PBoolean True)+bool2num (PString "t") = return (PBoolean True)+bool2num (PString "y") = return (PBoolean True)+bool2num (PString "true") = return (PBoolean True)+bool2num (PString "yes") = return (PBoolean True)+bool2num (PString "0") = return (PBoolean False)+bool2num (PString "f") = return (PBoolean False)+bool2num (PString "n") = return (PBoolean False)+bool2num (PString "false") = return (PBoolean False)+bool2num (PString "no") = return (PBoolean False)+bool2num (PString "undef") = return (PBoolean False)+bool2num (PString "undefined") = return (PBoolean False)+bool2num x@(PBoolean _) = return x+bool2num x = throwPosError ("bool2num(): Can't convert" <+> pretty x <+> "to boolean")++puppetConcat :: [PValue] -> InterpreterMonad PValue+puppetConcat = return . PArray . V.concat . map toArr+ where+ toArr (PArray x) = x+ toArr x = V.singleton x++puppetCount :: [PValue] -> InterpreterMonad PValue+puppetCount [PArray x] = return (_Integer # V.foldl' cnt 0 x)+ where+ cnt cur (PString "") = cur+ cnt cur PUndef = cur+ cnt cur _ = cur + 1+puppetCount [PArray x, y] = return (_Integer # V.foldl' cnt 0 x)+ where+ cnt cur z | y == z = cur + 1+ | otherwise = cur+puppetCount _ = throwPosError "count(): expects 1 or 2 arguments"++delete :: [PValue] -> InterpreterMonad PValue+delete [PString x, y] = fmap (PString . Text.concat . (`Text.splitOn` x)) (resolvePValueString y)+delete [PArray r, z] = return $ PArray $ V.filter (/= z) r+delete [PHash h, z] = do+ tz <- resolvePValueString z+ return $ PHash (h & at tz .~ Nothing)+delete [a,_] = throwPosError ("delete(): First argument must be an Array, String, or Hash. Given:" <+> pretty a)+delete _ = throwPosError "delete(): expects 2 arguments"++deleteAt :: [PValue] -> InterpreterMonad PValue+deleteAt [PArray r, z] = case z ^? _Integer of+ Just gn ->+ let n = fromInteger gn+ lr = V.length r+ s1 = V.slice 0 n r+ s2 = V.slice (n+1) (lr - n - 1) r+ in if V.length r <= n+ then throwPosError ("delete_at(): Out of bounds access detected, tried to remove index" <+> pretty z <+> "wheras the array only has" <+> string (show lr) <+> "elements")+ else return (PArray (s1 <> s2))+ _ -> throwPosError ("delete_at(): The second argument must be an integer, not" <+> pretty z)+deleteAt [x,_] = throwPosError ("delete_at(): expects its first argument to be an array, not" <+> pretty x)+deleteAt _ = throwPosError "delete_at(): expects 2 arguments"++deleteUndefValues :: PValue -> InterpreterMonad PValue+deleteUndefValues (PArray r) = return $ PArray $ V.filter (/= PUndef) r+deleteUndefValues (PHash h) = return $ PHash $ HM.filter (/= PUndef) h+deleteUndefValues x = throwPosError ("delete_undef_values(): Expects an Array or a Hash, not" <+> pretty x)++_empty :: PValue -> InterpreterMonad PValue+_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)+ where+ flatten' :: PValue -> V.Vector PValue+ flatten' (PArray x) = V.concatMap flatten' x+ flatten' x = V.singleton x+flatten x = throwPosError ("flatten(): Expects an Array, not" <+> pretty x)++getvar :: PValue -> InterpreterMonad PValue+getvar = resolvePValueString >=> resolveVariable++_grep :: [PValue] -> InterpreterMonad PValue+_grep [PArray vls, rawre] = do+ regexp <- resolvePValueString rawre >>= compileRE+ rvls <- for vls $ \v -> do+ r <- resolvePValueString v+ ismatched <- matchRE regexp r+ return (r, ismatched)+ return $ PArray $ V.map (PString . fst) (V.filter snd rvls)+_grep [x,_] = throwPosError ("grep(): The first argument must be an Array, not" <+> pretty x)+_grep _ = throwPosError "grep(): Expected two arguments."++hash :: [PValue] -> InterpreterMonad PValue+hash [PArray elems] = do+ let xs = mapMaybe assocPairs $ List.chunksOf 2 $ V.toList elems+ assocPairs [a,b] = Just (a,b)+ assocPairs _ = Nothing+ PHash . HM.fromList <$> mapM (\(k,v) -> (,v) <$> resolvePValueString k) xs+hash _ = throwPosError "hash(): Expected and array."++isArray :: PValue -> InterpreterMonad PValue+isArray = return . PBoolean . has _PArray++isDomainName :: PValue -> InterpreterMonad PValue+isDomainName s = do+ rs <- resolvePValueString s+ let ndrs = if Text.last rs == '.'+ then Text.init rs+ else rs+ prts = Text.splitOn "." ndrs+ checkPart x = not (Text.null x)+ && (Text.length x <= 63)+ && (Text.head x /= '-')+ && (Text.last x /= '-')+ && Text.all (\y -> Char.isAlphaNum y || y == '-') x+ return $ PBoolean $ not (Text.null rs) && Text.length rs <= 255 && all checkPart prts++isInteger :: PValue -> InterpreterMonad PValue+isInteger = return . PBoolean . has _Integer++isHash :: PValue -> InterpreterMonad PValue+isHash = return . PBoolean . has _PHash++isString :: PValue -> InterpreterMonad PValue+isString pv = return $ PBoolean $ case (pv ^? _PString, pv ^? _Number) of+ (_, Just _) -> False+ (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 (Text.intercalate interc rrt))+puppetJoin [_,_] = throwPosError "join(): expected an array of strings, and a string"+puppetJoin _ = throwPosError "join(): expected two arguments"++joinKeysToValues :: [PValue] -> InterpreterMonad PValue+joinKeysToValues [PHash h, separator] = do+ ssep <- resolvePValueString separator+ fmap (PArray . V.fromList) $ forM (itoList h) $ \(k,v) -> do+ sv <- case v of+ PUndef -> return ""+ _ -> resolvePValueString v+ return (PString (k <> ssep <> sv))+joinKeysToValues _ = throwPosError "join_keys_to_values(): expects 2 arguments, an hash and a string"++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)++member :: [PValue] -> InterpreterMonad PValue+member [PArray v, x] = return $ PBoolean (x `V.elem` v)+member _ = throwPosError "member() expects 2 arguments"++hasKey :: [PValue] -> InterpreterMonad PValue+hasKey [PHash h, k] = do+ 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."++merge :: [PValue] -> InterpreterMonad PValue+merge xs | length xs < 2 = throwPosError "merge(): Expects at least two hashes"+ | otherwise = let hashcontents = mapM (preview _PHash) xs+ in case hashcontents of+ Nothing -> throwPosError "merge(): Expects hashes"+ Just hashes -> return $ PHash (getDual $ foldMap Dual hashes)++pick :: [PValue] -> InterpreterMonad PValue+pick [] = throwPosError "pick(): must receive at least one non empty value"+pick xs = case filter (`notElem` [PUndef, PString "", PString "undef"]) xs of+ [] -> throwPosError "pick(): no value suitable to be picked"+ (x:_) -> return x++pickDefault :: [PValue] -> InterpreterMonad PValue+pickDefault [] = throwPosError "pick_default(): must receive at least one non empty value"+pickDefault xs = case filter (`notElem` [PUndef, PString "", PString "undef"]) xs of+ [] -> return (List.last xs)+ (x:_) -> return x++size :: PValue -> InterpreterMonad PValue+size (PHash h) = return (_Integer # fromIntegral (HM.size h))+size (PArray v) = return (_Integer # fromIntegral (V.length v))+size (PString s) = return (_Integer # fromIntegral (Text.length s))+size x = throwPosError ("size(): Expects a hash, and array or a string, not" <+> pretty x)++sort :: PValue -> InterpreterMonad PValue+sort (PArray s) =+ let lst = V.toList s+ msort :: Ord a => Prism' PValue a -> Maybe PValue+ msort prsm = PArray . V.fromList . map (review prsm) . List.sort <$> mapM (preview prsm) lst+ in case (msort _PString <|> msort _PNumber) of+ Just x -> return x+ _ -> throwPosError "sort(): only homogeneous arrays of numbers or strings are allowed"+sort x = throwPosError ("sort(): Expect to sort an array, not" <+> pretty x)++str2Bool :: PValue -> InterpreterMonad PValue+str2Bool PUndef = return (PBoolean False)+str2Bool a@(PBoolean _) = return a+str2Bool a = do+ s <- resolvePValueString a+ let b | s `elem` ["", "1", "t", "y", "true", "yes"] = Just True+ | s `elem` [ "0", "f", "n", "false", "no"] = Just False+ | otherwise = Nothing+ case b of+ Just x -> return (PBoolean x)+ Nothing -> throwPosError "str2bool(): Unknown type of boolean given"++validateAbsolutePath :: [PValue] -> InterpreterMonad PValue+validateAbsolutePath [] = throwPosError "validateAbsolutePath(): wrong number of arguments, must be > 0"+validateAbsolutePath a = mapM_ (resolvePValueString >=> validate) a >> return PUndef+ where+ validate x | Text.head x == '/' = return ()+ | otherwise = throwPosError (ttext x <+> "is not an absolute path")++validateArray :: [PValue] -> InterpreterMonad PValue+validateArray [] = throwPosError "validate_array(): wrong number of arguments, must be > 0"+validateArray x = mapM_ vb x >> return PUndef+ where+ vb (PArray _) = return ()+ vb y = throwPosError (pretty y <+> "is not an array.")++validateBool :: [PValue] -> InterpreterMonad PValue+validateBool [] = throwPosError "validate_bool(): wrong number of arguments, must be > 0"+validateBool x = mapM_ vb x >> return PUndef+ where+ vb (PBoolean _) = return ()+ vb y = throwPosError (pretty y <+> "is not a boolean.")++validateHash :: [PValue] -> InterpreterMonad PValue+validateHash [] = throwPosError "validate_hash(): wrong number of arguments, must be > 0"+validateHash x = mapM_ vb x >> return PUndef+ where+ vb (PHash _) = return ()+ vb y = throwPosError (pretty y <+> "is not a hash.")++validateNumeric :: [PValue] -> InterpreterMonad PValue+validateNumeric [] = throwPosError "validate_numeric: invalid arguments"+validateNumeric (arr:extra) = do+ (mn, mx) <- case extra of+ [mx'] -> (Nothing,) . Just <$> resolvePValueNumber mx'+ [PUndef, mi'] -> (,Nothing) . Just <$> resolvePValueNumber mi'+ [mx',mi'] -> (,) <$> (Just <$> resolvePValueNumber mi') <*> (Just <$> resolvePValueNumber mx')+ [] -> pure (Nothing, Nothing)+ _ -> throwPosError "validate_numeric: invalid arguments"+ numbers <- case arr of+ PArray lst -> mapM resolvePValueNumber (V.toList lst)+ _ -> pure <$> resolvePValueNumber arr+ forM_ mn $ \mn' -> unless (all (>= mn') numbers) $ throwPosError "validate_numeric: failure"+ forM_ mx $ \mx' -> unless (all (<= mx') numbers) $ throwPosError "validate_numeric: failure"+ return PUndef++validateRe :: [PValue] -> InterpreterMonad PValue+validateRe [str, reg] = validateRe [str, reg, PString "Match failed"]+validateRe [str, PString reg, msg] = validateRe [str, PArray (V.singleton (PString reg)), msg]+validateRe [str, PArray v, msg] = do+ rstr <- resolvePValueString str+ rest <- mapM (resolvePValueString >=> compileRE >=> flip matchRE rstr) (V.toList v)+ if or rest+ then return PUndef+ else throwPosError (pretty msg PP.<$> "Source string:" <+> pretty str <> comma <+> "regexps:" <+> pretty (V.toList v))+validateRe [_, r, _] = throwPosError ("validate_re(): expected a regexp or an array of regexps, but not" <+> pretty r)+validateRe _ = throwPosError "validate_re(): wrong number of arguments (#{args.length}; must be 2 or 3)"++validateString :: [PValue] -> InterpreterMonad PValue+validateString [] = throwPosError "validate_string(): wrong number of arguments, must be > 0"+validateString x = mapM_ resolvePValueString x >> return PUndef++validateInteger :: [PValue] -> InterpreterMonad PValue+validateInteger [] = throwPosError "validate_integer(): wrong number of arguments, must be > 0"+validateInteger x = PUndef <$ mapM_ vb x+ where+ msg d = pretty d <+> "is not an integer."+ check n = unless (Scientific.isInteger n) $ throwPosError (msg (show n))+ vb (PNumber n) = check n+ vb (PString s) | Just n <- text2Scientific s = check n+ vb a = throwPosError (msg a)++pvalues :: PValue -> InterpreterMonad PValue+pvalues (PHash h) = return $ PArray (toVectorOf traverse h)+pvalues x = throwPosError ("values(): expected a hash, not" <+> pretty x)
+ src/PuppetDB/Common.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE LambdaCase #-}+-- | Common data types for PuppetDB.+module PuppetDB.Common where++import Puppet.Prelude hiding (Read)++import Data.List (stripPrefix)+import Data.Maybe+import Data.Vector.Lens+import GHC.Read (Read (..))+import Network.HTTP.Client+import Servant.Common.BaseUrl+import System.Environment++import Puppet.Interpreter.Types+import PuppetDB.Dummy+import PuppetDB.Remote+import PuppetDB.TestDB++-- | The supported PuppetDB implementations.+data PDBType = PDBRemote -- ^ Your standard PuppetDB, queried through the HTTP interface.+ | PDBDummy -- ^ A stupid stub, this is the default choice.+ | PDBTest -- ^ A slow but handy PuppetDB implementation that is backed by a YAML file.+ deriving Eq++instance Read PDBType where+ readsPrec _ r | isJust reml = [(PDBRemote, fromJust reml)]+ | isJust rems = [(PDBRemote, fromJust rems)]+ | isJust duml = [(PDBDummy, fromJust duml)]+ | isJust dums = [(PDBDummy, fromJust dums)]+ | isJust tstl = [(PDBTest, fromJust tstl)]+ | isJust tsts = [(PDBTest, fromJust tsts)]+ | otherwise = []+ where+ reml = stripPrefix "PDBRemote" r+ rems = stripPrefix "remote" r+ duml = stripPrefix "PDBDummy" r+ dums = stripPrefix "dummy" r+ tstl = stripPrefix "PDBTest" r+ tsts = stripPrefix "test" r++-- | Given a 'PDBType', will try return a sane default implementation.+getDefaultDB :: PDBType -> IO (Either PrettyError (PuppetDBAPI IO))+getDefaultDB PDBDummy = return (Right dummyPuppetDB)+getDefaultDB PDBRemote = do+ url <- parseBaseUrl "http://localhost:8080"+ mgr <- newManager defaultManagerSettings+ pdbConnect mgr url+getDefaultDB PDBTest = lookupEnv "HOME" >>= \case+ Just h -> loadTestDB (h ++ "/.testdb")+ Nothing -> fmap Right initTestDB++-- | Turns a 'FinalCatalog' and 'EdgeMap' into a document that can be+ -- serialized and fed to @puppet apply@.+generateWireCatalog :: NodeName -> FinalCatalog -> EdgeMap -> WireCatalog+generateWireCatalog node cat edgemap = WireCatalog node "version" edges resources "uiid"+ where+ edges = toVectorOf (folded . to (\li -> PuppetEdge (li ^. linksrc) (li ^. linkdst) (li ^. linkType))) (concatOf folded edgemap)+ resources = toVectorOf folded cat
+ src/PuppetDB/Dummy.hs view
@@ -0,0 +1,19 @@+-- | A dummy implementation of 'PuppetDBAPI', that will return empty+-- responses.+module PuppetDB.Dummy where++import Puppet.Prelude++import Puppet.Interpreter.Types++dummyPuppetDB :: Monad m => PuppetDBAPI m+dummyPuppetDB = PuppetDBAPI+ (return "dummy")+ (const (return ()))+ (const (return ()))+ (const (return ()))+ (const (throwError "not implemented"))+ (const (return [] ))+ (const (return [] ))+ (throwError "not implemented")+ (\_ _ -> return [] )
+ src/PuppetDB/Remote.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module PuppetDB.Remote (pdbConnect) where++import Puppet.Prelude++import Network.HTTP.Client (Manager)+import Servant.API+import Servant.Client++import Puppet.Interpreter.Types+import Puppet.PP++type PDBAPIv3 = "nodes" :> QueryParam "query" (Query NodeField) :> Get '[JSON] [NodeInfo]+ :<|> "nodes" :> Capture "resourcename" Text :> "resources" :> QueryParam "query" (Query ResourceField) :> Get '[JSON] [Resource]+ :<|> "facts" :> QueryParam "query" (Query FactField) :> Get '[JSON] [FactInfo]+ :<|> "resources" :> QueryParam "query" (Query ResourceField) :> Get '[JSON] [Resource]++type PDBAPI = "v3" :> PDBAPIv3++api :: Proxy PDBAPI+api = Proxy++-- | Given an URL (ie. @http://localhost:8080@), will return an incomplete 'PuppetDBAPI'.+pdbConnect :: Manager -> BaseUrl -> IO (Either PrettyError (PuppetDBAPI IO))+pdbConnect mgr url =+ return $ Right $ PuppetDBAPI+ (return (string $ show url))+ (const (throwError "operation not supported"))+ (const (throwError "operation not supported"))+ (const (throwError "operation not supported"))+ (q1 sgetFacts)+ (q1 sgetResources)+ (q1 sgetNodes)+ (throwError "operation not supported")+ (\ndename q -> prettyError $ sgetNodeResources ndename (Just q))+ where+ sgetNodes :: Maybe (Query NodeField) -> ClientM [NodeInfo]+ sgetNodeResources :: Text -> Maybe (Query ResourceField) -> ClientM [Resource]+ sgetFacts :: Maybe (Query FactField) -> ClientM [FactInfo]+ sgetResources :: Maybe (Query ResourceField) -> ClientM [Resource]+ (sgetNodes :<|> sgetNodeResources :<|> sgetFacts :<|> sgetResources) = client api++ prettyError :: ClientM b -> ExceptT PrettyError IO b+ prettyError = ExceptT . fmap (_Left %~ PrettyError . string. show) . flip runClientM (ClientEnv mgr url)+ q1 :: (Maybe a -> ClientM b) -> a -> ExceptT PrettyError IO b+ q1 f a = prettyError (f (Just a))
+ src/PuppetDB/TestDB.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}++-- | A stub implementation of PuppetDB, backed by a YAML file.+module PuppetDB.TestDB+ ( loadTestDB+ , initTestDB+) where++import Puppet.Prelude++import Control.Concurrent.STM+import Data.Aeson.Lens (_Integer)+import qualified Data.CaseInsensitive as CaseInsensitive+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.Maybe.Strict as S+import qualified Data.Text as Text+import qualified Data.Vector as V+import Data.Yaml+import Text.Megaparsec.Pos++import Puppet.Interpreter.Types+import Puppet.Parser.Types+import Puppet.PP++data DBContent = DBContent+ { _dbcontentResources :: Container WireCatalog+ , _dbcontentFacts :: Container Facts+ , _dbcontentBackingFile :: Maybe FilePath+ }++makeLensesWith abbreviatedFields ''DBContent++type DB = TVar DBContent++instance FromJSON DBContent where+ parseJSON (Object v) = DBContent <$> v .: "resources" <*> v .: "facts" <*> pure Nothing+ parseJSON _ = mempty++instance ToJSON DBContent where+ toJSON (DBContent r f _) = object [("resources", toJSON r), ("facts", toJSON f)]++-- | Initializes the test DB using a file to back its content+loadTestDB :: FilePath -> IO (Either PrettyError (PuppetDBAPI IO))+loadTestDB fp =+ decodeFileEither fp >>= \case+ Left (OtherParseException rr) -> return (Left (PrettyError (string (show rr))))+ Left (InvalidYaml Nothing) -> baseError "Unknown error"+ Left (InvalidYaml (Just (YamlException s))) -> if take 21 s == "Yaml file not found: "+ then newFile+ else baseError (string s)+ Left (InvalidYaml (Just (YamlParseException pb ctx (YamlMark _ l c)))) -> baseError $ red (string pb <+> string ctx) <+> "at line" <+> int l <> ", column" <+> int c+ Left _ -> newFile+ Right x -> fmap Right (genDBAPI (x & backingFile ?~ fp ))+ where+ baseError r = return $ Left $ PrettyError $ "Could not parse" <+> string fp <> ":" <+> r+ newFile = Right <$> genDBAPI (newDB & backingFile ?~ fp )++-- | Starts a new PuppetDB, without any backing file.+initTestDB :: IO (PuppetDBAPI IO)+initTestDB = genDBAPI newDB++newDB :: DBContent+newDB = DBContent mempty mempty Nothing++genDBAPI :: DBContent -> IO (PuppetDBAPI IO)+genDBAPI db = do+ d <- newTVarIO db+ return (PuppetDBAPI (dbapiInfo d)+ (replCat d)+ (replFacts d)+ (deactivate d)+ (getFcts d)+ (getRes d)+ (getNds d)+ (commit d)+ (getResNode d)+ )++data Extracted = EText Text+ | ESet (HS.HashSet Text)+ | ENil++resolveQuery :: (a -> b -> Extracted) -> Query a -> b -> Bool+resolveQuery _ QEmpty = const True+resolveQuery f (QEqual a t) = \v -> case f a v of+ EText tt -> CaseInsensitive.mk tt == CaseInsensitive.mk t+ ESet ss -> ss ^. contains t+ _ -> False+resolveQuery f (QNot q) = not . resolveQuery f q+resolveQuery f (QG a i) = ncompare (>) f a i+resolveQuery f (QL a i) = ncompare (<) f a i+resolveQuery f (QGE a i) = ncompare (>=) f a i+resolveQuery f (QLE a i) = ncompare (<=) f a i+resolveQuery _ (QMatch _ _) = const False+resolveQuery f (QAnd qs) = \v -> all (\q -> resolveQuery f q v) qs+resolveQuery f (QOr qs) = \v -> any (\q -> resolveQuery f q v) qs++dbapiInfo :: DB -> IO Doc+dbapiInfo db = do+ c <- readTVarIO db+ case c ^. backingFile of+ Nothing -> return "TestDB"+ Just v -> return ("TestDB" <+> string v)++ncompare :: (Integer -> Integer -> Bool) -> (a -> b -> Extracted) -> a -> Integer -> b -> Bool+ncompare operation f a i v = case f a v of+ EText tt -> case PString tt ^? _Integer of+ Just ii -> operation i ii+ _ -> False+ _ -> False++replCat :: DB -> WireCatalog -> ExceptT PrettyError IO ()+replCat db wc = liftIO $ atomically $ modifyTVar db (resources . at (wc ^. wireCatalogNodename) ?~ wc)++replFacts :: DB -> [(NodeName, Facts)] -> ExceptT PrettyError IO ()+replFacts db lst = liftIO $ atomically $ modifyTVar db $+ facts %~ (\r -> foldl' (\curr (n,f) -> curr & at n ?~ f) r lst)++deactivate :: DB -> NodeName -> ExceptT PrettyError IO ()+deactivate db n = liftIO $ atomically $ modifyTVar db $+ (resources . at n .~ Nothing) . (facts . at n .~ Nothing)++getFcts :: DB -> Query FactField -> ExceptT PrettyError IO [FactInfo]+getFcts db f = fmap (filter (resolveQuery factQuery f) . toFactInfo) (liftIO $ readTVarIO db)+ where+ toFactInfo :: DBContent -> [FactInfo]+ toFactInfo = concatMap gf . HM.toList . _dbcontentFacts+ where+ gf (k,n) = do+ (fn,fv) <- HM.toList n+ return $ FactInfo k fn fv+ factQuery :: FactField -> FactInfo -> Extracted+ factQuery t = EText . view l+ where+ l = case t of+ FName -> factInfoName+ FValue -> factInfoVal . _PString+ FCertname -> factInfoNodename++resourceQuery :: ResourceField -> Resource -> Extracted+resourceQuery RTag r = r ^. rtags . to ESet+resourceQuery RCertname r = r ^. rnode . to EText+resourceQuery (RParameter p) r = case r ^? rattributes . ix p . _PString of+ Just s -> EText s+ Nothing -> ENil+resourceQuery RType r = r ^. rid . itype . to EText+resourceQuery RTitle r = r ^. rid . iname . to EText+resourceQuery RExported r = if r ^. rvirtuality == Exported+ then EText "true"+ else EText "false"+resourceQuery RFile r = r ^. rpos . _1 . to sourceName . to Text.pack . to EText+resourceQuery RLine r = r ^. rpos . _1 . to sourceLine . to show . to Text.pack . to EText++getRes :: DB -> Query ResourceField -> ExceptT PrettyError IO [Resource]+getRes db f = fmap (filter (resolveQuery resourceQuery f) . toResources) (liftIO $ readTVarIO db)+ where+ toResources :: DBContent -> [Resource]+ toResources = concatMap (V.toList . view wireCatalogResources) . HM.elems . view resources++getResNode :: DB -> NodeName -> Query ResourceField -> ExceptT PrettyError IO [Resource]+getResNode db nn f = do+ c <- liftIO $ readTVarIO db+ case c ^. resources . at nn of+ Just cnt -> return $ filter (resolveQuery resourceQuery f) $ V.toList $ cnt ^. wireCatalogResources+ Nothing -> throwError "Unknown node"++commit :: DB -> ExceptT PrettyError IO ()+commit db = do+ dbc <- liftIO $ atomically $ readTVar db+ case dbc ^. backingFile of+ Nothing -> throwError "No backing file defined"+ Just bf -> liftIO (encodeFile bf dbc `catches` [ ])++getNds :: DB -> Query NodeField -> ExceptT PrettyError IO [NodeInfo]+getNds db QEmpty = fmap toNodeInfo (liftIO $ readTVarIO db)+ where+ toNodeInfo :: DBContent -> [NodeInfo]+ toNodeInfo = fmap g . HM.keys . _dbcontentFacts+ where+ g :: NodeName -> NodeInfo+ g = \n -> NodeInfo n False S.Nothing S.Nothing S.Nothing++getNds _ _ = throwError "getNds with query not implemented"
tests/DT/Parser.hs view
@@ -1,19 +1,21 @@ module DT.Parser (spec) where -import qualified Data.Text as T+import Helpers+ import Puppet.Parser-import Puppet.Parser.Types-import Test.Hspec import Test.Hspec.Megaparsec import Text.Megaparsec (parse) spec :: Spec spec = do- let prs s r = it s $ parse datatype "?" (T.pack s) `shouldParse` r- fl s = it s $ shouldFailOn (parse datatype "?") (T.pack s)+ let parsed s r = it ("accepts " <> toS s) $ parse datatype "?" s `shouldParse` r+ failed s = it ("rejects " <> toS s) $ shouldFailOn (parse datatype "?") s describe "String" $ do- "String" `prs` DTString Nothing Nothing- fl "String[]"- fl "String[4,5,6]"- "String[5]" `prs` DTString (Just 5) Nothing- "String[5,8]" `prs` DTString (Just 5) (Just 8)+ "String" `parsed` UDTString Nothing Nothing+ failed "String[]"+ failed "String[4,5,6]"+ "String[5]" `parsed` UDTString (Just 5) Nothing+ "String[5,8]" `parsed` UDTString (Just 5) (Just 8)+ it "accepts variables" $ pendingWith "to be fixed" *> parse datatype "?" "String[$var]" `shouldParse` UDTString (Just 5) Nothing+ describe "Stdlib::" $ do+ "Stdlib::HTTPUrl" `parsed` UDTData
tests/Function/AssertPrivateSpec.hs view
@@ -1,20 +1,12 @@ {-# LANGUAGE OverloadedLists #-} module Function.AssertPrivateSpec where -import Test.Hspec--import Control.Lens-import Control.Monad-import Data.Text (Text)+import Helpers import Puppet.Interpreter.Resolve-import Puppet.Interpreter.Pure-import Puppet.Interpreter.Types import Puppet.Interpreter.Utils (initialState) import Puppet.Interpreter.IO (interpretMonad)-import Puppet.Parser.Types -import Helpers main :: IO () main = hspec spec
tests/Function/DeleteAtSpec.hs view
@@ -1,12 +1,7 @@ {-# LANGUAGE OverloadedLists #-}-module Function.DeleteAtSpec (spec, main) where--import Test.Hspec--import Data.Monoid+{-# LANGUAGE FlexibleContexts #-} -import Puppet.Interpreter.Pure-import Puppet.Interpreter.Types+module Function.DeleteAtSpec (spec, main) where import Helpers
tests/Function/EachSpec.hs view
@@ -1,11 +1,8 @@- {-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedLists #-} module Function.EachSpec (spec, main) where -import Test.Hspec import Helpers -import Puppet.Interpreter.Types- main :: IO () main = hspec spec @@ -51,5 +48,3 @@ pending c <- mgetCatalog "$a = [1, 3, 2]\n $b = $a.each |$x| { \"unwanted\" }\n $u = $b[1]\n file { \"/file_${u}\":\n ensure => present\n }" getResource (RIdentifier "file" "/file_3") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"--
+ tests/Function/LookupSpec.hs view
@@ -0,0 +1,29 @@+module Function.LookupSpec (spec, main) where++import Helpers++main :: IO ()+main = hspec spec++fname = "lookup"+expectedErrMsg = "Wrong set of arguments"+expectedValue = "pure"++checkSuccess :: [Expression] -> Text -> Expectation+checkSuccess = checkExprsSuccess fname++checkError :: [Expression] -> String -> Expectation+checkError = checkExprsError fname+++boolDatatype = Terminal (UDataType UDTBoolean)+stringDatatype = Terminal (UDataType (UDTString Nothing Nothing))++spec :: Spec+spec = do+ it "should fail with no argument" (checkError [] expectedErrMsg)+ it "should succeed with one argument" (checkSuccess ["hostname"] expectedValue)+ it "should succeed with 4 arguments" (checkSuccess ["hostname", stringDatatype, "unique", "default"] expectedValue)+ it "should succeed with two arguments, the second on being a datatype" (checkSuccess ["hostname", stringDatatype] expectedValue)+ it "should fail when the type mismatched" (checkError ["hostname", boolDatatype] "Datatype mismatched")+ it "should fail with two arguments both strings" (checkError ["hostname", "default"] expectedErrMsg)
tests/Function/MergeSpec.hs view
@@ -1,18 +1,12 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedLists #-} module Function.MergeSpec (spec, main) where -import Test.Hspec -import Control.Monad-import qualified Data.HashMap.Strict as HM-import Data.Monoid-import Data.Text (Text)+import Helpers -import Puppet.Interpreter.Pure-import Puppet.Interpreter.Types-import Puppet.PP+import qualified Data.HashMap.Strict as HM -import Helpers main :: IO () main = hspec spec
tests/Function/ShellquoteSpec.hs view
@@ -1,33 +1,16 @@ {-# LANGUAGE OverloadedLists #-} module Function.ShellquoteSpec (spec, main) where -import Test.Hspec--import Data.Text (Text)-import qualified Data.Vector as V-import Control.Monad-import Data.Monoid--import Puppet.Interpreter.Resolve-import Puppet.Interpreter.Pure-import Puppet.Interpreter.Types-import Puppet.Parser.Types-import Puppet.PP+import Helpers main :: IO () main = hspec spec -evalArgs :: [Expression] -> Either PrettyError Text-evalArgs = dummyEval . resolveValue . UFunctionCall "shellquote" . V.fromList- >=> \pv -> case pv of- PString s -> return s- _ -> Left ("Expected a string, not " <> PrettyError (pretty pv))+check :: [Expression] -> Text -> Expectation+check = checkExprsSuccess "shellquote" spec :: Spec spec = do- let check args res = case evalArgs args of- Left rr -> expectationFailure (show rr)- Right res' -> res' `shouldBe` res it "should handle no arguments" (check [] "") it "should handle array arguments" $ check ["foo", ["bar@example.com", "localhost:/dev/null"], "xyzzy+-4711,23"]
tests/Function/SizeSpec.hs view
@@ -1,16 +1,7 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedLists #-} module Function.SizeSpec (spec, main) where -import Test.Hspec--import Control.Monad-import Data.Monoid-import Data.Scientific--import Puppet.Interpreter.Pure-import Puppet.Interpreter.Types-import Puppet.PP- import Helpers main :: IO ()@@ -50,4 +41,3 @@ check ["a"] 1 check ["ab"] 2 check ["abcd"] 4-
tests/Function/SprintfSpec.hs view
@@ -1,36 +1,17 @@ module Function.SprintfSpec (spec, main) where -import Test.Hspec-import Data.Text (Text)-import Control.Monad-import qualified Data.Vector as V-import Data.Monoid--import Puppet.Interpreter.Pure-import Puppet.Interpreter.Resolve-import Puppet.Interpreter.Types-import Puppet.Parser.Types-import Puppet.PP+import Helpers main :: IO () main = hspec spec -evalArgs :: [Expression] -> Either PrettyError Text-evalArgs = dummyEval . resolveValue . UFunctionCall "sprintf" . V.fromList- >=> \pv -> case pv of- PString s -> return s- _ -> Left ("Expected a string, not " <> PrettyError (pretty pv))+fname = "sprintf" checkSuccess :: [Expression] -> Text -> Expectation-checkSuccess args res =- case evalArgs args of- Left rr -> expectationFailure (show rr)- Right res' -> res' `shouldBe` res+checkSuccess = checkExprsSuccess fname+ checkError :: [Expression] -> String -> Expectation-checkError args msg =- case evalArgs args of- Left rr -> show rr `shouldContain` msg- Right r -> expectationFailure ("Should have errored, received this instead: " <> show r)+checkError = checkExprsError fname spec :: Spec spec = do
tests/Helpers.hs view
@@ -1,6 +1,10 @@-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE FlexibleContexts #-}-module Helpers ( compileCatalog+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists #-}+module Helpers ( module Exports+ , compileCatalog+ , checkExprsSuccess+ , checkExprsError , getCatalog , getResource , getAttribute@@ -8,21 +12,29 @@ , withStdlibFunction ) where -import Puppet.Interpreter (computeCatalog)-import Puppet.Interpreter.Pure-import Puppet.Interpreter.Types++-- import Control.Lens as Exports hiding (Strict, argument,+-- failing, noneOf, op)+import Control.Monad as Exports(fail)++import Puppet.Interpreter.Pure as Exports+import Puppet.Interpreter.Types as Exports+import Puppet.Parser.Types as Exports+import Puppet.PP as Exports hiding (bool, cat, empty,+ text, group)+import Puppet.Prelude as Exports+import Test.Hspec as Exports++import qualified Data.HashMap.Strict as HM+import qualified Data.Maybe.Strict as S+import Data.Text as Text+import qualified Data.Vector as Vector++import Puppet.Interpreter (computeCatalog)+import Puppet.Interpreter.Resolve import Puppet.Parser-import Puppet.Parser.Types-import Puppet.PP import Puppet.Stdlib -import Control.Lens-import Control.Monad.Except-import qualified Data.HashMap.Strict as HM-import qualified Data.Maybe.Strict as S-import Data.Text (Text, unpack)-import Test.Hspec- compileCatalog :: MonadError String m => Text -> m (FinalCatalog, EdgeMap, FinalCatalog, [Resource], InterpreterState) compileCatalog input = do statements <- either (throwError . show) return (runPParser "dummy" input)@@ -38,16 +50,36 @@ spretty :: Pretty a => a -> String spretty = flip displayS "" . renderCompact . pretty -getResource :: Monad m => RIdentifier -> FinalCatalog -> m Resource+getResource :: (Monad m) => RIdentifier -> FinalCatalog -> m Resource getResource resid catalog = maybe (fail ("Unknown resource " ++ spretty resid)) return (HM.lookup resid catalog) getAttribute :: Monad m => Text -> Resource -> m PValue-getAttribute att res = case res ^? rattributes . ix att of- Nothing -> fail ("Unknown attribute: " ++ unpack att)- Just x -> return x+getAttribute att res =+ case res ^? rattributes . ix att of+ Nothing -> fail ("Unknown attribute: " ++ Text.unpack att)+ Just x -> return x withStdlibFunction :: Text -> ( ([PValue] -> InterpreterMonad PValue) -> Spec ) -> Spec withStdlibFunction fname testsuite = case stdlibFunctions ^? ix fname of- Just f -> testsuite f- Nothing -> fail ("Don't know this function: " ++ show fname)+ Just f -> testsuite f+ Nothing -> panic ("Don't know this function: " <> fname)++checkExprsSuccess :: Text -> [Expression] -> Text -> Expectation+checkExprsSuccess fname args res =+ case evalExprs fname args of+ Left rr -> expectationFailure (show rr)+ Right res' -> res' `shouldBe` res++checkExprsError :: Text -> [Expression] -> String -> Expectation+checkExprsError fname args msg =+ case evalExprs fname args of+ Left rr -> show rr `shouldContain` msg+ Right r -> expectationFailure ("Should have errored, received this instead: " <> show r)++evalExprs :: Text -> [Expression] -> Either PrettyError Text+evalExprs fname =+ dummyEval . resolveValue . UFunctionCall fname . Vector.fromList+ >=> \pv -> case pv of+ PString s -> return s+ _ -> Left ("Expected a string, not " <> PrettyError (pretty pv))
tests/Interpreter/CollectorSpec.hs view
@@ -5,26 +5,23 @@ import Test.Hspec import Control.Lens-import Control.Monad.Except-import Data.Text (Text)-import qualified Data.Text as T+import qualified Data.Text as Text import Helpers-import Puppet.Interpreter.Types shouldNotify :: [Text] -> [PValue] -> Expectation shouldNotify content expectedMessages = do- cat <- case runExcept (getCatalog (T.unlines content)) of- Left rr -> fail rr- Right x -> return x- let messages = itoList cat ^.. folded . filtered (\rp -> rp ^. _1 . itype == "notify") . _2 . rattributes . ix "message"+ catalog <- case runExcept (getCatalog (Text.unlines content)) of+ Left rr -> fail rr+ Right x -> return x+ let messages = itoList catalog ^.. folded . filtered (\rp -> rp ^. _1 . itype == "notify") . _2 . rattributes . ix "message" messages `shouldMatchList` expectedMessages shouldFail :: [Text] -> Expectation-shouldFail content = let cat :: Either String FinalCatalog- cat = runExcept (getCatalog (T.unlines content))- in cat `shouldSatisfy` has _Left+shouldFail content = let catalog :: Either String FinalCatalog+ catalog = runExcept (getCatalog (Text.unlines content))+ in catalog `shouldSatisfy` has _Left spec :: Spec spec = do
tests/Interpreter/IfSpec.hs view
@@ -5,12 +5,9 @@ import Test.Hspec import Control.Lens-import Control.Monad.Except-import Data.Text (Text)-import qualified Data.Text as T+import qualified Data.Text as Text import Helpers-import Puppet.Interpreter.Types {- shouldReturn :: [Text] -> [PValue] -> Expectation@@ -23,12 +20,12 @@ shouldFail :: [Text] -> Expectation shouldFail content = let cat :: Either String FinalCatalog- cat = runExcept (getCatalog (T.unlines content))+ cat = runExcept (getCatalog (Text.unlines content)) in cat `shouldSatisfy` has _Left shouldNotFail :: [Text] -> Expectation shouldNotFail content = let cat :: Either String FinalCatalog- cat = runExcept (getCatalog (T.unlines content))+ cat = runExcept (getCatalog (Text.unlines content)) in cat `shouldSatisfy` has _Right spec :: Spec
tests/InterpreterSpec.hs view
@@ -1,28 +1,21 @@ module InterpreterSpec (collectorSpec, classIncludeSpec, main) where -import Control.Lens+import Helpers+ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM-import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T+import qualified Data.Text as Text import qualified Data.Vector as V-import Test.Hspec import Text.Megaparsec (eof, parse) import Puppet.Interpreter-import Puppet.Interpreter.Pure-import Puppet.Interpreter.Types--- import Puppet.Lens import Puppet.Parser-import Puppet.Parser.Types-import Puppet.PP appendArrowNode :: Text appendArrowNode = "appendArrow" arrowOperationInput :: ArrowOp -> Text-arrowOperationInput arr = T.unlines [ "node " <> appendArrowNode <> " {"+arrowOperationInput arr = Text.unlines [ "node " <> appendArrowNode <> " {" , "user { 'jenkins':" , " groups => 'ci'" , "}"@@ -61,9 +54,9 @@ classIncludeSpec = do let compute i = pureCompute "dummy" i ^. _1 describe "Multiple loading" $ do- it "should work when using several include statements" $ compute (T.unlines [ "node 'dummy' {", "include foo", "include foo", "}" ]) `shouldSatisfy` (has _Right)- it "should work when using class before include" $ compute (T.unlines [ "node 'dummy' {", "class { 'foo': }", "include foo", "}" ]) `shouldSatisfy` (has _Right)- it "should fail when using include before class" $ compute (T.unlines [ "node 'dummy' {", "include foo", "class { 'foo': }", "}" ]) `shouldSatisfy` (has _Left)+ it "should work when using several include statements" $ compute (Text.unlines [ "node 'dummy' {", "include foo", "include foo", "}" ]) `shouldSatisfy` (has _Right)+ it "should work when using class before include" $ compute (Text.unlines [ "node 'dummy' {", "class { 'foo': }", "include foo", "}" ]) `shouldSatisfy` (has _Right)+ it "should fail when using include before class" $ compute (Text.unlines [ "node 'dummy' {", "include foo", "class { 'foo': }", "}" ]) `shouldSatisfy` (has _Left) main :: IO () main = hspec $ do@@ -77,8 +70,8 @@ InterpreterState, InterpreterWriter) pureCompute node input =- let hush :: Show a => Either a b -> b- hush = either (error . show) id+ let hush' :: Show a => Either a b -> b+ hush' = either (panic . show) identity getStatement :: NodeName -> Text -> HashMap (TopLevelType, NodeName) Statement getStatement n i = HM.fromList [ ((TopNode, n), nodeStatement i)@@ -86,6 +79,6 @@ ] nodeStatement :: Text -> Statement- nodeStatement i = V.head $ hush $ parse (puppetParser <* eof) "test" i+ nodeStatement i = V.head $ hush' $ parse (puppetParser <* eof) "test" i in pureEval dummyFacts (getStatement node input) (computeCatalog node)
tests/Spec.hs view
@@ -1,5 +1,7 @@ import Test.Hspec +import Helpers+ import qualified InterpreterSpec import qualified Interpreter.CollectorSpec import qualified Function.ShellquoteSpec@@ -11,6 +13,7 @@ import qualified Function.DeleteAtSpec import qualified Interpreter.IfSpec import qualified Function.SprintfSpec+import qualified Function.LookupSpec import qualified DT.Parser main :: IO ()@@ -29,6 +32,7 @@ describe "The shellquote function" Function.ShellquoteSpec.spec describe "The sprintf function" Function.SprintfSpec.spec describe "The each function" Function.EachSpec.spec+ describe "The lookup function" Function.LookupSpec.spec describe "stdlib functions" $ do describe "The assert_private function" Function.AssertPrivateSpec.spec describe "The join_keys_to_values function" Function.JoinKeysToValuesSpec.spec
tests/hiera.hs view
@@ -1,59 +1,92 @@+{-# LANGUAGE QuasiQuotes #-} module Main where -import Test.Hspec-import System.IO.Temp-import Hiera.Server-import Data.Monoid-import qualified Data.Either.Strict as S-import Test.HUnit-import qualified Data.Vector as V-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import qualified System.Log.Logger as LOG+import Helpers -import Puppet.Interpreter.Types+import qualified Data.Either.Strict as S+import qualified Data.HashMap.Strict as HM+import qualified Data.Vector as Vector+import Hiera.Server+import NeatInterpolation+import qualified System.IO.Temp as IO+import qualified System.Log.Logger as Log+import Test.HUnit main :: IO ()-main = withSystemTempDirectory "hieratest" $ \tmpfp -> do- LOG.updateGlobalLogger hieraLoggerName (LOG.setLevel LOG.ERROR)+main = IO.withSystemTempDirectory "hieratest" $ \tmpfp -> do+ Log.updateGlobalLogger loggerName (Log.setLevel Log.ERROR) let ndname = "node.site.com" vars = HM.fromList [ ("::environment", "production") , ("::fqdn" , ndname) ]- writeFile (tmpfp ++ "/hiera.yaml") $ "---\n:backends:\n - \"yaml\"\n - \"json\"\n:logger: \"console\"\n:hierarchy:\n - \"%{::fqdn}\"\n - \"%{::environment}\"\n - \"global\"\n\n:yaml:\n :datadir: " ++ show tmpfp ++ "\n:json:\n :datadir: " ++ show tmpfp ++ "\n"- writeFile (tmpfp ++ "/global.yaml") "---\nhttp_port: 8080\nntp_servers: ['0.ntp.puppetlabs.com', '1.ntp.puppetlabs.com']\nusers:\n pete:\n uid: 2000\n tom:\n uid: 2001\nglobal: \"glob\""- writeFile (tmpfp ++ "/production.yaml") "---\nhttp_port: 9090\nntp_servers: ['2.ntp.puppetlabs.com', '3.ntp.puppetlabs.com']\ninterp1: '**%{::fqdn}**'\nusers:\n bob:\n uid: 100\n tom:\n uid: 12\n"- writeFile (tmpfp ++ "/" ++ T.unpack ndname ++ ".json") "{\"testnode\":{\"1\":\"**%{::fqdn}**\",\"2\":\"nothing special\"},\"testjson\":\"ok\",\"arraytest\":[\"a\",\"%{::fqdn}\",\"c\"]}\n"+ hiera5_config fp =+ [text|+ version: 5+ hierarchy:+ - name: "Hiera config for unit test"+ data_hash: yaml_data+ datadir: $fp+ paths:+ - "%{::fqdn}.yaml"+ - "%{::environment}.yaml"+ - "global.yaml"+ |]+ hiera3_config fp =+ [text|+ :backends:+ - "yaml"+ - "json"+ :logger: "console"+ :hierarchy:+ - "%{::fqdn}"+ - "%{::environment}"+ - "global"+ :yaml:+ :datadir: $fp+ :json:+ :datadir: $fp+ |]+ writeFile (tmpfp <> "/hiera3.yaml") (hiera3_config (toS tmpfp))+ writeFile (tmpfp <> "/hiera5.yaml") (hiera5_config (toS tmpfp))+ writeFile (tmpfp <> "/global.yaml") "---\nhttp_port: 8080\nntp_servers: ['0.ntp.puppetlabs.com', '1.ntp.puppetlabs.com']\nusers:\n pete:\n uid: 2000\n tom:\n uid: 2001\nglobal: \"glob\""+ writeFile (tmpfp <> "/production.yaml") "---\nhttp_port: 9090\nntp_servers: ['2.ntp.puppetlabs.com', '3.ntp.puppetlabs.com']\ninterp1: '**%{::fqdn}**'\nusers:\n bob:\n uid: 100\n tom:\n uid: 12\n"+ writeFile (tmpfp <> "/" <> toS ndname <> ".json") "{\"testnode\":{\"1\":\"**%{::fqdn}**\",\"2\":\"nothing special\"},\"testjson\":\"ok\",\"arraytest\":[\"a\",\"%{::fqdn}\",\"c\"]}\n" let users = HM.fromList [ ("pete", PHash (HM.singleton "uid" (PNumber 2000))) , ("tom" , PHash (HM.singleton "uid" (PNumber 2001))) ] pusers = HM.fromList [ ("bob", PHash (HM.singleton "uid" (PNumber 100))) , ("tom" , PHash (HM.singleton "uid" (PNumber 12))) ]- Right q <- startHiera (tmpfp ++ "/hiera.yaml")+ q3 <- startHiera (tmpfp ++ "/hiera3.yaml")+ q5 <- startHiera (tmpfp ++ "/hiera5.yaml") let checkOutput v (S.Right x) = x @?= v checkOutput _ (S.Left rr) = assertFailure (show rr) hspec $ do describe "lookup data without a key" $- it "returns an error when called with an empty string" $ q mempty "" QFirst >>= checkOutput Nothing+ it "returns an error when called with an empty string" $ q3 mempty "" QFirst >>= checkOutput Nothing describe "lookup data without a valid key" $ do- it "returns an error when called with a non existent key [QFirst]" $ q mempty "foo" QFirst >>= checkOutput Nothing- it "returns an error when called with a non existent key [QUnique]" $ q mempty "foo" QUnique >>= checkOutput Nothing- it "returns an error when called with a non existent key [QHash]" $ q mempty "foo" QHash >>= checkOutput Nothing+ it "returns an error when called with a non existent key [QFirst]" $ q3 mempty "foo" QFirst >>= checkOutput Nothing+ it "returns an error when called with a non existent key [QUnique]" $ q3 mempty "foo" QUnique >>= checkOutput Nothing+ it "returns an error when called with a non existent key [QHash]" $ q3 mempty "foo" QHash >>= checkOutput Nothing describe "lookup data with no options" $ do- it "can get string data" $ q mempty "http_port" QFirst >>= checkOutput (Just (PNumber 8080))- it "can get arrays" $ q mempty "ntp_servers" QFirst >>= checkOutput (Just (PArray (V.fromList ["0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])))- it "can get hashes" $ q mempty "users" QFirst >>= checkOutput (Just (PHash users))+ it "can get string data" $ q3 mempty "http_port" QFirst >>= checkOutput (Just (PNumber 8080))+ it "can get arrays" $ q3 mempty "ntp_servers" QFirst >>= checkOutput (Just (PArray (Vector.fromList ["0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])))+ it "can get hashes" $ q3 mempty "users" QFirst >>= checkOutput (Just (PHash users)) describe "lookup data with a scope" $ do- it "overrides some values" $ q vars "http_port" QFirst >>= checkOutput (Just (PNumber 9090))- it "doesn't fail on others" $ q vars "global" QFirst >>= checkOutput (Just "glob")+ it "overrides some values" $ q3 vars "http_port" QFirst >>= checkOutput (Just (PNumber 9090))+ it "doesn't fail on others" $ q3 vars "global" QFirst >>= checkOutput (Just "glob") describe "json backend" $- it "resolves in json" $ q vars "testjson" QFirst >>= checkOutput (Just "ok")+ it "resolves in json" $ q3 vars "testjson" QFirst >>= checkOutput (Just "ok") describe "deep interpolation" $ do- it "resolves in strings" $ q vars "interp1" QFirst >>= checkOutput (Just (PString ("**" <> ndname <> "**")))- it "resolves in objects" $ q vars "testnode" QFirst >>= checkOutput (Just (PHash (HM.fromList [("1",PString ("**" <> ndname <> "**")),("2",PString "nothing special")])))- it "resolves in arrays" $ q vars "arraytest" QFirst >>= checkOutput (Just (PArray (V.fromList [PString "a", PString ndname, PString "c"])))+ it "resolves in strings" $ q3 vars "interp1" QFirst >>= checkOutput (Just (PString ("**" <> ndname <> "**")))+ it "resolves in objects" $ q3 vars "testnode" QFirst >>= checkOutput (Just (PHash (HM.fromList [("1",PString ("**" <> ndname <> "**")),("2",PString "nothing special")])))+ it "resolves in arrays" $ q3 vars "arraytest" QFirst >>= checkOutput (Just (PArray (Vector.fromList [PString "a", PString ndname, PString "c"]))) describe "other merge modes" $ do- it "catenates arrays" $ q vars "ntp_servers" QUnique >>= checkOutput (Just (PArray (V.fromList ["2.ntp.puppetlabs.com","3.ntp.puppetlabs.com","0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])))- it "puts single values in arrays" $ q vars "http_port" QUnique >>= checkOutput (Just (PArray (V.fromList [PNumber 9090, PNumber 8080])))- it "merges hashes" $ q vars "users" QHash >>= checkOutput (Just (PHash (pusers <> users)))+ it "catenates arrays" $ q3 vars "ntp_servers" QUnique >>= checkOutput (Just (PArray (Vector.fromList ["2.ntp.puppetlabs.com","3.ntp.puppetlabs.com","0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])))+ it "puts single values in arrays" $ q3 vars "http_port" QUnique >>= checkOutput (Just (PArray (Vector.fromList [PNumber 9090, PNumber 8080])))+ it "merges hashes" $ q3 vars "users" QHash >>= checkOutput (Just (PHash (pusers <> users)))++ -- V5 format+ describe "[V5] lookup data with a scope" $ do+ it "overrides some values" $ q5 vars "http_port" QFirst >>= checkOutput (Just (PNumber 9090))+ it "doesn't fail on others" $ q5 vars "global" QFirst >>= checkOutput (Just "glob")