diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -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 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 Mon, 09 Oct 2017 15:00:00 +0100 + +language-puppet (1.3.12) xenial; urgency=medium + + * Support for Glob >= 0.9 + + -- Simon Marechal 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 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 Mon, 28 Aug 2017 15:00:00 +0100 + +language-puppet (1.3.9) xenial; urgency=medium + + * Moved to megaparsec 6 + + -- Simon Marechal Sun, 30 Jul 2017 15:00:00 +0100 + +language-puppet (1.3.8.1) xenial; urgency=medium + + * Fix haddocks error (#208) + + -- Simon Marechal 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 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 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 Mon, 27 Feb 2017 15:00:00 +0100 + +language-puppet (1.3.5.1) xenial; urgency=medium + + * Version bumps for megaparsec & servant + + -- Simon Marechal Thu, 02 Feb 2017 15:00:00 +0100 + +language-puppet (1.3.5) xenial; urgency=medium + + * Ignored packages are not parsed anymore + + -- Simon Marechal 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 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 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 Mon, 05 Dec 2016 15:00:00 +0100 + +language-puppet (1.3.2.1) xenial; urgency=medium + + * Support for megaparsec 5.1 + + -- Simon Marechal 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 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 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 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 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 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 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 Sun, 31 May 2015 15:00:00 +0100 + +language-puppet (1.1.1.2) xenial; urgency=medium + + + -- Simon Marechal 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 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 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 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 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 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 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 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 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 Mon, 10 Feb 2014 15:00:00 +0100 + +language-puppet (0.12.0) xenial; urgency=medium + + * Builds against GHC 7.8-rc1. + + -- Simon Marechal 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 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 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 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 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 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 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 Sun, 27 Oct 2013 15:00:00 +0100 + +language-puppet (0.10.1) xenial; urgency=medium + + * The TestDB file was never created. + + -- Simon Marechal 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 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 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 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 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 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 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 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 Mon, 19 Nov 2012 15:00:00 +0100 + +language-puppet (0.2.2) xenial; urgency=medium + + * A few statistics are exported. + + -- Simon Marechal 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 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 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 Thu, 20 Sep 2012 15:00:00 +0100 + +language-puppet (0.1.7.2) xenial; urgency=medium + + * Preliminary support for PuppetDB + + -- Simon Marechal 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 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 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 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 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 Mon, 02 Jul 2012 15:00:00 +0100 diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown deleted file mode 100644 --- a/CHANGELOG.markdown +++ /dev/null @@ -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. diff --git a/Erb/Compute.hs b/Erb/Compute.hs deleted file mode 100644 --- a/Erb/Compute.hs +++ /dev/null @@ -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) diff --git a/Erb/Evaluate.hs b/Erb/Evaluate.hs deleted file mode 100644 --- a/Erb/Evaluate.hs +++ /dev/null @@ -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 diff --git a/Erb/Parser.hs b/Erb/Parser.hs deleted file mode 100644 --- a/Erb/Parser.hs +++ /dev/null @@ -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" diff --git a/Erb/Ruby.hs b/Erb/Ruby.hs deleted file mode 100644 --- a/Erb/Ruby.hs +++ /dev/null @@ -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) diff --git a/Facter.hs b/Facter.hs deleted file mode 100644 --- a/Facter.hs +++ /dev/null @@ -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) diff --git a/Hiera/Server.hs b/Hiera/Server.hs deleted file mode 100644 --- a/Hiera/Server.hs +++ /dev/null @@ -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" diff --git a/Puppet/Daemon.hs b/Puppet/Daemon.hs deleted file mode 100644 --- a/Puppet/Daemon.hs +++ /dev/null @@ -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") diff --git a/Puppet/Interpreter.hs b/Puppet/Interpreter.hs deleted file mode 100644 --- a/Puppet/Interpreter.hs +++ /dev/null @@ -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" diff --git a/Puppet/Interpreter/IO.hs b/Puppet/Interpreter/IO.hs deleted file mode 100644 --- a/Puppet/Interpreter/IO.hs +++ /dev/null @@ -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)) diff --git a/Puppet/Interpreter/PrettyPrinter.hs b/Puppet/Interpreter/PrettyPrinter.hs deleted file mode 100644 --- a/Puppet/Interpreter/PrettyPrinter.hs +++ /dev/null @@ -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 diff --git a/Puppet/Interpreter/Pure.hs b/Puppet/Interpreter/Pure.hs deleted file mode 100644 --- a/Puppet/Interpreter/Pure.hs +++ /dev/null @@ -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 diff --git a/Puppet/Interpreter/Resolve.hs b/Puppet/Interpreter/Resolve.hs deleted file mode 100644 --- a/Puppet/Interpreter/Resolve.hs +++ /dev/null @@ -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] diff --git a/Puppet/Interpreter/Resolve/Sprintf.hs b/Puppet/Interpreter/Resolve/Sprintf.hs deleted file mode 100644 --- a/Puppet/Interpreter/Resolve/Sprintf.hs +++ /dev/null @@ -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 diff --git a/Puppet/Interpreter/RubyRandom.hs b/Puppet/Interpreter/RubyRandom.hs deleted file mode 100644 --- a/Puppet/Interpreter/RubyRandom.hs +++ /dev/null @@ -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) diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs deleted file mode 100644 --- a/Puppet/Interpreter/Types.hs +++ /dev/null @@ -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 -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 -data PuppetEdge = PuppetEdge RIdentifier RIdentifier LinkType deriving Show - --- | Wire format --- --- See . -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 () -- ^ - , replaceFacts :: [(NodeName, Facts)] -> ExceptT PrettyError m () -- ^ - , deactivateNode :: NodeName -> ExceptT PrettyError m () -- ^ - , getFacts :: Query FactField -> ExceptT PrettyError m [FactInfo] -- ^ - , getResources :: Query ResourceField -> ExceptT PrettyError m [Resource] -- ^ - , 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" diff --git a/Puppet/Interpreter/Utils.hs b/Puppet/Interpreter/Utils.hs deleted file mode 100644 --- a/Puppet/Interpreter/Utils.hs +++ /dev/null @@ -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 diff --git a/Puppet/Lens.hs b/Puppet/Lens.hs deleted file mode 100644 --- a/Puppet/Lens.hs +++ /dev/null @@ -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 diff --git a/Puppet/Manifests.hs b/Puppet/Manifests.hs deleted file mode 100644 --- a/Puppet/Manifests.hs +++ /dev/null @@ -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))) diff --git a/Puppet/NativeTypes.hs b/Puppet/NativeTypes.hs deleted file mode 100644 --- a/Puppet/NativeTypes.hs +++ /dev/null @@ -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 diff --git a/Puppet/NativeTypes/Concat.hs b/Puppet/NativeTypes/Concat.hs deleted file mode 100644 --- a/Puppet/NativeTypes/Concat.hs +++ /dev/null @@ -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]) - ] diff --git a/Puppet/NativeTypes/Cron.hs b/Puppet/NativeTypes/Cron.hs deleted file mode 100644 --- a/Puppet/NativeTypes/Cron.hs +++ /dev/null @@ -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 diff --git a/Puppet/NativeTypes/Exec.hs b/Puppet/NativeTypes/Exec.hs deleted file mode 100644 --- a/Puppet/NativeTypes/Exec.hs +++ /dev/null @@ -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 diff --git a/Puppet/NativeTypes/File.hs b/Puppet/NativeTypes/File.hs deleted file mode 100644 --- a/Puppet/NativeTypes/File.hs +++ /dev/null @@ -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) diff --git a/Puppet/NativeTypes/Group.hs b/Puppet/NativeTypes/Group.hs deleted file mode 100644 --- a/Puppet/NativeTypes/Group.hs +++ /dev/null @@ -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"]]) - ] diff --git a/Puppet/NativeTypes/Helpers.hs b/Puppet/NativeTypes/Helpers.hs deleted file mode 100644 --- a/Puppet/NativeTypes/Helpers.hs +++ /dev/null @@ -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 diff --git a/Puppet/NativeTypes/Host.hs b/Puppet/NativeTypes/Host.hs deleted file mode 100644 --- a/Puppet/NativeTypes/Host.hs +++ /dev/null @@ -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 diff --git a/Puppet/NativeTypes/Mount.hs b/Puppet/NativeTypes/Mount.hs deleted file mode 100644 --- a/Puppet/NativeTypes/Mount.hs +++ /dev/null @@ -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]) - ] diff --git a/Puppet/NativeTypes/Notify.hs b/Puppet/NativeTypes/Notify.hs deleted file mode 100644 --- a/Puppet/NativeTypes/Notify.hs +++ /dev/null @@ -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"]]) - ] diff --git a/Puppet/NativeTypes/Package.hs b/Puppet/NativeTypes/Package.hs deleted file mode 100644 --- a/Puppet/NativeTypes/Package.hs +++ /dev/null @@ -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 diff --git a/Puppet/NativeTypes/SshSecure.hs b/Puppet/NativeTypes/SshSecure.hs deleted file mode 100644 --- a/Puppet/NativeTypes/SshSecure.hs +++ /dev/null @@ -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" diff --git a/Puppet/NativeTypes/User.hs b/Puppet/NativeTypes/User.hs deleted file mode 100644 --- a/Puppet/NativeTypes/User.hs +++ /dev/null @@ -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]) - ] diff --git a/Puppet/NativeTypes/ZoneRecord.hs b/Puppet/NativeTypes/ZoneRecord.hs deleted file mode 100644 --- a/Puppet/NativeTypes/ZoneRecord.hs +++ /dev/null @@ -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 diff --git a/Puppet/OptionalTests.hs b/Puppet/OptionalTests.hs deleted file mode 100644 --- a/Puppet/OptionalTests.hs +++ /dev/null @@ -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) diff --git a/Puppet/PP.hs b/Puppet/PP.hs deleted file mode 100644 --- a/Puppet/PP.hs +++ /dev/null @@ -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 diff --git a/Puppet/Parser.hs b/Puppet/Parser.hs deleted file mode 100644 --- a/Puppet/Parser.hs +++ /dev/null @@ -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" diff --git a/Puppet/Parser/PrettyPrinter.hs b/Puppet/Parser/PrettyPrinter.hs deleted file mode 100644 --- a/Puppet/Parser/PrettyPrinter.hs +++ /dev/null @@ -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 diff --git a/Puppet/Parser/Types.hs b/Puppet/Parser/Types.hs deleted file mode 100644 --- a/Puppet/Parser/Types.hs +++ /dev/null @@ -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 } @ --- --- . -data ResDefaultDecl = ResDefaultDecl !Text !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show) - --- | Resource override: --- --- @ File['title'] { mode => 755} @ --- --- See . -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 -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) diff --git a/Puppet/Parser/Utils.hs b/Puppet/Parser/Utils.hs deleted file mode 100644 --- a/Puppet/Parser/Utils.hs +++ /dev/null @@ -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" diff --git a/Puppet/Paths.hs b/Puppet/Paths.hs deleted file mode 100644 --- a/Puppet/Paths.hs +++ /dev/null @@ -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" diff --git a/Puppet/Preferences.hs b/Puppet/Preferences.hs deleted file mode 100644 --- a/Puppet/Preferences.hs +++ /dev/null @@ -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) diff --git a/Puppet/Puppetlabs.hs b/Puppet/Puppetlabs.hs deleted file mode 100644 --- a/Puppet/Puppetlabs.hs +++ /dev/null @@ -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) diff --git a/Puppet/Stats.hs b/Puppet/Stats.hs deleted file mode 100644 --- a/Puppet/Stats.hs +++ /dev/null @@ -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) diff --git a/Puppet/Stdlib.hs b/Puppet/Stdlib.hs deleted file mode 100644 --- a/Puppet/Stdlib.hs +++ /dev/null @@ -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) diff --git a/Puppet/Utils.hs b/Puppet/Utils.hs deleted file mode 100644 --- a/Puppet/Utils.hs +++ /dev/null @@ -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) diff --git a/PuppetDB/Common.hs b/PuppetDB/Common.hs deleted file mode 100644 --- a/PuppetDB/Common.hs +++ /dev/null @@ -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 diff --git a/PuppetDB/Dummy.hs b/PuppetDB/Dummy.hs deleted file mode 100644 --- a/PuppetDB/Dummy.hs +++ /dev/null @@ -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 [] ) diff --git a/PuppetDB/Remote.hs b/PuppetDB/Remote.hs deleted file mode 100644 --- a/PuppetDB/Remote.hs +++ /dev/null @@ -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)) diff --git a/PuppetDB/TestDB.hs b/PuppetDB/TestDB.hs deleted file mode 100644 --- a/PuppetDB/TestDB.hs +++ /dev/null @@ -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" diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet -version: 1.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 diff --git a/progs/PuppetResources.hs b/progs/PuppetResources.hs --- a/progs/PuppetResources.hs +++ b/progs/PuppetResources.hs @@ -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 diff --git a/progs/pdbQuery.hs b/progs/pdbQuery.hs --- a/progs/pdbQuery.hs +++ b/progs/pdbQuery.hs @@ -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 diff --git a/progs/yera.hs b/progs/yera.hs --- a/progs/yera.hs +++ b/progs/yera.hs @@ -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) diff --git a/src/Erb/Compute.hs b/src/Erb/Compute.hs new file mode 100644 --- /dev/null +++ b/src/Erb/Compute.hs @@ -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) diff --git a/src/Erb/Evaluate.hs b/src/Erb/Evaluate.hs new file mode 100644 --- /dev/null +++ b/src/Erb/Evaluate.hs @@ -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 diff --git a/src/Erb/Parser.hs b/src/Erb/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Erb/Parser.hs @@ -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" diff --git a/src/Erb/Ruby.hs b/src/Erb/Ruby.hs new file mode 100644 --- /dev/null +++ b/src/Erb/Ruby.hs @@ -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) diff --git a/src/Facter.hs b/src/Facter.hs new file mode 100644 --- /dev/null +++ b/src/Facter.hs @@ -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) diff --git a/src/Hiera/Server.hs b/src/Hiera/Server.hs new file mode 100644 --- /dev/null +++ b/src/Hiera/Server.hs @@ -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" diff --git a/src/Puppet/Daemon.hs b/src/Puppet/Daemon.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Daemon.hs @@ -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") diff --git a/src/Puppet/Interpreter.hs b/src/Puppet/Interpreter.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Interpreter.hs @@ -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" diff --git a/src/Puppet/Interpreter/IO.hs b/src/Puppet/Interpreter/IO.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Interpreter/IO.hs @@ -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 diff --git a/src/Puppet/Interpreter/PrettyPrinter.hs b/src/Puppet/Interpreter/PrettyPrinter.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Interpreter/PrettyPrinter.hs @@ -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 diff --git a/src/Puppet/Interpreter/Pure.hs b/src/Puppet/Interpreter/Pure.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Interpreter/Pure.hs @@ -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 diff --git a/src/Puppet/Interpreter/Resolve.hs b/src/Puppet/Interpreter/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Interpreter/Resolve.hs @@ -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]) diff --git a/src/Puppet/Interpreter/Resolve/Sprintf.hs b/src/Puppet/Interpreter/Resolve/Sprintf.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Interpreter/Resolve/Sprintf.hs @@ -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 diff --git a/src/Puppet/Interpreter/RubyRandom.hs b/src/Puppet/Interpreter/RubyRandom.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Interpreter/RubyRandom.hs @@ -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) diff --git a/src/Puppet/Interpreter/Types.hs b/src/Puppet/Interpreter/Types.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Interpreter/Types.hs @@ -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 +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 +data PuppetEdge = PuppetEdge RIdentifier RIdentifier LinkType deriving Show + +-- | Wire format +-- +-- See . +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 () -- ^ + , replaceFacts :: [(NodeName, Facts)] -> ExceptT PrettyError m () -- ^ + , deactivateNode :: NodeName -> ExceptT PrettyError m () -- ^ + , getFacts :: Query FactField -> ExceptT PrettyError m [FactInfo] -- ^ + , getResources :: Query ResourceField -> ExceptT PrettyError m [Resource] -- ^ + , 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" diff --git a/src/Puppet/Interpreter/Utils.hs b/src/Puppet/Interpreter/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Interpreter/Utils.hs @@ -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 diff --git a/src/Puppet/Lens.hs b/src/Puppet/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Lens.hs @@ -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 diff --git a/src/Puppet/Manifests.hs b/src/Puppet/Manifests.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Manifests.hs @@ -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))) diff --git a/src/Puppet/NativeTypes.hs b/src/Puppet/NativeTypes.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/NativeTypes.hs @@ -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 diff --git a/src/Puppet/NativeTypes/Concat.hs b/src/Puppet/NativeTypes/Concat.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/NativeTypes/Concat.hs @@ -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]) + ] diff --git a/src/Puppet/NativeTypes/Cron.hs b/src/Puppet/NativeTypes/Cron.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/NativeTypes/Cron.hs @@ -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 diff --git a/src/Puppet/NativeTypes/Exec.hs b/src/Puppet/NativeTypes/Exec.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/NativeTypes/Exec.hs @@ -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 diff --git a/src/Puppet/NativeTypes/File.hs b/src/Puppet/NativeTypes/File.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/NativeTypes/File.hs @@ -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) diff --git a/src/Puppet/NativeTypes/Group.hs b/src/Puppet/NativeTypes/Group.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/NativeTypes/Group.hs @@ -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"]]) + ] diff --git a/src/Puppet/NativeTypes/Helpers.hs b/src/Puppet/NativeTypes/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/NativeTypes/Helpers.hs @@ -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 diff --git a/src/Puppet/NativeTypes/Host.hs b/src/Puppet/NativeTypes/Host.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/NativeTypes/Host.hs @@ -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 diff --git a/src/Puppet/NativeTypes/Mount.hs b/src/Puppet/NativeTypes/Mount.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/NativeTypes/Mount.hs @@ -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]) + ] diff --git a/src/Puppet/NativeTypes/Notify.hs b/src/Puppet/NativeTypes/Notify.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/NativeTypes/Notify.hs @@ -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"]]) + ] diff --git a/src/Puppet/NativeTypes/Package.hs b/src/Puppet/NativeTypes/Package.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/NativeTypes/Package.hs @@ -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 diff --git a/src/Puppet/NativeTypes/SshSecure.hs b/src/Puppet/NativeTypes/SshSecure.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/NativeTypes/SshSecure.hs @@ -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" diff --git a/src/Puppet/NativeTypes/User.hs b/src/Puppet/NativeTypes/User.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/NativeTypes/User.hs @@ -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]) + ] diff --git a/src/Puppet/NativeTypes/ZoneRecord.hs b/src/Puppet/NativeTypes/ZoneRecord.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/NativeTypes/ZoneRecord.hs @@ -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 diff --git a/src/Puppet/OptionalTests.hs b/src/Puppet/OptionalTests.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/OptionalTests.hs @@ -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) diff --git a/src/Puppet/PP.hs b/src/Puppet/PP.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/PP.hs @@ -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 diff --git a/src/Puppet/Parser.hs b/src/Puppet/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Parser.hs @@ -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" diff --git a/src/Puppet/Parser/PrettyPrinter.hs b/src/Puppet/Parser/PrettyPrinter.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Parser/PrettyPrinter.hs @@ -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 diff --git a/src/Puppet/Parser/Types.hs b/src/Puppet/Parser/Types.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Parser/Types.hs @@ -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 } @ +-- +-- . +data ResDefaultDecl = ResDefaultDecl !Text !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show) + +-- | Resource override: +-- +-- @ File['title'] { mode => 755} @ +-- +-- See . +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 +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 diff --git a/src/Puppet/Parser/Utils.hs b/src/Puppet/Parser/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Parser/Utils.hs @@ -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" diff --git a/src/Puppet/Paths.hs b/src/Puppet/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Paths.hs @@ -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" diff --git a/src/Puppet/Preferences.hs b/src/Puppet/Preferences.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Preferences.hs @@ -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) diff --git a/src/Puppet/Prelude.hs b/src/Puppet/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Prelude.hs @@ -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" diff --git a/src/Puppet/Puppetlabs.hs b/src/Puppet/Puppetlabs.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Puppetlabs.hs @@ -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) diff --git a/src/Puppet/Stats.hs b/src/Puppet/Stats.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Stats.hs @@ -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) diff --git a/src/Puppet/Stdlib.hs b/src/Puppet/Stdlib.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Stdlib.hs @@ -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) diff --git a/src/PuppetDB/Common.hs b/src/PuppetDB/Common.hs new file mode 100644 --- /dev/null +++ b/src/PuppetDB/Common.hs @@ -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 diff --git a/src/PuppetDB/Dummy.hs b/src/PuppetDB/Dummy.hs new file mode 100644 --- /dev/null +++ b/src/PuppetDB/Dummy.hs @@ -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 [] ) diff --git a/src/PuppetDB/Remote.hs b/src/PuppetDB/Remote.hs new file mode 100644 --- /dev/null +++ b/src/PuppetDB/Remote.hs @@ -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)) diff --git a/src/PuppetDB/TestDB.hs b/src/PuppetDB/TestDB.hs new file mode 100644 --- /dev/null +++ b/src/PuppetDB/TestDB.hs @@ -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" diff --git a/tests/DT/Parser.hs b/tests/DT/Parser.hs --- a/tests/DT/Parser.hs +++ b/tests/DT/Parser.hs @@ -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 diff --git a/tests/Function/AssertPrivateSpec.hs b/tests/Function/AssertPrivateSpec.hs --- a/tests/Function/AssertPrivateSpec.hs +++ b/tests/Function/AssertPrivateSpec.hs @@ -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 diff --git a/tests/Function/DeleteAtSpec.hs b/tests/Function/DeleteAtSpec.hs --- a/tests/Function/DeleteAtSpec.hs +++ b/tests/Function/DeleteAtSpec.hs @@ -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 diff --git a/tests/Function/EachSpec.hs b/tests/Function/EachSpec.hs --- a/tests/Function/EachSpec.hs +++ b/tests/Function/EachSpec.hs @@ -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" - - diff --git a/tests/Function/LookupSpec.hs b/tests/Function/LookupSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Function/LookupSpec.hs @@ -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) diff --git a/tests/Function/MergeSpec.hs b/tests/Function/MergeSpec.hs --- a/tests/Function/MergeSpec.hs +++ b/tests/Function/MergeSpec.hs @@ -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 diff --git a/tests/Function/ShellquoteSpec.hs b/tests/Function/ShellquoteSpec.hs --- a/tests/Function/ShellquoteSpec.hs +++ b/tests/Function/ShellquoteSpec.hs @@ -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"] diff --git a/tests/Function/SizeSpec.hs b/tests/Function/SizeSpec.hs --- a/tests/Function/SizeSpec.hs +++ b/tests/Function/SizeSpec.hs @@ -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 - diff --git a/tests/Function/SprintfSpec.hs b/tests/Function/SprintfSpec.hs --- a/tests/Function/SprintfSpec.hs +++ b/tests/Function/SprintfSpec.hs @@ -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 diff --git a/tests/Helpers.hs b/tests/Helpers.hs --- a/tests/Helpers.hs +++ b/tests/Helpers.hs @@ -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)) diff --git a/tests/Interpreter/CollectorSpec.hs b/tests/Interpreter/CollectorSpec.hs --- a/tests/Interpreter/CollectorSpec.hs +++ b/tests/Interpreter/CollectorSpec.hs @@ -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 diff --git a/tests/Interpreter/IfSpec.hs b/tests/Interpreter/IfSpec.hs --- a/tests/Interpreter/IfSpec.hs +++ b/tests/Interpreter/IfSpec.hs @@ -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 diff --git a/tests/InterpreterSpec.hs b/tests/InterpreterSpec.hs --- a/tests/InterpreterSpec.hs +++ b/tests/InterpreterSpec.hs @@ -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) diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -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 diff --git a/tests/hiera.hs b/tests/hiera.hs --- a/tests/hiera.hs +++ b/tests/hiera.hs @@ -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")