├── .gitignore ├── .travis.yml ├── CHANGELOG ├── HLint.hs ├── LICENSE ├── README.md ├── build ├── equivs ├── getversion.sh ├── mkdeb.sh └── package.sh ├── debian ├── changelog ├── compat ├── control ├── files └── rules ├── default.nix ├── flake.lock ├── flake.nix ├── language-puppet.cabal ├── nix ├── filter.nix ├── hpkgs.nix ├── sources.json └── sources.nix ├── progs ├── PuppetResources.hs ├── pdbQuery.hs └── yera.hs ├── ruby └── hrubyerb.rb ├── shell.nix ├── src ├── Erb.hs ├── Erb │ ├── Parser.hs │ └── Ruby.hs ├── Facter.hs ├── Hiera │ └── Server.hs ├── Puppet │ ├── Interpreter.hs │ ├── Interpreter │ │ ├── Helpers.hs │ │ ├── IO.hs │ │ ├── PrettyPrinter.hs │ │ ├── Resolve.hs │ │ ├── Resolve │ │ │ └── Sprintf.hs │ │ ├── RubyRandom.hs │ │ └── Types.hs │ ├── Language.hs │ ├── Language │ │ ├── Core.hs │ │ ├── NativeTypes.hs │ │ ├── NativeTypes │ │ │ ├── Concat.hs │ │ │ ├── Cron.hs │ │ │ ├── Exec.hs │ │ │ ├── File.hs │ │ │ ├── Group.hs │ │ │ ├── Helpers.hs │ │ │ ├── Host.hs │ │ │ ├── Mount.hs │ │ │ ├── Notify.hs │ │ │ ├── Package.hs │ │ │ ├── SshSecure.hs │ │ │ ├── User.hs │ │ │ └── ZoneRecord.hs │ │ ├── Paths.hs │ │ ├── Resource.hs │ │ ├── Value.hs │ │ └── WireCatalog.hs │ ├── Parser.hs │ ├── Parser │ │ ├── Internal.hs │ │ ├── Lens.hs │ │ ├── PrettyPrinter.hs │ │ └── Types.hs │ ├── Runner.hs │ └── Runner │ │ ├── Daemon.hs │ │ ├── Daemon │ │ ├── FileParser.hs │ │ └── OptionalTests.hs │ │ ├── Erb.hs │ │ ├── Erb │ │ └── Evaluate.hs │ │ ├── Preferences.hs │ │ ├── Puppetlabs.hs │ │ ├── Pure.hs │ │ ├── Stats.hs │ │ └── Stdlib.hs ├── PuppetDB.hs ├── PuppetDB │ ├── Core.hs │ ├── Remote.hs │ └── TestDB.hs ├── XPrelude.hs └── XPrelude │ ├── Extra.hs │ └── PP.hs ├── stack-21.yaml └── tests ├── ErbSpec.hs ├── Helpers.hs ├── HieraSpec.hs ├── Interpreter ├── ClassSpec.hs ├── CollectorSpec.hs ├── EvalSpec.hs ├── EvaluateStatementSpec.hs ├── Function │ ├── AssertPrivateSpec.hs │ ├── DeleteAtSpec.hs │ ├── EachSpec.hs │ ├── JoinKeysToValuesSpec.hs │ ├── LookupSpec.hs │ ├── MergeSpec.hs │ ├── PrefixSpec.hs │ ├── ShellquoteSpec.hs │ ├── SizeSpec.hs │ ├── SprintfSpec.hs │ ├── SuffixSpec.hs │ └── WithSpec.hs └── IfSpec.hs ├── Parser ├── DT.hs ├── ExprSpec.hs ├── LexerSpec.hs └── lexer │ ├── aliastest.pp │ ├── appendArrowAttribute.pp │ ├── argumentdefaults.pp │ ├── arithmeticexpression.pp │ ├── arraytrailingcomma.pp │ ├── assert_types.pp │ ├── case143.pp │ ├── casestatement.pp │ ├── classheirarchy.pp │ ├── classpathtest.pp │ ├── collection.pp │ ├── collection_override.pp │ ├── collection_within_virtual_definitions.pp │ ├── componentmetaparams.pp │ ├── componentrequire.pp │ ├── conversions.pp │ ├── deepclassheirarchy.pp │ ├── defineoverrides.pp │ ├── emptyclass.pp │ ├── emptyexec.pp │ ├── falsevalues.pp │ ├── filecreate.pp │ ├── fqdefinition.pp │ ├── fqparents.pp │ ├── funccomma.pp │ ├── hashindefault.pp │ ├── ifexpression.pp │ ├── ifupdown.pp │ ├── implicititeration.pp │ ├── include.pp │ ├── interpolableindexing.pp │ ├── lambda.pp │ ├── multilinecomments.pp │ ├── multilookup.pp │ ├── multipleclass.pp │ ├── multipleinstances.pp │ ├── multisubs.pp │ ├── namevartest.pp │ ├── nodes.pp │ ├── rawresref.pp │ ├── scopetest.pp │ ├── selectorvalues.pp │ ├── simpledefaults.pp │ ├── simpleselector.pp │ ├── singleary.pp │ ├── singlequote.pp │ ├── singleselector.pp │ ├── subclass_name_duplication.pp │ ├── tagged.pp │ ├── tricky_wikimedia_1.pp │ ├── varassignment.pp │ ├── virtualresources.pp │ └── wget_double_regexp.pp ├── PuppetdbSpec.hs ├── Spec.hs ├── colors ├── defaults.yaml └── hiera ├── common.yaml ├── hiera-v3.yaml ├── hiera-v5.yaml ├── interpolate ├── README.md ├── config │ ├── hiera.yaml │ ├── hiera_iplm_hiera.yaml │ └── hiera_iplm_hiera_bad.yaml └── data │ ├── bad_interpolation.yaml │ ├── complex.yaml │ ├── dotted_keys.yaml │ ├── empty_interpolation.yaml │ ├── frontend.json │ ├── niltest.yaml │ ├── recursive.yaml │ ├── role.json │ └── weird_keys.yaml ├── misc ├── config │ └── hiera.yaml ├── data │ └── common.yaml └── production.yaml ├── node.com.json └── production.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | /Poupette 2 | /dist 3 | /dist-newstyle 4 | /Main.hs 5 | /Main 6 | /puppetresources-*.tar.gz 7 | /puppetresources_* 8 | /Erb/Compute_stub.h 9 | /.cabal-sandbox 10 | /cabal.sandbox.config 11 | TAGS 12 | .stack-work/ 13 | result 14 | *.el 15 | .envrc 16 | *.orig 17 | hackage-doc.sh 18 | stack.yaml 19 | stack.yaml.lock 20 | debian/debhelper-build-stamp 21 | debian/language-puppet.debhelper.log 22 | debian/language-puppet.substvars 23 | debian/language-puppet/ 24 | .direnv/.vscode 25 | .vscode 26 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # runghc make_travis_yml_2.hs 'language-puppet.cabal' 4 | # 5 | # For more information, see https://github.com/haskell-CI/haskell-ci 6 | # 7 | language: c 8 | sudo: false 9 | dist: trusty 10 | git: 11 | submodules: false # whether to recursively clone submodules 12 | 13 | cache: 14 | directories: 15 | - $HOME/.cabal/packages 16 | - $HOME/.cabal/store 17 | 18 | before_cache: 19 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 20 | # remove files that are regenerated by 'cabal update' 21 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* 22 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json 23 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache 24 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar 25 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx 26 | 27 | - rm -rfv $HOME/.cabal/packages/head.hackage 28 | 29 | matrix: 30 | include: 31 | - compiler: "ghc-8.10.4" 32 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 33 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-3.4,ghc-8.10.4, ruby2.0-dev], sources: [hvr-ghc]}} 34 | - compiler: "ghc-8.8.4" 35 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 36 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-3.0,ghc-8.8.4, ruby2.0-dev], sources: [hvr-ghc]}} 37 | - compiler: "ghc-8.6.5" 38 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 39 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.5, ruby2.0-dev], sources: [hvr-ghc]}} 40 | - compiler: "ghc-8.4.4" 41 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 42 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4, ruby2.0-dev], sources: [hvr-ghc]}} 43 | 44 | before_install: 45 | - HC=${CC} 46 | - HCPKG=${HC/ghc/ghc-pkg} 47 | - unset CC 48 | - ROOTDIR=$(pwd) 49 | - mkdir -p $HOME/.local/bin 50 | - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" 51 | - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) 52 | - echo $HCNUMVER 53 | 54 | install: 55 | - cabal --version 56 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 57 | - BENCH=${BENCH---enable-benchmarks} 58 | - TEST=${TEST---enable-tests} 59 | - HADDOCK=${HADDOCK-true} 60 | - UNCONSTRAINED=${UNCONSTRAINED-true} 61 | - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false} 62 | - GHCHEAD=${GHCHEAD-false} 63 | - travis_retry cabal update -v 64 | - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" 65 | - rm -fv cabal.project cabal.project.local 66 | - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' 67 | - "printf 'packages: \".\"\\n' > cabal.project" 68 | - touch cabal.project.local 69 | - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- language-puppet | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi" 70 | - cat cabal.project || true 71 | - cat cabal.project.local || true 72 | - if [ -f "./configure.ac" ]; then 73 | (cd "." && autoreconf -i); 74 | fi 75 | - rm -f cabal.project.freeze 76 | - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all 77 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all 78 | - rm -rf .ghc.environment.* "."/dist 79 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 80 | 81 | # Here starts the actual work to be performed for the package under test; 82 | # any command which exits with a non-zero exit code causes the build to fail. 83 | script: 84 | # test that source-distributions can be generated 85 | - cabal new-sdist all 86 | - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ 87 | - cd ${DISTDIR} || false 88 | - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; 89 | - "printf 'packages: language-puppet-*/*.cabal\\n' > cabal.project" 90 | - touch cabal.project.local 91 | - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- language-puppet | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi" 92 | - cat cabal.project || true 93 | - cat cabal.project.local || true 94 | 95 | # build & run tests, build benchmarks 96 | - cabal new-build -w ${HC} ${TEST} ${BENCH} all 97 | - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi 98 | 99 | # cabal check 100 | - (cd language-puppet-* && cabal check) 101 | 102 | # haddock 103 | - rm -rf ./dist-newstyle 104 | - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi 105 | 106 | # Build without installed constraints for packages in global-db 107 | - if $UNCONSTRAINED; then rm -f cabal.project.local; echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks all; else echo "Not building without installed constraints"; fi 108 | 109 | # REGENDATA ["language-puppet.cabal"] 110 | # EOF 111 | -------------------------------------------------------------------------------- /CHANGELOG: -------------------------------------------------------------------------------- 1 | debian/changelog -------------------------------------------------------------------------------- /HLint.hs: -------------------------------------------------------------------------------- 1 | import "hint" HLint.HLint 2 | 3 | 4 | ignore "Redundant lambda" 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Simon Marechal 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Simon Marechal nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /build/equivs: -------------------------------------------------------------------------------- 1 | Package: puppetresources 2 | Version: VERSION-BUILDNUMBER 3 | Maintainer: Bartavelle 4 | Files: puppetresources /usr/local/bin 5 | pdbquery /usr/local/bin 6 | hrubyerb.rb /usr/local/bin 7 | Architecture: amd64 8 | Description: A program that displays the puppet resources associated to a node given .pp files. 9 | Distribution: stable 10 | 11 | -------------------------------------------------------------------------------- /build/getversion.sh: -------------------------------------------------------------------------------- 1 | grep '^version:' language-puppet.cabal | awk '{print $2}' 2 | -------------------------------------------------------------------------------- /build/mkdeb.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | VERSION=$1 3 | BUILDNUMBER=$2 4 | if [ -z "$VERSION" ] 5 | then 6 | echo "please set version" 7 | exit 4 8 | fi 9 | 10 | if [ -z "$BUILDNUMBER" ] 11 | then 12 | BUILDNUMBER="0" 13 | fi 14 | 15 | cp build/equivs dist/build/puppetresources/ && \ 16 | cp ruby/*.rb dist/build/puppetresources/ && \ 17 | cp dist/build/pdbquery/pdbquery dist/build/puppetresources/ && \ 18 | cd dist/build/puppetresources && \ 19 | sed -i -e "s/Version: .*/Version: $VERSION-$BUILDNUMBER/" equivs && \ 20 | equivs-build -f equivs && \ 21 | mv puppetresources_*{_amd64.deb,_amd64.changes,.dsc,.tar.gz} ../../../ 22 | 23 | -------------------------------------------------------------------------------- /build/package.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | VERSION=`grep '^version:' language-puppet.cabal | awk '{print $2}'` 3 | 4 | if [ -z "$VERSION" ] 5 | then 6 | exit -1 7 | fi 8 | 9 | rm -rf puppetresources-$VERSION && \ 10 | mkdir puppetresources-$VERSION && \ 11 | cabal configure -p && \ 12 | cabal build && \ 13 | cp dist/build/puppetresources/puppetresources dist/build/pdbquery/pdbquery ../language-puppet/ruby/hrubyerb.rb puppetresources-$VERSION && \ 14 | fakeroot tar cfvz puppetresources-$VERSION.tar.gz puppetresources-$VERSION 15 | 16 | rm -rf puppetresources-$VERSION 17 | -------------------------------------------------------------------------------- /debian/compat: -------------------------------------------------------------------------------- 1 | 9 2 | -------------------------------------------------------------------------------- /debian/control: -------------------------------------------------------------------------------- 1 | Source: language-puppet 2 | Section: admin 3 | Maintainer: Simon Marechal 4 | Priority: optional 5 | 6 | Package: language-puppet 7 | Architecture: amd64 8 | Description: Create tests and develop quickly with puppet 9 | -------------------------------------------------------------------------------- /debian/files: -------------------------------------------------------------------------------- 1 | language-puppet_1.3.13_amd64.deb - optional 2 | -------------------------------------------------------------------------------- /debian/rules: -------------------------------------------------------------------------------- 1 | #!/usr/bin/make -f 2 | %: 3 | dh $@ 4 | 5 | override_dh_auto_clean: 6 | override_dh_auto_test: 7 | override_dh_auto_build: 8 | override_dh_auto_install: 9 | rm -rf debian/language-puppet 10 | stack test 11 | stack install 12 | mkdir -p debian/language-puppet/usr/bin 13 | mkdir -p debian/language-puppet/usr/share/language-puppet 14 | cp -v ~/.local/bin/pdbquery debian/language-puppet/usr/bin/ 15 | cp -v ~/.local/bin/puppetresources debian/language-puppet/usr/bin/ 16 | cp -v ~/.local/bin/yera debian/language-puppet/usr/bin/ 17 | cp -v ruby/hrubyerb.rb debian/language-puppet/usr/bin/ 18 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | # You can build this repository by running: 2 | # $ nix-build 3 | { 4 | pkgs ? (import (import ./nix/sources.nix).nixpkgs {}) 5 | , compiler ? "default" 6 | }: 7 | 8 | 9 | let 10 | filter = import ./nix/filter.nix; 11 | hpkgs = import ./nix/hpkgs.nix {inherit pkgs compiler;}; 12 | hrubySrc = pkgs.fetchFromGitHub { 13 | owner = "bartavelle"; 14 | repo = "hruby"; 15 | rev = "v0.3.8.1"; 16 | sha256 = "tXzcqwL9NugpkVd0qxq3B/MB6sKnWDj4uAlC6E2pO7Y="; 17 | }; 18 | haskellPackages = hpkgs.override { 19 | overrides = self: super: rec { 20 | hruby = (self.callCabal2nix 21 | "hruby" 22 | hrubySrc { } 23 | ); 24 | language-puppet = with pkgs.haskell.lib; 25 | disableLibraryProfiling 26 | ( self.callCabal2nix 27 | "language-puppet" 28 | (builtins.path { name = "language-puppet"; inherit filter; path = ./.; } ) 29 | { } 30 | ); 31 | }; 32 | }; 33 | in 34 | 35 | # There is no need to create a static exec or other related artifacts as of now 36 | # This is because the drv is used as a library. 37 | # For now we just return the single drv without wrapping it in a record. 38 | haskellPackages.language-puppet 39 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "hrubySrc": { 4 | "flake": false, 5 | "locked": { 6 | "lastModified": 1616484344, 7 | "narHash": "sha256-tXzcqwL9NugpkVd0qxq3B/MB6sKnWDj4uAlC6E2pO7Y=", 8 | "owner": "bartavelle", 9 | "repo": "hruby", 10 | "rev": "1b1ed097c4fbd0aba8f5a6e30a284d8fcee3a12b", 11 | "type": "github" 12 | }, 13 | "original": { 14 | "owner": "bartavelle", 15 | "ref": "v0.3.8.1", 16 | "repo": "hruby", 17 | "type": "github" 18 | } 19 | }, 20 | "nixpkgs": { 21 | "locked": { 22 | "lastModified": 1651662302, 23 | "narHash": "sha256-utlTjLa1s4ezdQIUvnBtmA9TBYFrPlXpAJnCXEiZFZI=", 24 | "owner": "nixos", 25 | "repo": "nixpkgs", 26 | "rev": "dff5496b12817e3d019983827c4b7ba7beb96580", 27 | "type": "github" 28 | }, 29 | "original": { 30 | "owner": "nixos", 31 | "repo": "nixpkgs", 32 | "rev": "dff5496b12817e3d019983827c4b7ba7beb96580", 33 | "type": "github" 34 | } 35 | }, 36 | "root": { 37 | "inputs": { 38 | "hrubySrc": "hrubySrc", 39 | "nixpkgs": "nixpkgs" 40 | } 41 | } 42 | }, 43 | "root": "root", 44 | "version": 7 45 | } 46 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs = { 3 | nixpkgs.url = "github:nixos/nixpkgs?rev=dff5496b12817e3d019983827c4b7ba7beb96580"; # 2022-05-04 4 | hrubySrc = { 5 | url = "github:bartavelle/hruby?ref=v0.3.8.1"; 6 | flake = false; 7 | }; 8 | }; 9 | outputs = { self, nixpkgs, hrubySrc }: 10 | let 11 | supportedSystems = [ "x86_64-linux" ]; 12 | forAllSystems = nixpkgs.lib.genAttrs supportedSystems; 13 | nixpkgsFor = forAllSystems (system: import nixpkgs { inherit system; overlays = [ self.overlays.default ]; }); 14 | in 15 | { 16 | overlays.default = final: prev: { 17 | haskellPackages = prev.haskellPackages.override { 18 | overrides = self: super: with prev.haskell.lib; { 19 | hruby = dontCheck (dontHaddock (disableLibraryProfiling ( 20 | self.callCabal2nix 21 | "hruby" 22 | hrubySrc 23 | { } 24 | ))); 25 | language-puppet = dontCheck (dontHaddock (disableLibraryProfiling ( 26 | self.callCabal2nix 27 | "language-puppet" 28 | (prev.lib.cleanSource ./.) 29 | { } 30 | ))); 31 | }; 32 | }; 33 | }; 34 | 35 | packages = forAllSystems (system: 36 | with nixpkgsFor.${system}; 37 | { 38 | default = haskell.lib.justStaticExecutables haskellPackages.language-puppet; 39 | } 40 | ); 41 | 42 | devShells = forAllSystems (system: 43 | { 44 | default = with nixpkgsFor.${system}; mkShell { 45 | buildInputs = [ 46 | cabal-install 47 | ruby 48 | pkg-config 49 | ]; 50 | }; 51 | }); 52 | }; 53 | } 54 | -------------------------------------------------------------------------------- /nix/filter.nix: -------------------------------------------------------------------------------- 1 | path: type: 2 | let 3 | baseName = baseNameOf (toString path); 4 | in 5 | type != "symlink" 6 | && baseName != ".stack-work" 7 | && baseName != "dist" 8 | && baseName != "dist-newstyle" 9 | && baseName != "stack.yaml" 10 | && baseName != "stack.yaml.lock" 11 | && baseName != ".git" 12 | && baseName != "default.nix" 13 | && baseName != ".envrc" 14 | && baseName != "README.adoc" 15 | -------------------------------------------------------------------------------- /nix/hpkgs.nix: -------------------------------------------------------------------------------- 1 | { 2 | pkgs 3 | , compiler ? "default" 4 | }: 5 | 6 | if compiler == "default" 7 | then pkgs.haskellPackages 8 | else pkgs.haskell.packages.${compiler} 9 | -------------------------------------------------------------------------------- /nix/sources.json: -------------------------------------------------------------------------------- 1 | { 2 | "niv": { 3 | "branch": "master", 4 | "description": "Easy dependency management for Nix projects", 5 | "homepage": "https://github.com/nmattia/niv", 6 | "owner": "nmattia", 7 | "repo": "niv", 8 | "rev": "v0.2.16", 9 | "sha256": "1fy4dcr05d80diwlxmh42xnjm5ki1pkbky38smvlqjaky2y2f71f", 10 | "type": "tarball", 11 | "url": "https://github.com/nmattia/niv/archive/v0.2.16.tar.gz", 12 | "url_template": "https://github.com///archive/.tar.gz" 13 | }, 14 | "nixpkgs": { 15 | "branch": "release-21.10", 16 | "description": "Nix Packages collection", 17 | "homepage": null, 18 | "owner": "NixOS", 19 | "repo": "nixpkgs", 20 | "rev": "dff5496b128", 21 | "sha256": "14hmk545rhlr03lmagkbh42m63wqdmqbw502fnrqgcxmns657nds", 22 | "type": "tarball", 23 | "url": "https://github.com/NixOS/nixpkgs/archive/dff5496b128.tar.gz", 24 | "url_template": "https://github.com///archive/.tar.gz" 25 | } 26 | } 27 | -------------------------------------------------------------------------------- /progs/yera.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE StrictData #-} 4 | module Main (main) where 5 | 6 | import XPrelude 7 | 8 | import qualified Data.HashMap.Strict as Map 9 | import qualified Data.List as List 10 | import Options.Applicative 11 | 12 | import Hiera.Server 13 | import Puppet.Language (PValue(..)) 14 | 15 | data Config 16 | = Config 17 | { _filepath :: FilePath 18 | , _query :: String 19 | , _queryType :: HieraQueryType 20 | , _variables :: [(Text,Text)] 21 | } 22 | 23 | parseVariable :: String -> Either String (Text, Text) 24 | parseVariable s = 25 | case List.break (=='=') s of 26 | ([], []) -> Left "Empty variable" 27 | ([], _) -> Left "Nothing on the left side of the = symbol" 28 | (_, []) -> Left "Nothing on the right side of the = symbol" 29 | (var, '=':val) -> Right (toS var, toS val) 30 | _ -> Left "???" 31 | 32 | configParser :: Parser Config 33 | configParser = Config <$> strOption (long "config" <> short 'c' <> metavar "CONFIG" <> value "hiera.yaml") 34 | <*> strOption (long "query" <> short 'q' <> metavar "QUERY") 35 | <*> option (maybeReader (readQueryType.toS)) (long "querytype" <> short 't' <> metavar "QUERYTYPE" <> value QFirst <> help "values: first (default), unique, hash") 36 | <*> many (argument (eitherReader parseVariable) (metavar "VARIABLE" <> help "Variables, in the form key=value")) 37 | 38 | configInfo :: ParserInfo Config 39 | configInfo = info (configParser <**> helper) mempty 40 | 41 | main :: IO () 42 | main = do 43 | Config fp query qtype vars <- execParser configInfo 44 | hiera <- startHiera "yera" fp 45 | runExceptT (hiera (PString <$> Map.fromList vars) (toS query) qtype) >>= \case 46 | Left rr -> panic (show rr) 47 | Right Nothing -> die "no match" 48 | Right (Just res) -> print (pretty res) 49 | -------------------------------------------------------------------------------- /ruby/hrubyerb.rb: -------------------------------------------------------------------------------- 1 | require 'erb' 2 | require 'digest/md5' 3 | require 'yaml' 4 | require 'json' 5 | 6 | class Scope 7 | def initialize(context,variables,filename,stt,rdr) 8 | @context = context 9 | @variables = variables 10 | @file = filename 11 | @stt = stt 12 | @rdr = rdr 13 | end 14 | 15 | def [](key) 16 | lookupvar(key) 17 | end 18 | 19 | def vl(name) 20 | if name.start_with?("::") 21 | name = name[2..-1] 22 | end 23 | varlookup(@context,@variables,name) 24 | end 25 | 26 | def lookupvar(name) 27 | if name == "file" 28 | return @file 29 | end 30 | x = vl(name) 31 | if x == :undef 32 | throw("Unknown variable " + name) 33 | else 34 | x 35 | end 36 | end 37 | 38 | def has_variable?(name) 39 | x = vl(name) 40 | if x == :undef 41 | false 42 | else 43 | true 44 | end 45 | end 46 | 47 | def to_hash 48 | vl('~g~e~t_h~a~s~h~') 49 | end 50 | 51 | def function_to_yaml(args) 52 | args.to_yaml 53 | end 54 | 55 | def method_missing(sname,*args,&block) 56 | name = sname.to_s 57 | if name.start_with?('function_') 58 | fname = name[9..1000] 59 | o = callextfunc(fname, args, @stt, @rdr) 60 | case o 61 | when MyError 62 | throw o.getError() 63 | else 64 | return o 65 | end 66 | end 67 | end 68 | end 69 | 70 | class MyError 71 | def initialize(msg) 72 | @msg = msg 73 | end 74 | def getError 75 | @msg 76 | end 77 | end 78 | 79 | class ErbBinding 80 | @options = {} 81 | def initialize(context,variables,stt,rdr,filename='x') 82 | @stt = stt 83 | @rdr = rdr 84 | @scope = Scope.new(context,variables,filename,stt,rdr) 85 | end 86 | def get_binding 87 | return binding() 88 | end 89 | def has_variable?(name) 90 | @scope.has_variable?(name.to_s) 91 | end 92 | def method_missing(sname,*args,&block) 93 | name = sname.to_s 94 | if name.start_with?('function_') 95 | fname = name[9..1000] 96 | o = callextfunc(fname, args, @stt, @rdr) 97 | case o 98 | when MyError 99 | throw o.getError() 100 | else 101 | return o 102 | end 103 | elsif name == 'scope' 104 | @scope 105 | else 106 | @scope.lookupvar(name) 107 | end 108 | end 109 | end 110 | 111 | class Controller 112 | def self.runFromFile(filename,binding) 113 | self.runFromContent(IO.read(filename),binding) 114 | end 115 | def self.runFromContent(content,binding) 116 | nerb = ERB.new(content, nil, "-") 117 | nerb.result(binding.get_binding) 118 | end 119 | end 120 | 121 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | (import ./. {}).env 2 | -------------------------------------------------------------------------------- /src/Erb.hs: -------------------------------------------------------------------------------- 1 | -- | Entry point to general Erb service 2 | -- This module share no dependency with Puppet modules 3 | module Erb 4 | ( module Erb.Ruby, 5 | module Erb.Parser, 6 | ) 7 | where 8 | 9 | import Erb.Parser 10 | import Erb.Ruby 11 | -------------------------------------------------------------------------------- /src/Erb/Ruby.hs: -------------------------------------------------------------------------------- 1 | -- | Base types for the internal ruby parser ("Erb.Parser"). 2 | module Erb.Ruby where 3 | 4 | import XPrelude 5 | 6 | data Value 7 | = Literal !Text 8 | | Interpolable ![Expression] 9 | | Symbol !Text 10 | | Array ![Expression] 11 | deriving (Show, Ord, Eq) 12 | 13 | data Expression 14 | = LookupOperation !Expression !Expression 15 | | PlusOperation !Expression !Expression 16 | | MinusOperation !Expression !Expression 17 | | DivOperation !Expression !Expression 18 | | MultiplyOperation !Expression !Expression 19 | | ShiftLeftOperation !Expression !Expression 20 | | ShiftRightOperation !Expression !Expression 21 | | AndOperation !Expression !Expression 22 | | OrOperation !Expression !Expression 23 | | EqualOperation !Expression !Expression 24 | | DifferentOperation !Expression !Expression 25 | | AboveOperation !Expression !Expression 26 | | AboveEqualOperation !Expression !Expression 27 | | UnderEqualOperation !Expression !Expression 28 | | UnderOperation !Expression !Expression 29 | | RegexpOperation !Expression !Expression 30 | | NotRegexpOperation !Expression !Expression 31 | | NotOperation !Expression 32 | | NegOperation !Expression 33 | | ConditionalValue !Expression !Expression 34 | | Object !Expression 35 | | ScopeObject !Expression 36 | | MethodCall !Expression !Expression 37 | | BlockOperation !Text 38 | | Value !Value 39 | | BTrue 40 | | BFalse 41 | | Error !String 42 | deriving (Show, Ord, Eq) 43 | 44 | instance Pretty Expression where 45 | pretty (LookupOperation a b) = pretty a <> brackets (pretty b) 46 | pretty (PlusOperation a b) = parens (pretty a <+> "+" <+> pretty b) 47 | pretty (MinusOperation a b) = parens (pretty a <+> "-" <+> pretty b) 48 | pretty (DivOperation a b) = parens (pretty a <+> "/" <+> pretty b) 49 | pretty (MultiplyOperation a b) = parens (pretty a <+> "*" <+> pretty b) 50 | pretty op = ppline (show op) 51 | 52 | data RubyStatement 53 | = Puts !Expression 54 | | DropPrevSpace !RubyStatement 55 | | DropPrevSpace' 56 | | DropNextSpace !RubyStatement 57 | deriving (Show, Eq) 58 | -------------------------------------------------------------------------------- /src/Puppet/Interpreter/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | -- | This is an internal module. 4 | module Puppet.Interpreter.IO 5 | ( interpretMonad, 6 | ) 7 | where 8 | 9 | import Control.Monad.Operational 10 | import Control.Monad.State.Strict 11 | import qualified Data.Either.Strict as S 12 | import qualified Data.Text as Text 13 | import Hiera.Server 14 | import Puppet.Interpreter.PrettyPrinter () 15 | import Puppet.Interpreter.Types 16 | import PuppetDB 17 | import XPrelude 18 | 19 | -- | The operational interpreter function 20 | interpretMonad :: 21 | (Monad m) => 22 | InterpreterReader m -> 23 | InterpreterState -> 24 | InterpreterMonad a -> 25 | m (Either PrettyError a, InterpreterState, InterpreterWriter) 26 | interpretMonad r s0 instr = 27 | let (!p, !s1) = runState (viewT instr) s0 28 | in eval r s1 p 29 | 30 | -- The internal (not exposed) eval function 31 | eval :: 32 | (Monad m) => 33 | InterpreterReader m -> 34 | InterpreterState -> 35 | ProgramViewT InterpreterInstr (State InterpreterState) a -> 36 | m (Either PrettyError a, InterpreterState, InterpreterWriter) 37 | eval _ s (Return x) = return (Right x, s, mempty) 38 | eval r s (a :>>= k) = 39 | let runInstr = interpretMonad r s . k -- run one instruction 40 | thpe = interpretMonad r s . throwPosError . getError 41 | pdb = r ^. readerPdbApi 42 | strFail iof errf = 43 | iof >>= \case 44 | Left rr -> thpe (errf (ppstring rr)) 45 | Right x -> runInstr x 46 | canFail iof = 47 | iof >>= \case 48 | S.Left err -> thpe err 49 | S.Right x -> runInstr x 50 | canFailX iof = 51 | runExceptT iof >>= \case 52 | Left err -> thpe err 53 | Right x -> runInstr x 54 | logStuff x c = (_3 %~ (x <>)) <$> c 55 | in case a of 56 | IsStrict -> runInstr (r ^. readerIsStrict) 57 | ExternalFunction "Sensitive" [arg] -> interpretMonad r s (k (PSensitive arg)) 58 | ExternalFunction name args -> 59 | -- #271: namespace is currently ignored when looking up puppetlabs functions 60 | let (nsp, name') = Text.breakOnEnd "::" name 61 | in case r ^. readerExternalFunc . at name' of 62 | Just fn -> interpretMonad r s (fn args >>= k) 63 | Nothing -> thpe (PrettyError ("Unknown function: (" <> ppline nsp <> ")" <> ppline name')) 64 | GetStatement toptype topname -> canFail ((r ^. readerGetStatement) toptype topname) 65 | ComputeTemplate src st -> canFail ((r ^. readerGetTemplate) src st r) 66 | WriterTell t -> logStuff t (runInstr ()) 67 | WriterPass _ -> thpe "WriterPass" 68 | WriterListen _ -> thpe "WriterListen" 69 | PuppetPaths -> runInstr (r ^. readerPuppetPaths) 70 | Facts -> runInstr (r ^. readerFacts) 71 | RebaseFile -> runInstr (r ^. readerRebaseFile) 72 | GetNativeTypes -> runInstr (r ^. readerNativeTypes) 73 | ErrorThrow d -> return (Left d, s, mempty) 74 | GetNodeName -> runInstr (r ^. readerNodename) 75 | HieraQuery scps q t -> 76 | runExceptT (queryHiera (r ^. readerHieraQuery) scps q t) >>= either thpe runInstr 77 | PDBInformation -> pdbInformation pdb >>= runInstr 78 | PDBReplaceCatalog w -> canFailX (replaceCatalog pdb w) 79 | PDBReplaceFacts fcts -> canFailX (replaceFacts pdb fcts) 80 | PDBDeactivateNode nn -> canFailX (deactivateNode pdb nn) 81 | PDBGetFacts q -> canFailX (getPDBFacts pdb q) 82 | PDBGetResources q -> canFailX (getResources pdb q) 83 | PDBGetNodes q -> canFailX (getNodes pdb q) 84 | PDBCommitDB -> canFailX (commitDB pdb) 85 | PDBGetResourcesOfNode nn q -> canFailX (getResourcesOfNode pdb nn q) 86 | GetCurrentCallStack -> (r ^. readerIoMethods . ioGetCurrentCallStack) >>= runInstr 87 | ReadFile fls -> strFail ((r ^. readerIoMethods . ioReadFile) fls) (const $ PrettyError ("No file found in " <> list (map ppline fls))) 88 | TraceEvent e -> (r ^. readerIoMethods . ioTraceEvent) e >>= runInstr 89 | IsIgnoredModule m -> runInstr (r ^. readerIgnoredModules . contains m) 90 | IsExternalModule m -> runInstr (r ^. readerExternalModules . contains m) 91 | -- on error, the program state is RESET and the logged messages are dropped 92 | ErrorCatch atry ahandle -> do 93 | (eres, s', w) <- interpretMonad r s atry 94 | case eres of 95 | Left rr -> interpretMonad r s (ahandle rr >>= k) 96 | Right x -> logStuff w (interpretMonad r s' (k x)) 97 | 98 | -- query all hiera layers 99 | queryHiera :: 100 | (Monad m) => 101 | HieraQueryLayers m -> 102 | Container PValue -> 103 | Text -> 104 | HieraQueryType -> 105 | ExceptT PrettyError m (Maybe PValue) 106 | queryHiera layers scps q t = do 107 | eglobal <- (layers ^. globalLayer) scps q t 108 | eenvironment <- (layers ^. environmentLayer) scps q t 109 | let modname = 110 | case Text.splitOn "::" (Text.dropWhile (== ':') q) of 111 | [] -> Nothing 112 | [_] -> Nothing 113 | (m : _) -> Just m 114 | layer = modname >>= (\n -> layers ^. moduleLayer . at n) 115 | emodle <- maybe (pure Nothing) (\hq -> hq scps q t) layer 116 | case catMaybes [eglobal, eenvironment, emodle] of 117 | [] -> pure Nothing 118 | x : xs -> Just <$> foldM (mergeWith t) x xs 119 | -------------------------------------------------------------------------------- /src/Puppet/Interpreter/PrettyPrinter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | module Puppet.Interpreter.PrettyPrinter () where 5 | 6 | import qualified Data.Aeson as Aeson 7 | import qualified Data.ByteString.Lazy.Char8 as BSL 8 | import Puppet.Interpreter.Types 9 | import PuppetDB 10 | import XPrelude 11 | 12 | instance Pretty TemplateSource where 13 | pretty (Inline s) = pretty (PString s) 14 | pretty (Filename s) = pptext s 15 | 16 | instance Pretty TopLevelType where 17 | pretty TopNode = dullyellow "node" 18 | pretty TopDefine = dullyellow "define" 19 | pretty TopClass = dullyellow "class" 20 | 21 | instance Pretty ResDefaults where 22 | pretty (ResDefaults t _ v p) = capitalizeR t <+> showPPos p <> line <> containerComma v 23 | 24 | instance Pretty ResourceModifier where 25 | pretty (ResourceModifier rt ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString x)) _ p) = "realize" <> parens (pretty (PResourceReference rt x)) <+> showPPos p 26 | pretty _ = "TODO pretty ResourceModifier" 27 | 28 | instance Pretty RSearchExpression where 29 | pretty (REqualitySearch a v) = ppline a <+> "==" <+> pretty v 30 | pretty (RNonEqualitySearch a v) = ppline a <+> "!=" <+> pretty v 31 | pretty (RAndSearch a b) = parens (pretty a) <+> "&&" <+> parens (pretty b) 32 | pretty (ROrSearch a b) = parens (pretty a) <+> "||" <+> parens (pretty b) 33 | pretty RAlwaysTrue = mempty 34 | 35 | pf :: Doc -> [Doc] -> Doc 36 | pf fn args = bold (red fn) <> tupled (map pretty args) 37 | 38 | showQuery :: (ToJSON a) => Query a -> Doc 39 | showQuery = ppstring . BSL.unpack . Aeson.encode 40 | 41 | instance Pretty (InterpreterInstr a) where 42 | pretty PuppetPaths = pf "PuppetPathes" [] 43 | pretty RebaseFile = pf "RebaseFile" [] 44 | pretty IsStrict = pf "IsStrict" [] 45 | pretty GetNativeTypes = pf "GetNativeTypes" [] 46 | pretty (GetStatement tlt nm) = pf "GetStatement" [pretty tlt, ppline nm] 47 | pretty (ComputeTemplate src _) = pf "ComputeTemplate" [pretty src] 48 | pretty (ExternalFunction fn args) = pf (ppline fn) (map pretty args) 49 | pretty GetNodeName = pf "GetNodeName" [] 50 | pretty (HieraQuery _ q _) = pf "HieraQuery" [ppline q] 51 | pretty GetCurrentCallStack = pf "GetCurrentCallStack" [] 52 | pretty (ErrorThrow rr) = pf "ErrorThrow" [getError rr] 53 | pretty (ErrorCatch _ _) = pf "ErrorCatch" [] 54 | pretty (WriterTell t) = pf "WriterTell" (map (pretty . view _2) t) 55 | pretty (WriterPass _) = pf "WriterPass" [] 56 | pretty (WriterListen _) = pf "WriterListen" [] 57 | pretty PDBInformation = pf "PDBInformation" [] 58 | pretty (PDBReplaceCatalog _) = pf "PDBReplaceCatalog" ["..."] 59 | pretty (PDBReplaceFacts _) = pf "PDBReplaceFacts" ["..."] 60 | pretty (PDBDeactivateNode n) = pf "PDBDeactivateNode" [ppline n] 61 | pretty (PDBGetFacts q) = pf "PDBGetFacts" [showQuery q] 62 | pretty (PDBGetResources q) = pf "PDBGetResources" [showQuery q] 63 | pretty (PDBGetNodes q) = pf "PDBGetNodes" [showQuery q] 64 | pretty PDBCommitDB = pf "PDBCommitDB" [] 65 | pretty (PDBGetResourcesOfNode n q) = pf "PDBGetResourcesOfNode" [ppline n, showQuery q] 66 | pretty (ReadFile f) = pf "ReadFile" (map ppline f) 67 | pretty (TraceEvent e) = pf "TraceEvent" [ppstring e] 68 | pretty (IsIgnoredModule m) = pf "IsIgnoredModule" [ppline m] 69 | pretty (IsExternalModule m) = pf "IsExternalModule" [ppline m] 70 | pretty Facts = pf "Facts" [] 71 | 72 | instance Pretty LinkInformation where 73 | pretty (LinkInformation lsrc ldst ltype lpos) = pretty lsrc <+> pretty ltype <+> pretty ldst <+> showPPos lpos 74 | -------------------------------------------------------------------------------- /src/Puppet/Interpreter/Resolve/Sprintf.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 2 | 3 | {-# HLINT ignore "Use <$>" #-} 4 | module Puppet.Interpreter.Resolve.Sprintf 5 | ( sprintf, 6 | ) 7 | where 8 | 9 | import Data.Attoparsec.Text 10 | import qualified Data.Text as Text 11 | import qualified Data.Text.Lazy as TL 12 | import qualified Data.Text.Lazy.Builder as TB 13 | import qualified Data.Text.Lazy.Builder.Int as TB 14 | import qualified Data.Text.Lazy.Builder.Scientific as TB 15 | import Puppet.Interpreter.Helpers 16 | import Puppet.Interpreter.PrettyPrinter () 17 | import Puppet.Interpreter.Types 18 | import XPrelude 19 | 20 | data Flag = Minus | Plus | Space | Zero | Hash 21 | deriving (Show, Eq) 22 | 23 | data FLen = Lhh | Lh | Ll | Lll | LL | Lz | Lj | Lt 24 | deriving (Show, Eq) 25 | 26 | data FType = TPct | Td | Tu | Tf | TF | Te | TE | Tg | TG | Tx | TX | To | Ts | Tc | Tp | Ta | TA 27 | deriving (Show, Eq) 28 | 29 | data PrintfFormat = PrintfFormat 30 | { _pfFlags :: [Flag], 31 | _pfWidth :: Maybe Int, 32 | _pfPrec :: Maybe Int, 33 | _pfLen :: Maybe FLen, 34 | _pfType :: FType 35 | } 36 | deriving (Show, Eq) 37 | 38 | data FormatStringPart 39 | = Raw Text 40 | | Format PrintfFormat 41 | deriving (Show, Eq) 42 | 43 | parseFormat :: Text -> [FormatStringPart] 44 | parseFormat t 45 | | Text.null t = [] 46 | | Text.null nxt = [Raw raw] 47 | | otherwise = Raw raw : rformat 48 | where 49 | (raw, nxt) = Text.break (== '%') t 50 | tryNext = case parseFormat (Text.tail nxt) of 51 | (Raw nt : nxt') -> Raw (Text.cons '%' nt) : nxt' 52 | nxt' -> Raw (Text.singleton '%') : nxt' 53 | rformat = case parse format nxt of 54 | Fail {} -> tryNext 55 | Partial _ -> tryNext 56 | Done remaining f -> Format f : parseFormat remaining 57 | 58 | flag :: Parser Flag 59 | flag = 60 | (Minus <$ char '-') 61 | <|> (Plus <$ char '+') 62 | <|> (Space <$ char ' ') 63 | <|> (Zero <$ char '0') 64 | <|> (Hash <$ char '#') 65 | 66 | lenModifier :: Parser FLen 67 | lenModifier = 68 | (Lhh <$ string "hh") 69 | <|> (Lh <$ char 'h') 70 | <|> (Lll <$ string "ll") 71 | <|> (Ll <$ char 'l') 72 | <|> (LL <$ char 'L') 73 | <|> (Lz <$ char 'z') 74 | <|> (Lj <$ char 'j') 75 | <|> (Lt <$ char 't') 76 | 77 | ftype :: Parser FType 78 | ftype = 79 | (TPct <$ char '%') 80 | <|> (Td <$ char 'd') 81 | <|> (Td <$ char 'i') 82 | <|> (Tu <$ char 'u') 83 | <|> (Tf <$ char 'f') 84 | <|> (TF <$ char 'F') 85 | <|> (Te <$ char 'e') 86 | <|> (TE <$ char 'E') 87 | <|> (Tg <$ char 'g') 88 | <|> (TG <$ char 'G') 89 | <|> (Tx <$ char 'x') 90 | <|> (TX <$ char 'X') 91 | <|> (To <$ char 'o') 92 | <|> (Ts <$ char 's') 93 | <|> (Tc <$ char 'c') 94 | <|> (Ta <$ char 'a') 95 | <|> (Tp <$ char 'p') 96 | <|> (TA <$ char 'A') 97 | 98 | format :: Parser PrintfFormat 99 | format = do 100 | void $ char '%' 101 | flags <- many flag 102 | width <- optional decimal 103 | prec <- optional $ do 104 | void $ char '.' 105 | decimal 106 | len <- optional lenModifier 107 | ft <- ftype 108 | return (PrintfFormat flags width prec len ft) 109 | 110 | sprintf :: Text -> [PValue] -> InterpreterMonad PValue 111 | sprintf str oargs = PString . TL.toStrict . TB.toLazyText . mconcat <$> go (parseFormat str) oargs 112 | where 113 | go (Raw x : xs) args = (TB.fromText x :) <$> go xs args 114 | go (Format f : _) _ | Hash `elem` _pfFlags f = throwPosError "sprintf: the # modifier is not supported" 115 | go (Format f : xs) (arg : args) = do 116 | let numeric = case arg of 117 | PNumber n -> pure n 118 | PString s -> maybe (throwError "sprintf: Don't know how to convert this to a number") return (text2Scientific s) 119 | _ -> throwError "sprintf: Don't know how to convert this to a number" 120 | flags = _pfFlags f 121 | sh mkBuilder n 122 | | has_ Minus = TL.justifyLeft padlen ' ' (sprefix <> content) 123 | | has_ Plus && has_ Zero = sprefix <> TL.justifyRight mpadlen '0' content 124 | | has_ Plus = TL.justifyRight padlen ' ' (sprefix <> content) 125 | | has_ Zero = TL.justifyRight padlen '0' content 126 | | otherwise = TL.justifyRight padlen ' ' content 127 | where 128 | (mpadlen, sprefix) 129 | | Plus `elem` flags && n >= 0 = (padlen - 1, "+") 130 | | Space `elem` flags && n >= 0 = (padlen - 1, " ") 131 | | otherwise = (padlen, mempty) 132 | padlen = maybe 0 fromIntegral (_pfWidth f) 133 | has_ flg = flg `elem` flags 134 | content = TB.toLazyText (mkBuilder n) 135 | baseString <- case _pfType f of 136 | Td -> sh (TB.formatScientificBuilder TB.Fixed (Just 0)) <$> numeric 137 | Tf -> sh (TB.formatScientificBuilder TB.Fixed (_pfPrec f)) <$> numeric 138 | TF -> sh (TB.formatScientificBuilder TB.Fixed (_pfPrec f)) <$> numeric 139 | Tg -> sh (TB.formatScientificBuilder TB.Generic (_pfPrec f)) <$> numeric 140 | TG -> sh (TB.formatScientificBuilder TB.Generic (_pfPrec f)) <$> numeric 141 | Te -> sh (TB.formatScientificBuilder TB.Exponent (_pfPrec f)) <$> numeric 142 | TE -> sh (TB.formatScientificBuilder TB.Exponent (_pfPrec f)) <$> numeric 143 | Tx -> sh (TB.hexadecimal . (truncate :: Scientific -> Integer)) <$> numeric 144 | TX -> sh (TB.hexadecimal . (truncate :: Scientific -> Integer)) <$> numeric 145 | Ts -> return $ case arg of 146 | PString s -> TL.fromStrict s 147 | _ -> TL.pack (show (pretty arg)) 148 | _ -> throwPosError "sprintf: not yet supported" 149 | (TB.fromLazyText baseString :) <$> go xs args 150 | go [] [] = return [] 151 | go _ [] = throwPosError "sprintf: not enough arguments" 152 | go [] _ = [] <$ let msg = "sprintf: too many arguments" in checkStrict msg msg 153 | -------------------------------------------------------------------------------- /src/Puppet/Interpreter/RubyRandom.hs: -------------------------------------------------------------------------------- 1 | module Puppet.Interpreter.RubyRandom 2 | ( randInit, 3 | limitedRand, 4 | ) 5 | where 6 | 7 | import qualified Data.List as List 8 | import qualified Data.Vector.Unboxed as V 9 | import qualified Data.Vector.Unboxed.Mutable as VM 10 | import XPrelude 11 | 12 | data RandState = RandState 13 | { _array :: V.Vector Int, 14 | _left :: Int, 15 | _initf :: Int, 16 | _next :: Int 17 | } 18 | deriving (Show) 19 | 20 | mixbits :: Int -> Int -> Int 21 | mixbits u v = (u .&. 0x80000000) .|. (v .&. 0x7fffffff) 22 | 23 | twist :: Int -> Int -> Int 24 | twist u v = (mixbits u v `shiftR` 1) `xor` ma 25 | where 26 | ma = 27 | if (v .&. 1) == 1 28 | then 0x9908b0df 29 | else 0 30 | 31 | valN :: Int 32 | valN = 624 33 | 34 | valM :: Int 35 | valM = 397 36 | 37 | initGenrand :: Integer -> RandState 38 | initGenrand rseed = RandState (V.fromList (scanl genfunc seed [1 .. (valN - 1)])) 1 1 0 39 | where 40 | seed = fromIntegral rseed .&. 0xffffffff 41 | genfunc :: Int -> Int -> Int 42 | genfunc curval x = (1812433253 * (curval `xor` (curval `shiftR` 30)) + x) .&. 0xffffffff 43 | 44 | nextState :: RandState -> RandState 45 | nextState (RandState array _ initf _) = RandState narray valN 1 0 46 | where 47 | rarray = 48 | if initf == 0 49 | then _array (initGenrand 5489) 50 | else array 51 | narray = V.modify (\v -> twist1 v >> twist2 v >> final v) rarray 52 | twist1 v = mapM_ (twist' valM v) [0 .. (valN - valM - 1)] 53 | twist2 v = mapM_ (twist' (valM - valN) v) [(valN - valM) .. (valN - 2)] 54 | final v = do 55 | a <- VM.read v (valN - 1) 56 | b <- VM.read v 0 57 | pm <- VM.read v (valM - 1) 58 | let res = pm `xor` twist a b 59 | VM.write v (valN - 1) res 60 | twist' idx v n = do 61 | a <- VM.read v n 62 | b <- VM.read v (n + 1) 63 | pm <- VM.read v (idx + n) 64 | let res = pm `xor` twist a b 65 | VM.write v n res 66 | 67 | -- needs refactoring, too tedious for me 68 | initGenrandBigint :: Integer -> RandState 69 | initGenrandBigint seed = 70 | let intarray = unfoldr reduceint seed 71 | reduceint :: Integer -> Maybe (Integer, Integer) 72 | reduceint 0 = Nothing 73 | reduceint x = Just (x .&. 0xffffffff, x `shiftR` 32) 74 | initstate = _array (initGenrand 19650218) 75 | keylist = concat (repeat intarray) 76 | jlist = concat (repeat [0 .. (length intarray - 1)]) 77 | kmax = max (length intarray) valN 78 | state1 = foldl' apply1 initstate (List.zip3 keylist jlist [1 .. kmax]) 79 | apply1 :: V.Vector Int -> (Integer, Int, Int) -> V.Vector Int 80 | apply1 ra (initKey, j, ri) = 81 | let (a, i, sti, stim) = rollover ra ri 82 | nsti = ((sti `xor` ((stim `xor` (stim `shiftR` 30)) * 1664525)) + fromIntegral initKey + j) .&. 0xffffffff 83 | in a V.// [(i, nsti)] 84 | state2 = foldl' apply2 state1 [2 .. valN] 85 | rollover :: V.Vector Int -> Int -> (V.Vector Int, Int, Int, Int) 86 | rollover ra ri = 87 | let (a, i) = 88 | if ri >= valN 89 | then (ra V.// [(0, ra V.! (valN - 1))], 1) 90 | else (ra, ri) 91 | in (a, i, a V.! i, a V.! (i - 1)) 92 | apply2 :: V.Vector Int -> Int -> V.Vector Int 93 | apply2 ra ri = 94 | let (a, i, sti, stim) = rollover ra ri 95 | nsti = ((sti `xor` ((stim `xor` (stim `shiftR` 30)) * 1566083941)) - i) .&. 0xffffffff 96 | in a V.// [(i, nsti)] 97 | in RandState (state2 V.// [(0, 0x80000000)]) 1 1 0 98 | 99 | randInit :: Integer -> RandState 100 | randInit x = 101 | if x <= 0xffffffff 102 | then initGenrand x 103 | else initGenrandBigint x 104 | 105 | limitedRand :: RandState -> Int -> (Int, RandState) 106 | limitedRand s n 107 | | n <= 0 = (0, s) 108 | | otherwise = limitedRand' s 109 | where 110 | masked = foldl' (\x pow -> x .|. (x `shiftR` pow)) (n - 1) [1, 2, 4, 8, 16, 32] 111 | limitedRand' s' = 112 | let (rval, ns) = rbGenrandInt32 s' 113 | val = rval .&. masked 114 | in if n <= val 115 | then limitedRand' ns 116 | else (val, ns) 117 | rbGenrandInt32 :: RandState -> (Int, RandState) 118 | rbGenrandInt32 st = 119 | let rst = 120 | if _left st == 1 121 | then nextState st 122 | else st {_left = _left st - 1} 123 | next = _next rst 124 | cv = _array rst V.! next 125 | nst = rst {_next = next + 1} 126 | y1 = cv `xor` (cv `shiftR` 11) 127 | y2 = y1 `xor` ((y1 `shiftL` 7) .&. 0x9d2c5680) 128 | y3 = y2 `xor` ((y2 `shiftL` 15) .&. 0xefc60000) 129 | y4 = y3 `xor` (y3 `shiftR` 18) 130 | in (y4, nst) 131 | -------------------------------------------------------------------------------- /src/Puppet/Language.hs: -------------------------------------------------------------------------------- 1 | -- | General puppet language specification. 2 | -- 3 | -- This module doesn't depend on any other project modules (except for "XPrelude"). 4 | -- It serves as a common bridge that can be used in "PuppetDB" or "Facter" as well as in 5 | -- "Puppet.Interpreter" or "Puppet.Parser". 6 | module Puppet.Language 7 | ( module Puppet.Language.Core, 8 | module Puppet.Language.NativeTypes, 9 | module Puppet.Language.Paths, 10 | module Puppet.Language.Resource, 11 | module Puppet.Language.Value, 12 | module Puppet.Language.WireCatalog, 13 | ) 14 | where 15 | 16 | import Puppet.Language.Core 17 | import Puppet.Language.NativeTypes 18 | import Puppet.Language.Paths 19 | import Puppet.Language.Resource 20 | import Puppet.Language.Value 21 | import Puppet.Language.WireCatalog 22 | -------------------------------------------------------------------------------- /src/Puppet/Language/Core.hs: -------------------------------------------------------------------------------- 1 | module Puppet.Language.Core where 2 | 3 | import Data.Aeson 4 | import qualified Data.Char as Char 5 | import qualified Data.HashMap.Strict as Map 6 | import qualified Data.Text as Text 7 | import qualified Data.Tuple.Strict as Tuple 8 | import qualified GHC.Show as Show (Show (..)) 9 | import Text.Megaparsec.Pos 10 | import XPrelude 11 | 12 | showPos :: Position -> Doc 13 | showPos = blue . pptext . sourcePosPretty 14 | 15 | -- | showing the first position of a position interval. 16 | showPPos :: PPosition -> Doc 17 | showPPos = showPos . Tuple.fst 18 | 19 | -- | showing the first position of a position interval as string. 20 | showPPos' :: PPosition -> String 21 | showPPos' = sourcePosPretty . Tuple.fst 22 | 23 | -- | Generates an initial position interval based on a filename. 24 | initialPPos :: FilePath -> PPosition 25 | initialPPos x = 26 | let i = initialPos x 27 | in (i :!: i) 28 | 29 | -- | A pair containing the start and end of a given token. 30 | type PPosition = Pair Position Position 31 | 32 | -- | Position in a puppet file. Currently an alias to 'SourcePos'. 33 | type Position = SourcePos 34 | 35 | type NodeName = Text 36 | 37 | type Scope = Text 38 | 39 | data CompRegex = CompRegex !Text !Regex 40 | 41 | instance Show CompRegex where 42 | show (CompRegex t _) = show t 43 | 44 | instance Eq CompRegex where 45 | (CompRegex a _) == (CompRegex b _) = a == b 46 | 47 | instance FromJSON CompRegex where 48 | parseJSON = panic "Can't deserialize a regular expression" 49 | 50 | instance ToJSON CompRegex where 51 | toJSON (CompRegex t _) = toJSON t 52 | 53 | instance Pretty CompRegex where 54 | pretty (CompRegex r _) = pretty '/' <> ppline r <> pretty '/' 55 | 56 | -- | Extremely hacky escaping system for text values. 57 | stringEscape :: Text -> Text 58 | stringEscape = Text.concatMap escapeChar 59 | where 60 | escapeChar '"' = "\\\"" 61 | escapeChar '\n' = "\\n" 62 | escapeChar '\t' = "\\t" 63 | escapeChar '\r' = "\\r" 64 | escapeChar x = Text.singleton x 65 | {-# INLINE stringEscape #-} 66 | 67 | -- | Capitalize resource type and convert into a 'Doc'. 68 | capitalizeR :: Text -> Doc 69 | capitalizeR = dullyellow . ppline . capitalizeRT 70 | 71 | -- | Properly capitalizes resource types. 72 | capitalizeRT :: Text -> Text 73 | capitalizeRT = Text.intercalate "::" . map capitalize' . Text.splitOn "::" 74 | where 75 | capitalize' :: Text -> Text 76 | capitalize' t 77 | | Text.null t = Text.empty 78 | | otherwise = Text.cons (Char.toUpper (Text.head t)) (Text.tail t) 79 | 80 | containerComma'' :: (Pretty a) => [(Doc, a)] -> Doc 81 | containerComma'' x = indent 4 ins 82 | where 83 | ins = mconcat $ intersperse (comma <> line) (fmap showC x) 84 | showC (a, b) = a <+> "=>" <+> pretty b 85 | 86 | containerComma' :: (Pretty a) => [(Doc, a)] -> Doc 87 | containerComma' = braces . containerComma'' 88 | 89 | containerComma :: (Pretty a) => Container a -> Doc 90 | containerComma hm = containerComma' (fmap (\(a, b) -> (fill maxalign (ppline a), b)) hml) 91 | where 92 | hml = Map.toList hm 93 | maxalign = maximum (fmap (Text.length . fst) hml) 94 | 95 | -- Lens 96 | _sourceName :: Lens' Position String 97 | _sourceName = lens sourceName (\s n -> s {sourceName = n}) 98 | 99 | _sourceLine :: Lens' Position Pos 100 | _sourceLine = lens sourceLine (\s l -> s {sourceLine = l}) 101 | 102 | _sourceColumn :: Lens' Position Pos 103 | _sourceColumn = lens sourceColumn (\s c -> s {sourceColumn = c}) 104 | 105 | -- | Generates a 'PPosition' based on a filename and line number. 106 | toPPos :: Text -> Int -> PPosition 107 | toPPos fl ln = 108 | let p = (initialPos (toS fl)) {sourceLine = mkPos $ fromIntegral (max 1 ln)} 109 | in (p :!: p) 110 | -------------------------------------------------------------------------------- /src/Puppet/Language/NativeTypes.hs: -------------------------------------------------------------------------------- 1 | -- | This exposed module holds the /native/ Puppet resource types. 2 | module Puppet.Language.NativeTypes 3 | ( baseNativeTypes, 4 | defaulttype, 5 | NativeTypeMethods, 6 | NativeTypeName, 7 | HasNativeTypeMethods (..), 8 | ) 9 | where 10 | 11 | import qualified Data.HashMap.Strict as HM 12 | import Puppet.Language.NativeTypes.Concat (nativeConcat, nativeConcatFragment) 13 | import Puppet.Language.NativeTypes.Cron (nativeCron) 14 | import Puppet.Language.NativeTypes.Exec (nativeExec) 15 | import Puppet.Language.NativeTypes.File (nativeFile) 16 | import Puppet.Language.NativeTypes.Group (nativeGroup) 17 | import Puppet.Language.NativeTypes.Helpers 18 | ( Container, 19 | HasNativeTypeMethods (..), 20 | NativeTypeMethods, 21 | NativeTypeName, 22 | defaulttype, 23 | faketype, 24 | map, 25 | (++), 26 | ) 27 | import Puppet.Language.NativeTypes.Host (nativeHost) 28 | import Puppet.Language.NativeTypes.Mount (nativeMount) 29 | import Puppet.Language.NativeTypes.Notify (nativeNotify) 30 | import Puppet.Language.NativeTypes.Package (nativePackage) 31 | import Puppet.Language.NativeTypes.SshSecure (nativeSshSecure) 32 | import Puppet.Language.NativeTypes.User (nativeUser) 33 | import Puppet.Language.NativeTypes.ZoneRecord (nativeZoneRecord) 34 | 35 | fakeTypes :: [(NativeTypeName, NativeTypeMethods)] 36 | fakeTypes = [faketype "class"] 37 | 38 | defaultTypes :: [(NativeTypeName, NativeTypeMethods)] 39 | 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"] 40 | 41 | -- | The map of native types. 42 | baseNativeTypes :: Container NativeTypeMethods 43 | baseNativeTypes = 44 | HM.fromList 45 | ( nativeConcat 46 | : nativeConcatFragment 47 | : nativeCron 48 | : nativeExec 49 | : nativeFile 50 | : nativeGroup 51 | : nativeHost 52 | : nativeMount 53 | : nativeNotify 54 | : nativePackage 55 | : nativeSshSecure 56 | : nativeUser 57 | : nativeZoneRecord 58 | : fakeTypes 59 | ++ defaultTypes 60 | ) 61 | -------------------------------------------------------------------------------- /src/Puppet/Language/NativeTypes/Concat.hs: -------------------------------------------------------------------------------- 1 | module Puppet.Language.NativeTypes.Concat 2 | ( nativeConcat, 3 | nativeConcatFragment, 4 | ) 5 | where 6 | 7 | import Puppet.Language.NativeTypes.Helpers 8 | 9 | nativeConcat :: (NativeTypeName, NativeTypeMethods) 10 | nativeConcat = ("concat", nativetypemethods concatparamfunctions pure) 11 | 12 | nativeConcatFragment :: (NativeTypeName, NativeTypeMethods) 13 | nativeConcatFragment = ("concat::fragment", nativetypemethods fragmentparamfunctions validateSourceOrContent) 14 | 15 | concatparamfunctions :: [(Text, [Text -> NativeTypeValidate])] 16 | concatparamfunctions = 17 | [ ("name", [nameval]), 18 | ("ensure", [defaultvalue "present", string, values ["present", "absent"]]), 19 | ("path", [string]), 20 | ("owner", [string]), 21 | ("group", [string]), 22 | ("validate_cmd", [string]), 23 | ("mode", [defaultvalue "0644", string]), 24 | ("warn", [defaultvalue "false", string, values ["false", "true"]]), 25 | ("force", [defaultvalue "false", string, values ["false", "true"]]), 26 | ("backup", [defaultvalue "puppet", string]), 27 | ("replace", [defaultvalue "true", string, values ["false", "true"]]), 28 | ("order", [defaultvalue "alpha", string, values ["alpha", "numeric"]]), 29 | ("ensure_newline", [defaultvalue "false", string, values ["false", "true"]]) 30 | -- deprecated 31 | -- ,("gnu" , [string]) 32 | ] 33 | 34 | fragmentparamfunctions :: [(Text, [Text -> NativeTypeValidate])] 35 | fragmentparamfunctions = 36 | [ ("name", [nameval]), 37 | ("target", [string, mandatory]), 38 | ("content", [string]), 39 | ("source", [string]), 40 | -- order should be an int or a string 41 | ("order", [defaultvalue "10", string]) 42 | ] 43 | -------------------------------------------------------------------------------- /src/Puppet/Language/NativeTypes/Cron.hs: -------------------------------------------------------------------------------- 1 | module Puppet.Language.NativeTypes.Cron (nativeCron) where 2 | 3 | import qualified Data.Text as Text 4 | import Puppet.Language.NativeTypes.Helpers 5 | 6 | nativeCron :: (NativeTypeName, NativeTypeMethods) 7 | nativeCron = ("cron", nativetypemethods parameterfunctions return) 8 | 9 | -- 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. 10 | parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] 11 | parameterfunctions = 12 | [ ("ensure", [defaultvalue "present", string, values ["present", "absent"]]), 13 | ("command", [string, mandatoryIfNotAbsent]), 14 | ("environment", []), 15 | ("hour", [vrange 0 23 []]), 16 | ("minute", [vrange 0 59 []]), 17 | ("month", [vrange 1 12 ["January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December"]]), 18 | ("monthday", [vrange 1 31 []]), 19 | ("name", [nameval]), 20 | ("provider", [defaultvalue "crontab", string, values ["crontab"]]), 21 | ("special", [string]), 22 | ("target", [string]), 23 | ("user", [defaultvalue "root", string]), 24 | ("weekday", [vrange 0 7 ["Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday"]]) 25 | ] 26 | 27 | vrange :: Integer -> Integer -> [Text] -> Text -> NativeTypeValidate 28 | vrange mi ma valuelist param res = case res ^. rattributes . at param of 29 | Just (PArray xs) -> foldM (vrange' mi ma valuelist param) res xs 30 | Just x -> vrange' mi ma valuelist param res x 31 | Nothing -> defaultvalue "*" param res 32 | 33 | vrange' :: Integer -> Integer -> [Text] -> Text -> Resource -> PValue -> Either PrettyError Resource 34 | vrange' mi ma valuelist param res y = case y of 35 | PString "*" -> Right res 36 | PString "absent" -> Right res 37 | PNumber n -> checkint' n mi ma param res 38 | PString x -> 39 | if x `elem` valuelist 40 | then Right res 41 | else parseval x mi ma param res 42 | x -> perror $ "Parameter" <+> paramname param <+> "value should be a valid cron declaration and not" <+> pretty x 43 | 44 | parseval :: Text -> Integer -> Integer -> Text -> NativeTypeValidate 45 | parseval resval mi ma pname res 46 | | "*/" `Text.isPrefixOf` resval = checkint (Text.drop 2 resval) 1 ma pname res 47 | | otherwise = checkint resval mi ma pname res 48 | 49 | checkint :: Text -> Integer -> Integer -> Text -> NativeTypeValidate 50 | checkint st mi ma pname res = 51 | case text2Scientific st of 52 | Just n -> checkint' n mi ma pname res 53 | Nothing -> perror $ "Invalid value type for parameter" <+> paramname pname <+> ": " <+> red (ppline st) 54 | 55 | checkint' :: Scientific -> Integer -> Integer -> Text -> NativeTypeValidate 56 | checkint' i mi ma param res = 57 | if (i >= fromIntegral mi) && (i <= fromIntegral ma) 58 | then Right res 59 | else perror $ "Parameter" <+> paramname param <+> "value is out of bound, should satisfy" <+> pretty mi <+> "<=" <+> pplines (show i) <+> "<=" <+> pretty ma 60 | -------------------------------------------------------------------------------- /src/Puppet/Language/NativeTypes/Exec.hs: -------------------------------------------------------------------------------- 1 | module Puppet.Language.NativeTypes.Exec (nativeExec) where 2 | 3 | import qualified Data.Text as Text 4 | import Puppet.Language.NativeTypes.Helpers 5 | 6 | nativeExec :: (NativeTypeName, NativeTypeMethods) 7 | nativeExec = ("exec", nativetypemethods parameterfunctions fullyQualifiedOrPath) 8 | 9 | -- 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. 10 | parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] 11 | parameterfunctions = 12 | [ ("command", [nameval]), 13 | ("creates", [rarray, strings, fullyQualifieds]), 14 | ("cwd", [string, fullyQualified]), 15 | ("environment", [rarray, strings]), 16 | ("group", [string]), 17 | ("logoutput", [defaultvalue "false", string, values ["true", "false", "on_failure"]]), 18 | ("onlyif", [string]), 19 | ("path", [rarray, strings, fullyQualifieds]), 20 | ("provider", [string, values ["posix", "shell", "windows"]]), 21 | ("refresh", [string]), 22 | ("refreshonly", [defaultvalue "false", string, values ["true", "false"]]), 23 | ("returns", [defaultvalue "0", rarray, integers]), 24 | ("timeout", [defaultvalue "300", integer]), 25 | ("tries", [defaultvalue "1", integer]), 26 | ("try_sleep", [defaultvalue "0", integer]), 27 | ("unless", [string]), 28 | ("user", [string]) 29 | ] 30 | 31 | fullyQualifiedOrPath :: NativeTypeValidate 32 | fullyQualifiedOrPath res = 33 | case (res ^. rattributes . at "path", res ^. rattributes . at "command") of 34 | (Nothing, Just (PString x)) -> 35 | if Text.head x == '/' 36 | then Right res 37 | else Left "Command must be fully qualified if path is not defined" 38 | _ -> Right res 39 | -------------------------------------------------------------------------------- /src/Puppet/Language/NativeTypes/File.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | 3 | module Puppet.Language.NativeTypes.File (nativeFile) where 4 | 5 | import qualified Data.Attoparsec.Text as AT 6 | import qualified Data.Char as Char 7 | import qualified Data.Map.Strict as Map 8 | import qualified Data.Set as Set 9 | import qualified Data.Text as Text 10 | import Puppet.Language.NativeTypes.Helpers 11 | 12 | nativeFile :: (NativeTypeName, NativeTypeMethods) 13 | nativeFile = ("file", nativetypemethods parameterfunctions (validateSourceOrContent >=> validateMode)) 14 | 15 | -- 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. 16 | 17 | parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] 18 | parameterfunctions = 19 | [ ("backup", [string]), 20 | ("checksum", [values ["md5", "md5lite", "mtime", "ctime", "none"]]), 21 | ("content", [string]), 22 | -- ,("ensure" , [defaultvalue "present", string, values ["directory","file","present","absent","link"]]) 23 | ("ensure", [defaultvalue "present", string]), 24 | ("force", [string, values ["true", "false"]]), 25 | ("group", [defaultvalue "root", string]), 26 | ("ignore", [strings]), 27 | ("links", [string]), 28 | ("mode", [defaultvalue "0644", string]), 29 | ("owner", [string]), 30 | ("path", [nameval, fullyQualified, noTrailingSlash']), 31 | ("provider", [values ["posix", "windows"]]), 32 | ("purge", [string, values ["true", "false"]]), 33 | ("recurse", [string, values ["inf", "true", "false", "remote"]]), 34 | ("recurselimit", [integer]), 35 | ("replace", [string, values ["true", "false", "yes", "no"]]), 36 | ("show_diff", [string, values ["true", "false"]]), 37 | ("sourceselect", [values ["first", "all"]]), 38 | ("seltype", [string]), 39 | ("selrange", [string]), 40 | ("selinux_ignore_defaults", [string, values ["true", "false"]]), 41 | ("selrole", [string]), 42 | ("target", [string]), 43 | ("source", [rarray, strings, flip runarray checkSource]), 44 | ("seluser", [string]), 45 | ("validate_cmd", [string]), 46 | ("validate_replacement", [string]) 47 | ] 48 | 49 | noTrailingSlash' :: Text -> NativeTypeValidate 50 | noTrailingSlash' param res 51 | | res ^? rattributes . ix "ensure" == Just "directory" = Right res 52 | | otherwise = noTrailingSlash param res 53 | 54 | validateMode :: NativeTypeValidate 55 | validateMode res = do 56 | modestr <- case res ^. rattributes . at "mode" of 57 | Just (PString s) -> return s 58 | Just x -> throwError $ PrettyError ("Invalide mode type, should be a string " <+> pretty x) 59 | Nothing -> throwError "Could not find mode!" 60 | (numeric modestr <|> except (ugo modestr)) & runExcept & _Right %~ ($ res) 61 | 62 | numeric :: Text -> Except PrettyError (Resource -> Resource) 63 | numeric modestr = do 64 | when ((Text.length modestr /= 3) && (Text.length modestr /= 4)) (throwError "Invalid mode size") 65 | unless (Text.all Char.isDigit modestr) (throwError "The mode should only be made of digits") 66 | return $ 67 | if Text.length modestr == 3 68 | then rattributes . at "mode" ?~ PString (Text.cons '0' modestr) 69 | else identity 70 | 71 | checkSource :: Text -> PValue -> NativeTypeValidate 72 | checkSource _ (PString x) res 73 | | any (`Text.isPrefixOf` x) ["puppet://", "file://", "/", "http://", "https://"] = Right res 74 | | otherwise = throwError "A source should start with either puppet://, http://, https:// or file:// or an absolute path" 75 | checkSource _ x _ = throwError $ PrettyError ("Expected a string, not" <+> pretty x) 76 | 77 | data PermParts = Special | User | Group | Other 78 | deriving (Eq, Ord) 79 | 80 | data PermSet = R | W | X 81 | deriving (Ord, Eq) 82 | 83 | ugo :: Text -> Either PrettyError (Resource -> Resource) 84 | ugo t = 85 | AT.parseOnly (modestring <* AT.endOfInput) t 86 | & _Left %~ (\rr -> PrettyError $ "Could not parse the mode string: " <> ppstring rr) 87 | & _Right %~ (\s -> rattributes . at "mode" ?~ PString (mkmode Special s <> mkmode User s <> mkmode Group s <> mkmode Other s)) 88 | 89 | mkmode :: PermParts -> Map PermParts (Set PermSet) -> Text 90 | mkmode p m = 91 | let s = m ^. at p . non mempty 92 | in Text.pack $ 93 | show $ 94 | fromEnum (Set.member R s) * 4 95 | + fromEnum (Set.member W s) * 2 96 | + fromEnum (Set.member X s) 97 | 98 | modestring :: AT.Parser (Map PermParts (Set.Set PermSet)) 99 | modestring = Map.fromList . mconcat <$> (modepart `AT.sepBy` AT.char ',') 100 | 101 | -- TODO suid, sticky and other funky things are not yet supported 102 | modepart :: AT.Parser [(PermParts, Set PermSet)] 103 | modepart = do 104 | let permpart = 105 | (AT.char 'u' $> [User]) 106 | <|> (AT.char 'g' $> [Group]) 107 | <|> (AT.char 'o' $> [Other]) 108 | <|> (AT.char 'a' $> [User, Group, Other]) 109 | permission = 110 | (AT.char 'r' $> R) 111 | <|> (AT.char 'w' $> W) 112 | <|> (AT.char 'x' $> X) 113 | pp <- mconcat <$> some permpart 114 | void $ AT.char '=' 115 | pr <- Set.fromList <$> some permission 116 | return (map (,pr) pp) 117 | -------------------------------------------------------------------------------- /src/Puppet/Language/NativeTypes/Group.hs: -------------------------------------------------------------------------------- 1 | module Puppet.Language.NativeTypes.Group (nativeGroup) where 2 | 3 | import Puppet.Language.NativeTypes.Helpers 4 | 5 | nativeGroup :: (NativeTypeName, NativeTypeMethods) 6 | nativeGroup = ("group", nativetypemethods parameterfunctions return) 7 | 8 | -- 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. 9 | parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] 10 | parameterfunctions = 11 | [ ("allowdupe", [string, defaultvalue "false", values ["true", "false"]]), 12 | ("attribute_membership", [string, defaultvalue "minimum", values ["inclusive", "minimum"]]), 13 | ("attributes", [strings]), 14 | ("auth_membership", [defaultvalue "minimum", string, values ["inclusive", "minimum"]]), 15 | ("ensure", [defaultvalue "present", string, values ["present", "absent"]]), 16 | ("gid", [integer]), 17 | ("ia_load_module", [string]), 18 | ("members", [strings]), 19 | ("name", [nameval]), 20 | ("provider", [string, values ["aix", "directoryservice", "groupadd", "ldap", "pw", "window_adsi"]]), 21 | ("system", [string, defaultvalue "false", values ["true", "false"]]) 22 | ] 23 | -------------------------------------------------------------------------------- /src/Puppet/Language/NativeTypes/Host.hs: -------------------------------------------------------------------------------- 1 | module Puppet.Language.NativeTypes.Host (nativeHost) where 2 | 3 | import qualified Data.Char as Char 4 | import qualified Data.Text as Text 5 | import Puppet.Language.NativeTypes.Helpers 6 | 7 | nativeHost :: (NativeTypeName, NativeTypeMethods) 8 | nativeHost = ("host", nativetypemethods parameterfunctions return) 9 | 10 | -- 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. 11 | parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] 12 | parameterfunctions = 13 | [ ("comment", [string, values ["true", "false"]]), 14 | ("ensure", [defaultvalue "present", string, values ["present", "absent"]]), 15 | ("host_aliases", [rarray, strings, checkhostname]), 16 | ("ip", [string, mandatory, ipaddr]), 17 | ("name", [nameval, checkhostname]), 18 | ("provider", [string, values ["parsed"]]), 19 | ("target", [string, fullyQualified]) 20 | ] 21 | 22 | checkhostname :: Text -> NativeTypeValidate 23 | checkhostname param res = case res ^. rattributes . at param of 24 | Nothing -> Right res 25 | Just (PArray xs) -> foldM (checkhostname' param) res xs 26 | Just x@(PString _) -> checkhostname' param res x 27 | Just x -> perror $ paramname param <+> "should be an array or a single string, not" <+> pretty x 28 | 29 | checkhostname' :: Text -> Resource -> PValue -> Either PrettyError Resource 30 | checkhostname' prm _ (PString "") = perror $ "Empty hostname for parameter" <+> paramname prm 31 | checkhostname' prm res (PString x) = checkhostname'' prm res x 32 | checkhostname' prm _ x = perror $ "Parameter " <+> paramname prm <+> "should be an string or an array of strings, but this was found :" <+> pretty x 33 | 34 | checkhostname'' :: Text -> Resource -> Text -> Either PrettyError Resource 35 | checkhostname'' prm _ "" = perror $ "Empty hostname part in parameter" <+> paramname prm 36 | checkhostname'' prm res prt = 37 | let (cur, nxt) = Text.break (== '.') prt 38 | nextfunc = 39 | if Text.null nxt 40 | then Right res 41 | else checkhostname'' prm res (Text.tail nxt) 42 | in if Text.null cur || (Text.head cur == '-') || not (Text.all (\x -> Char.isAlphaNum x || (x == '-')) cur) 43 | then perror $ "Invalid hostname part for parameter" <+> paramname prm 44 | else nextfunc 45 | -------------------------------------------------------------------------------- /src/Puppet/Language/NativeTypes/Mount.hs: -------------------------------------------------------------------------------- 1 | module Puppet.Language.NativeTypes.Mount (nativeMount) where 2 | 3 | import Puppet.Language.NativeTypes.Helpers 4 | 5 | nativeMount :: (NativeTypeName, NativeTypeMethods) 6 | nativeMount = ("mount", nativetypemethods parameterfunctions return) 7 | 8 | parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] 9 | parameterfunctions = 10 | [ ("atboot", [string, values ["true", "false"]]), 11 | ("blockdevice", [string]), 12 | ("device", [string, mandatoryIfNotAbsent]), 13 | ("dump", [integer, inrange 0 2]), 14 | ("ensure", [defaultvalue "present", string, values ["present", "absent", "mounted"]]), 15 | ("fstype", [string, mandatoryIfNotAbsent]), 16 | ("name", [nameval]), 17 | ("options", [string]), 18 | ("pass", [defaultvalue "0", integer]), 19 | ("provider", [defaultvalue "parsed", string, values ["parsed"]]), 20 | ("remounts", [string, values ["true", "false"]]), 21 | ("target", [string, fullyQualified]) 22 | ] 23 | -------------------------------------------------------------------------------- /src/Puppet/Language/NativeTypes/Notify.hs: -------------------------------------------------------------------------------- 1 | module Puppet.Language.NativeTypes.Notify (nativeNotify) where 2 | 3 | import Puppet.Language.NativeTypes.Helpers 4 | 5 | nativeNotify :: (NativeTypeName, NativeTypeMethods) 6 | nativeNotify = ("notify", nativetypemethods parameterfunctions return) 7 | 8 | parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] 9 | parameterfunctions = 10 | [ ("message", []), 11 | ("withpath", [string, defaultvalue "false", values ["true", "false"]]) 12 | ] 13 | -------------------------------------------------------------------------------- /src/Puppet/Language/NativeTypes/Package.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module Puppet.Language.NativeTypes.Package 4 | ( nativePackage, 5 | ) 6 | where 7 | 8 | import qualified Data.HashMap.Strict as HM 9 | import qualified Data.HashSet as Set 10 | import Puppet.Language.NativeTypes.Helpers 11 | 12 | nativePackage :: (NativeTypeName, NativeTypeMethods) 13 | nativePackage = ("package", nativetypemethods parameterfunctions (getFeature >=> checkFeatures)) 14 | 15 | -- Features are abilities that some providers may not support. 16 | data PackagingFeatures 17 | = Holdable 18 | | InstallOptions 19 | | Installable 20 | | Purgeable 21 | | UninstallOptions 22 | | Uninstallable 23 | | Upgradeable 24 | | Versionable 25 | deriving (Show, Eq, Generic) 26 | 27 | instance Pretty PackagingFeatures where 28 | pretty = ppline . show 29 | 30 | instance Hashable PackagingFeatures 31 | 32 | isFeatureSupported :: HashMap Text (HashSet PackagingFeatures) 33 | isFeatureSupported = 34 | HM.fromList 35 | [ ("aix", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]), 36 | ("appdmg", Set.fromList [Installable]), 37 | ("apple", Set.fromList [Installable]), 38 | ("apt", Set.fromList [Holdable, InstallOptions, Installable, Purgeable, Uninstallable, Upgradeable, Versionable]), 39 | ("aptitude", Set.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable]), 40 | ("aptrpm", Set.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable]), 41 | ("blastwave", Set.fromList [Installable, Uninstallable, Upgradeable]), 42 | ("dpkg", Set.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable]), 43 | ("fink", Set.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable]), 44 | ("freebsd", Set.fromList [Installable, Uninstallable]), 45 | ("gem", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]), 46 | ("hpux", Set.fromList [Installable, Uninstallable]), 47 | ("macports", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]), 48 | ("msi", Set.fromList [InstallOptions, Installable, UninstallOptions, Uninstallable]), 49 | ("nim", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]), 50 | ("openbsd", Set.fromList [Installable, Uninstallable, Versionable]), 51 | ("pacman", Set.fromList [Installable, Uninstallable, Upgradeable]), 52 | ("pip", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]), 53 | ("pkg", Set.fromList [Holdable, Installable, Uninstallable, Upgradeable, Versionable]), 54 | ("pkgdmg", Set.fromList [Installable]), 55 | ("pkgin", Set.fromList [Installable, Uninstallable]), 56 | ("pkgutil", Set.fromList [Installable, Uninstallable, Upgradeable]), 57 | ("portage", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]), 58 | ("ports", Set.fromList [Installable, Uninstallable, Upgradeable]), 59 | ("portupgrade", Set.fromList [Installable, Uninstallable, Upgradeable]), 60 | ("rpm", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]), 61 | ("rug", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]), 62 | ("sun", Set.fromList [InstallOptions, Installable, Uninstallable, Upgradeable]), 63 | ("sunfreeware", Set.fromList [Installable, Uninstallable, Upgradeable]), 64 | ("up2date", Set.fromList [Installable, Uninstallable, Upgradeable]), 65 | ("urpmi", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]), 66 | ("windows", Set.fromList [InstallOptions, Installable, UninstallOptions, Uninstallable]), 67 | ("yum", Set.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable]), 68 | ("zypper", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]) 69 | ] 70 | 71 | parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] 72 | parameterfunctions = 73 | [ ("adminfile", [string, fullyQualified]), 74 | ("allowcdrom", [string, values ["true", "false"]]), 75 | ("configfiles", [string, values ["keep", "replace"]]), 76 | -- ,("ensure" , [defaultvalue "present", string, values ["present","absent","latest","held","purged","installed"]]) 77 | ("ensure", [defaultvalue "present", string]), 78 | ("flavor", []), 79 | ("install_options", [rarray]), 80 | ("name", [nameval]), 81 | ("provider", [defaultvalue "apt", string]), 82 | ("responsefile", [string, fullyQualified]), 83 | ("source", [string]), 84 | ("uninstall_options", [rarray]) 85 | ] 86 | 87 | getFeature :: Resource -> Either PrettyError (HashSet PackagingFeatures, Resource) 88 | getFeature res = 89 | case res ^. rattributes . at "provider" of 90 | Just (PString x) -> 91 | case HM.lookup x isFeatureSupported of 92 | Just s -> Right (s, res) 93 | Nothing -> Left $ PrettyError ("Do not know provider" <+> ppline x) 94 | _ -> Left "Can't happen at Puppet.NativeTypes.Package" 95 | 96 | checkFeatures :: (HashSet PackagingFeatures, Resource) -> Either PrettyError Resource 97 | checkFeatures = 98 | checkAdminFile 99 | >=> checkEnsure 100 | >=> checkParam "install_options" InstallOptions 101 | >=> checkParam "uninstall_options" UninstallOptions 102 | >=> decap 103 | where 104 | checkFeature :: HashSet PackagingFeatures -> Resource -> PackagingFeatures -> Either PrettyError (HashSet PackagingFeatures, Resource) 105 | checkFeature s r f = 106 | if Set.member f s 107 | then Right (s, r) 108 | else Left $ PrettyError ("Feature" <+> pretty f <+> "is required for the current configuration") 109 | checkParam :: Text -> PackagingFeatures -> (HashSet PackagingFeatures, Resource) -> Either PrettyError (HashSet PackagingFeatures, Resource) 110 | checkParam pn f (s, r) = 111 | if has (ix pn) (r ^. rattributes) 112 | then checkFeature s r f 113 | else Right (s, r) 114 | checkAdminFile :: (HashSet PackagingFeatures, Resource) -> Either PrettyError (HashSet PackagingFeatures, Resource) 115 | checkAdminFile = Right -- TODO, check that it only works for aix 116 | checkEnsure :: (HashSet PackagingFeatures, Resource) -> Either PrettyError (HashSet PackagingFeatures, Resource) 117 | checkEnsure (s, res) = case res ^. rattributes . at "ensure" of 118 | Just (PString "latest") -> checkFeature s res Installable 119 | Just (PString "purged") -> checkFeature s res Purgeable 120 | Just (PString "absent") -> checkFeature s res Uninstallable 121 | Just (PString "installed") -> checkFeature s res Installable 122 | Just (PString "present") -> checkFeature s res Installable 123 | Just (PString "held") -> checkFeature s res Installable >> checkFeature s res Holdable 124 | _ -> checkFeature s res Versionable 125 | decap :: (HashSet PackagingFeatures, Resource) -> Either PrettyError Resource 126 | decap = Right . snd 127 | -------------------------------------------------------------------------------- /src/Puppet/Language/NativeTypes/SshSecure.hs: -------------------------------------------------------------------------------- 1 | module Puppet.Language.NativeTypes.SshSecure 2 | ( nativeSshSecure, 3 | ) 4 | where 5 | 6 | import Puppet.Language.NativeTypes.Helpers 7 | 8 | nativeSshSecure :: (NativeTypeName, NativeTypeMethods) 9 | nativeSshSecure = ("ssh_authorized_key_secure", nativetypemethods parameterfunctions (userOrTarget >=> keyIfPresent)) 10 | 11 | -- 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. 12 | parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] 13 | parameterfunctions = 14 | [ ("type", [string, defaultvalue "ssh-rsa", values ["rsa", "dsa", "ssh-rsa", "ssh-dss"]]), 15 | ("key", [string]), 16 | ("user", [string]), 17 | ("ensure", [defaultvalue "present", string, values ["present", "absent", "role"]]), 18 | ("target", [string]), 19 | ("options", [rarray, strings]) 20 | ] 21 | 22 | userOrTarget :: NativeTypeValidate 23 | userOrTarget res = 24 | case (res ^. rattributes & has (ix "user"), res ^. rattributes & has (ix "target")) of 25 | (False, False) -> Left "Parameters user or target are mandatory" 26 | _ -> Right res 27 | 28 | keyIfPresent :: NativeTypeValidate 29 | keyIfPresent res = 30 | case (res ^. rattributes . at "key", res ^. rattributes . at "ensure") of 31 | (Just _, Just "present") -> Right res 32 | (_, Just "absent") -> Right res 33 | _ -> Left "Parameter key is mandatory when the resource is present" 34 | -------------------------------------------------------------------------------- /src/Puppet/Language/NativeTypes/User.hs: -------------------------------------------------------------------------------- 1 | module Puppet.Language.NativeTypes.User (nativeUser) where 2 | 3 | import Puppet.Language.NativeTypes.Helpers 4 | 5 | nativeUser :: (NativeTypeName, NativeTypeMethods) 6 | nativeUser = ("user", nativetypemethods parameterfunctions return) 7 | 8 | -- Autorequires: If Puppet is managing the user or user that owns a file, the file resource will autorequire them. 9 | -- If Puppet is managing any parent directories of a file, the file resource will autorequire them. 10 | parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] 11 | parameterfunctions = 12 | [ ("allowdupe", [string, defaultvalue "false", values ["true", "false"]]), 13 | ("attribute_membership", [string, defaultvalue "minimum", values ["inclusive", "minimum"]]), 14 | ("attributes", [rarray, strings]), 15 | ("auth_membership", [defaultvalue "minimum", string, values ["inclusive", "minimum"]]), 16 | ("auths", [rarray, strings]), 17 | ("comment", [string]), 18 | ("ensure", [defaultvalue "present", string, values ["present", "absent", "role"]]), 19 | ("expiry", [string]), 20 | ("gid", [string]), 21 | ("groups", [rarray, strings]), 22 | ("home", [string, fullyQualified, noTrailingSlash]), 23 | ("ia_load_module", [string]), 24 | ("iterations", [integer]), 25 | ("key_membership", [string, defaultvalue "minimum", values ["inclusive", "minimum"]]), 26 | ("keys", []), 27 | ("managehome", [string, defaultvalue "false", values ["true", "false"]]), 28 | ("membership", [string, defaultvalue "minimum", values ["inclusive", "minimum"]]), 29 | ("name", [nameval]), 30 | ("password", [string]), 31 | ("password_max_age", [integer]), 32 | ("password_min_age", [integer]), 33 | ("profile_membership", [string, defaultvalue "minimum", values ["inclusive", "minimum"]]), 34 | ("profiles", [rarray, strings]), 35 | ("project", [string]), 36 | ("provider", [string, values ["aix", "directoryservice", "hpuxuseradd", "useradd", "ldap", "pw", "user_role_add", "window_adsi"]]), 37 | ("role_membership", [string, defaultvalue "minimum", values ["inclusive", "minimum"]]), 38 | ("roles", [rarray, strings]), 39 | ("salt", [string]), 40 | ("shell", [string, fullyQualified, noTrailingSlash]), 41 | ("system", [string, defaultvalue "false", values ["true", "false"]]), 42 | ("uid", [integer]) 43 | ] 44 | -------------------------------------------------------------------------------- /src/Puppet/Language/NativeTypes/ZoneRecord.hs: -------------------------------------------------------------------------------- 1 | module Puppet.Language.NativeTypes.ZoneRecord (nativeZoneRecord) where 2 | 3 | import Puppet.Language.NativeTypes.Helpers 4 | 5 | nativeZoneRecord :: (NativeTypeName, NativeTypeMethods) 6 | nativeZoneRecord = ("zone_record", nativetypemethods parameterfunctions validateMandatories) 7 | 8 | -- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. 9 | -- If Puppet is managing any parent directories of a file, the file resource will autorequire them. 10 | parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] 11 | parameterfunctions = 12 | [ ("name", [nameval]), 13 | ("owner", [string]), 14 | ("dest", [string]), 15 | ("ensure", [defaultvalue "present", string, values ["present", "absent"]]), 16 | ("rtype", [string, defaultvalue "A", values ["SOA", "A", "AAAA", "MX", "NS", "CNAME", "PTR", "SRV"]]), 17 | ("rclass", [defaultvalue "IN", string]), 18 | ("ttl", [defaultvalue "2d", string]), 19 | ("target", [string, mandatory]), 20 | ("nsname", [string]), 21 | ("serial", [string]), 22 | ("slave_refresh", [string]), 23 | ("slave_retry", [string]), 24 | ("slave_expiration", [string]), 25 | ("min_ttl", [string]), 26 | ("email", [string]) 27 | ] 28 | 29 | validateMandatories :: NativeTypeValidate 30 | validateMandatories res = 31 | case res ^. rattributes . at "rtype" of 32 | Nothing -> perror "The rtype parameter is mandatory." 33 | Just (PString "SOA") -> 34 | foldM (flip mandatory) res ["nsname", "email", "serial", "slave_refresh", "slave_retry", "slave_expiration", "min_ttl"] 35 | Just (PString "NS") -> foldM (flip mandatory) res ["owner", "rclass", "rtype", "dest"] 36 | Just (PString _) -> foldM (flip mandatory) res ["owner", "rclass", "rtype", "dest", "ttl"] 37 | Just x -> perror $ "Can't use this for the rtype parameter" <+> pretty x 38 | -------------------------------------------------------------------------------- /src/Puppet/Language/Paths.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Puppet.Language.Paths where 4 | 5 | import XPrelude 6 | 7 | data PuppetDirPaths = PuppetDirPaths 8 | { -- | Puppet base working directory 9 | _baseDir :: FilePath, 10 | -- | The path to the manifests. 11 | _manifestPath :: FilePath, 12 | -- | The path to the modules. 13 | _modulesPath :: FilePath, 14 | -- | The path to the template. 15 | _templatesPath :: FilePath, 16 | -- | The path to a tests folders to hold tests files such as the pdbfiles. 17 | _testPath :: FilePath 18 | } 19 | 20 | makeClassy ''PuppetDirPaths 21 | 22 | puppetPaths :: FilePath -> PuppetDirPaths 23 | puppetPaths basedir = PuppetDirPaths basedir manifestdir modulesdir templatedir testdir 24 | where 25 | manifestdir = basedir <> "/manifests" 26 | modulesdir = basedir <> "/modules" 27 | templatedir = basedir <> "/templates" 28 | testdir = basedir <> "/tests" 29 | -------------------------------------------------------------------------------- /src/Puppet/Language/Value.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Puppet.Language.Value where 4 | 5 | import Data.Aeson 6 | import qualified Data.Aeson.KeyMap as KM 7 | import Data.Aeson.TH 8 | import Data.Scientific (isInteger) 9 | import Foreign.Ruby.Helpers 10 | import Puppet.Language.Core 11 | import XPrelude 12 | 13 | data DataType 14 | = DTType 15 | | DTString (Maybe Int) (Maybe Int) 16 | | DTInteger (Maybe Int) (Maybe Int) 17 | | DTFloat (Maybe Double) (Maybe Double) 18 | | DTBoolean 19 | | DTArray DataType Int (Maybe Int) 20 | | DTHash DataType DataType Int (Maybe Int) 21 | | DTUndef 22 | | DTScalar 23 | | DTData 24 | | DTOptional DataType 25 | | NotUndef 26 | | DTVariant (NonEmpty DataType) 27 | | DTPattern (NonEmpty CompRegex) 28 | | DTEnum (NonEmpty Text) 29 | | DTAny 30 | | DTCollection 31 | | DTRegexp (Maybe CompRegex) 32 | | DTDeferred 33 | | DTSensitive DataType 34 | deriving (Show, Eq) 35 | 36 | instance Pretty DataType where 37 | pretty t = case t of 38 | DTType -> "Type" 39 | DTString ma mb -> bounded "String" ma mb 40 | DTInteger ma mb -> bounded "Integer" ma mb 41 | DTFloat ma mb -> bounded "Float" ma mb 42 | DTBoolean -> "Boolean" 43 | DTArray dt mi mmx -> "Array" <> list (pretty dt : pretty mi : maybe [] (pure . pretty) mmx) 44 | DTHash kt dt mi mmx -> "Hash" <> list (pretty kt : pretty dt : pretty mi : maybe [] (pure . pretty) mmx) 45 | DTUndef -> "Undef" 46 | DTScalar -> "Scalar" 47 | DTData -> "Data" 48 | DTOptional o -> "Optional" <> brackets (pretty o) 49 | NotUndef -> "NotUndef" 50 | DTVariant vs -> "Variant" <> list (foldMap (pure . pretty) vs) 51 | DTPattern vs -> "Pattern" <> list (foldMap (pure . pretty) vs) 52 | DTEnum tx -> "Enum" <> list (foldMap (pure . ppline) tx) 53 | DTAny -> "Any" 54 | DTCollection -> "Collection" 55 | DTRegexp mr -> "Regex" <> foldMap (brackets . pretty) mr 56 | DTDeferred -> "Deferred" 57 | DTSensitive o -> "Sensitive" <> brackets (pretty o) 58 | where 59 | bounded :: (Pretty a, Pretty b) => Doc -> Maybe a -> Maybe b -> Doc 60 | bounded s ma mb = 61 | s <> case (ma, mb) of 62 | (Just a, Nothing) -> list [pretty a] 63 | (Just a, Just b) -> list [pretty a, pretty b] 64 | _ -> mempty 65 | 66 | $(deriveJSON defaultOptions ''DataType) 67 | 68 | -- | A puppet value. 69 | data PValue 70 | = PBoolean !Bool 71 | | PUndef 72 | | PString !Text 73 | | PResourceReference !Text !Text 74 | | PArray !(Vector PValue) 75 | | PHash !(Container PValue) 76 | | PNumber !Scientific 77 | | PType !DataType 78 | | PRegexp !CompRegex 79 | | PSensitive !PValue 80 | deriving (Eq, Show) 81 | 82 | makePrisms ''PValue 83 | 84 | instance Pretty PValue where 85 | pretty (PBoolean True) = dullmagenta "true" 86 | pretty (PBoolean False) = dullmagenta "false" 87 | pretty (PString s) = dullcyan (ppline (stringEscape s)) 88 | pretty (PNumber n) = cyan (ppline (scientific2text n)) 89 | pretty PUndef = dullmagenta "undef" 90 | pretty (PResourceReference t n) = capitalizeR t <> brackets (ppline n) 91 | pretty (PArray v) = list (map pretty (toList v)) 92 | pretty (PHash g) = containerComma g 93 | pretty (PType dt) = pretty dt 94 | pretty (PRegexp cr) = pretty cr 95 | pretty (PSensitive _) = red "[SENSITIVE]" 96 | 97 | instance IsString PValue where 98 | fromString = PString . toS 99 | 100 | instance Pretty (HashMap Text PValue) where 101 | pretty = containerComma 102 | 103 | _PValueNumber :: Prism' PValue Scientific 104 | _PValueNumber = prism num2PValue toNumber 105 | where 106 | num2PValue :: Scientific -> PValue 107 | num2PValue = PNumber 108 | toNumber :: PValue -> Either PValue Scientific 109 | toNumber (PNumber n) = Right n 110 | toNumber p@(PString x) = case text2Scientific x of 111 | Just o -> Right o 112 | _ -> Left p 113 | toNumber p = Left p 114 | 115 | _ScientificInteger :: Prism' Scientific Integer 116 | _ScientificInteger = prism fromIntegral $ \n -> 117 | if isInteger n 118 | then Right (truncate n) 119 | else Left n 120 | 121 | _PValueInteger :: Prism' PValue Integer 122 | _PValueInteger = _PValueNumber . _ScientificInteger 123 | 124 | instance FromJSON PValue where 125 | parseJSON Null = return PUndef 126 | parseJSON (Number n) = return $ PNumber n 127 | parseJSON (String s) = return (PString s) 128 | parseJSON (Bool b) = return (PBoolean b) 129 | parseJSON (Array v) = fmap PArray (mapM parseJSON v) 130 | parseJSON (Object o) | KM.size o == 1 && KM.keys o == ["regexp"] = o .: "regexp" 131 | parseJSON (Object o) = fmap (PHash . KM.toHashMapText) (traverse parseJSON o) 132 | 133 | instance ToJSON PValue where 134 | toJSON (PType t) = toJSON t 135 | toJSON (PBoolean b) = Bool b 136 | toJSON PUndef = Null 137 | toJSON (PString s) = String s 138 | toJSON (PResourceReference _ _) = Null -- TODO 139 | toJSON (PArray r) = Array (fmap toJSON r) 140 | toJSON (PHash x) = Object (KM.fromHashMapText (fmap toJSON x)) 141 | toJSON (PNumber n) = Number n 142 | toJSON (PRegexp r) = object [("regexp", toJSON r)] 143 | toJSON (PSensitive x) = toJSON x 144 | 145 | instance ToRuby PValue where 146 | toRuby = toRuby . toJSON 147 | 148 | instance FromRuby PValue where 149 | fromRuby = fmap chk . fromRuby 150 | where 151 | chk (Left x) = Left x 152 | chk (Right x) = case fromJSON x of 153 | Error rr -> Left rr 154 | Success suc -> Right suc 155 | -------------------------------------------------------------------------------- /src/Puppet/Language/WireCatalog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Puppet.Language.WireCatalog where 4 | 5 | import Data.Aeson 6 | import Puppet.Language.Core 7 | import Puppet.Language.Resource 8 | import XPrelude 9 | 10 | -- | Used to represent a relationship between two resources within the wired format (json). 11 | -- 12 | -- See 13 | data PuppetEdge = PuppetEdge RIdentifier RIdentifier LinkType deriving (Show) 14 | 15 | instance FromJSON PuppetEdge where 16 | parseJSON (Object v) = PuppetEdge <$> v .: "source" <*> v .: "target" <*> v .: "relationship" 17 | parseJSON _ = fail "invalid puppet edge" 18 | 19 | instance ToJSON PuppetEdge where 20 | toJSON (PuppetEdge s t r) = object [("source", toJSON s), ("target", toJSON t), ("relationship", toJSON r)] 21 | 22 | -- | See . 23 | data WireCatalog = WireCatalog 24 | { _wireCatalogNodename :: !NodeName, 25 | _wireCatalogVersion :: !Text, 26 | _wireCatalogEdges :: !(Vector PuppetEdge), 27 | _wireCatalogResources :: !(Vector Resource), 28 | _wireCatalogTransactionUUID :: !Text 29 | } 30 | deriving (Show) 31 | 32 | makeClassy ''WireCatalog 33 | 34 | instance FromJSON WireCatalog where 35 | parseJSON (Object d) = 36 | d .: "data" >>= \case 37 | (Object v) -> 38 | WireCatalog 39 | <$> v .: "name" 40 | <*> v .: "version" 41 | <*> v .: "edges" 42 | <*> v .: "resources" 43 | <*> v .: "transaction-uuid" 44 | _ -> fail "Data is not an object" 45 | parseJSON _ = fail "invalid wire catalog" 46 | 47 | instance ToJSON WireCatalog where 48 | toJSON (WireCatalog n v e r t) = object [("metadata", object [("api_version", Number 1)]), ("data", object d)] 49 | where 50 | d = 51 | [ ("name", String n), 52 | ("version", String v), 53 | ("edges", toJSON e), 54 | ("resources", toJSON r), 55 | ("transaction-uuid", String t) 56 | ] 57 | -------------------------------------------------------------------------------- /src/Puppet/Parser.hs: -------------------------------------------------------------------------------- 1 | -- | Parse puppet source code from text. 2 | module Puppet.Parser 3 | ( -- * Runner 4 | runPuppetParser, 5 | 6 | -- * Parsers 7 | puppetParser, 8 | prettyParseError, 9 | 10 | -- * Pretty Print 11 | module Puppet.Parser.PrettyPrinter, 12 | module Puppet.Parser.Types, 13 | module Puppet.Parser.Lens, 14 | ) 15 | where 16 | 17 | import Puppet.Parser.Internal 18 | import Puppet.Parser.Lens 19 | import Puppet.Parser.PrettyPrinter 20 | import Puppet.Parser.Types 21 | import Text.Megaparsec 22 | import XPrelude 23 | 24 | -- | Build a 'PrettyError' from a 'ParseError' given the text source. 25 | -- The source is used to display the line on which the error occurs. 26 | prettyParseError :: ParseErrorBundle Text Void -> PrettyError 27 | prettyParseError err = PrettyError $ "cannot parse" <+> pretty (errorBundlePretty err) 28 | 29 | -- | Run a puppet parser against some 'Text' input. 30 | runPuppetParser :: String -> Text -> Either (ParseErrorBundle Text Void) (Vector Statement) 31 | runPuppetParser = parse puppetParser 32 | 33 | -- | Parse a collection of puppet 'Statement'. 34 | puppetParser :: Parser (Vector Statement) 35 | puppetParser = optional sc >> statementList 36 | -------------------------------------------------------------------------------- /src/Puppet/Parser/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Puppet.Parser.Lens 4 | ( -- * Prism for 'Statement's 5 | _Statements, 6 | _ResDecl, 7 | _ResDefaultDecl, 8 | _ResOverrDecl, 9 | _ResCollDecl, 10 | _ConditionalDecl, 11 | _ClassDecl, 12 | _DefineDecl, 13 | _NodeDecl, 14 | _VarAssignDecl, 15 | _MainFuncDecl, 16 | _HigherOrderLambdaDecl, 17 | _DepDecl, 18 | 19 | -- * Prism for 'Expression's 20 | _Equal, 21 | _Different, 22 | _Not, 23 | _And, 24 | _Or, 25 | _LessThan, 26 | _MoreThan, 27 | _LessEqualThan, 28 | _MoreEqualThan, 29 | _RegexMatch, 30 | _NotRegexMatch, 31 | _Contains, 32 | _Addition, 33 | _Substraction, 34 | _Division, 35 | _Multiplication, 36 | _Modulo, 37 | _RightShift, 38 | _LeftShift, 39 | _Lookup, 40 | _Negate, 41 | _ConditionalValue, 42 | _FunctionApplication, 43 | _Terminal, 44 | ) 45 | where 46 | 47 | import qualified Data.Vector as V 48 | import Puppet.Parser.Types 49 | import XPrelude 50 | 51 | makePrisms ''Expression 52 | 53 | _ResDecl :: Prism' Statement ResDecl 54 | _ResDecl = 55 | prism ResourceDeclaration $ \x -> 56 | case x of 57 | ResourceDeclaration a -> Right a 58 | _ -> Left x 59 | 60 | _ResDefaultDecl :: Prism' Statement ResDefaultDecl 61 | _ResDefaultDecl = 62 | prism ResourceDefaultDeclaration $ \x -> 63 | case x of 64 | ResourceDefaultDeclaration a -> Right a 65 | _ -> Left x 66 | 67 | _ResOverrDecl :: Prism' Statement ResOverrideDecl 68 | _ResOverrDecl = 69 | prism ResourceOverrideDeclaration $ \x -> 70 | case x of 71 | ResourceOverrideDeclaration a -> Right a 72 | _ -> Left x 73 | 74 | _ResCollDecl :: Prism' Statement ResCollDecl 75 | _ResCollDecl = 76 | prism ResourceCollectionDeclaration $ \x -> 77 | case x of 78 | ResourceCollectionDeclaration a -> Right a 79 | _ -> Left x 80 | 81 | _ConditionalDecl :: Prism' Statement ConditionalDecl 82 | _ConditionalDecl = 83 | prism ConditionalDeclaration $ \x -> 84 | case x of 85 | ConditionalDeclaration a -> Right a 86 | _ -> Left x 87 | 88 | _ClassDecl :: Prism' Statement ClassDecl 89 | _ClassDecl = 90 | prism ClassDeclaration $ \x -> 91 | case x of 92 | ClassDeclaration a -> Right a 93 | _ -> Left x 94 | 95 | _DefineDecl :: Prism' Statement DefineDecl 96 | _DefineDecl = 97 | prism DefineDeclaration $ \x -> 98 | case x of 99 | DefineDeclaration a -> Right a 100 | _ -> Left x 101 | 102 | _NodeDecl :: Prism' Statement NodeDecl 103 | _NodeDecl = 104 | prism NodeDeclaration $ \x -> 105 | case x of 106 | NodeDeclaration a -> Right a 107 | _ -> Left x 108 | 109 | _VarAssignDecl :: Prism' Statement VarAssignDecl 110 | _VarAssignDecl = 111 | prism VarAssignmentDeclaration $ \x -> 112 | case x of 113 | VarAssignmentDeclaration a -> Right a 114 | _ -> Left x 115 | 116 | _MainFuncDecl :: Prism' Statement MainFuncDecl 117 | _MainFuncDecl = 118 | prism MainFunctionDeclaration $ \x -> 119 | case x of 120 | MainFunctionDeclaration a -> Right a 121 | _ -> Left x 122 | 123 | _HigherOrderLambdaDecl :: Prism' Statement HigherOrderLambdaDecl 124 | _HigherOrderLambdaDecl = 125 | prism HigherOrderLambdaDeclaration $ \x -> 126 | case x of 127 | HigherOrderLambdaDeclaration a -> Right a 128 | _ -> Left x 129 | 130 | _DepDecl :: Prism' Statement DepDecl 131 | _DepDecl = 132 | prism DependencyDeclaration $ \x -> 133 | case x of 134 | DependencyDeclaration a -> Right a 135 | _ -> Left x 136 | 137 | _TopContainer :: Prism' Statement (V.Vector Statement, Statement) 138 | _TopContainer = 139 | prism (uncurry TopContainer) $ \x -> 140 | case x of 141 | TopContainer vs s -> Right (vs, s) 142 | _ -> Left x 143 | 144 | _Statements :: Lens' Statement [Statement] 145 | _Statements = 146 | lens (V.toList . sget) (\s v -> sset s (V.fromList v)) 147 | where 148 | sget :: Statement -> V.Vector Statement 149 | sget (ClassDeclaration (ClassDecl _ _ _ s _)) = s 150 | sget (DefineDeclaration (DefineDecl _ _ s _)) = s 151 | sget (NodeDeclaration (NodeDecl _ s _ _)) = s 152 | sget (TopContainer s _) = s 153 | sget (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall _ _ _ s _) _)) = s 154 | sget _ = V.empty 155 | sset :: Statement -> V.Vector Statement -> Statement 156 | sset (ClassDeclaration (ClassDecl n args inh _ p)) s = ClassDeclaration (ClassDecl n args inh s p) 157 | sset (NodeDeclaration (NodeDecl ns _ nd' p)) s = NodeDeclaration (NodeDecl ns s nd' p) 158 | sset (DefineDeclaration (DefineDecl n args _ p)) s = DefineDeclaration (DefineDecl n args s p) 159 | sset (TopContainer _ p) s = TopContainer s p 160 | sset (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall t e pr _ e2) p)) s = 161 | HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall t e pr s e2) p) 162 | sset x _ = x 163 | -------------------------------------------------------------------------------- /src/Puppet/Runner.hs: -------------------------------------------------------------------------------- 1 | -- | At the top of the abstraction level, the module exposes all high-end services: 2 | -- 3 | -- * the preferences container 4 | -- * the puppet daemon 5 | -- * the statistic module 6 | -- * the stdlib functions 7 | -- * a bunch of pure runners 8 | -- 9 | -- Naturally nothing from "Puppet.Runner" should be used in lower abstraction layers. 10 | module Puppet.Runner 11 | ( -- * Preferences 12 | module Puppet.Runner.Preferences, 13 | 14 | -- * Pure 15 | module Puppet.Runner.Pure, 16 | 17 | -- * Stats 18 | module Puppet.Runner.Stats, 19 | 20 | -- * Sdlib 21 | module Puppet.Runner.Stdlib, 22 | 23 | -- * Daemon 24 | module Puppet.Runner.Daemon, 25 | 26 | -- * Re-export 27 | module Puppet.Runner.Erb.Evaluate, 28 | module Puppet.Interpreter, 29 | ) 30 | where 31 | 32 | import Puppet.Interpreter 33 | import Puppet.Runner.Daemon 34 | import Puppet.Runner.Erb.Evaluate 35 | import Puppet.Runner.Preferences 36 | import Puppet.Runner.Pure 37 | import Puppet.Runner.Stats 38 | import Puppet.Runner.Stdlib 39 | -------------------------------------------------------------------------------- /src/Puppet/Runner/Daemon/FileParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | module Puppet.Runner.Daemon.FileParser (parseFunc) where 4 | 5 | import qualified Data.Either.Strict as S 6 | import Data.FileCache as FileCache 7 | import qualified Data.HashMap.Strict as Map 8 | import qualified Data.List as List 9 | import qualified Data.Text as Text 10 | import qualified Data.Text.Encoding as Text 11 | import qualified Data.Vector as V 12 | import Debug.Trace (traceEventIO) 13 | import Puppet.Interpreter 14 | import Puppet.Parser 15 | import Puppet.Runner.Stats 16 | import qualified Text.Megaparsec as Megaparsec 17 | import qualified Text.Regex.PCRE.ByteString.Utils as Regex 18 | import XPrelude 19 | 20 | -- | Return an HOF that would parse the file associated with a toplevel. 21 | -- The toplevel is defined by the tuple (type, name) 22 | -- The result of the parsing is a single Statement (which recursively contains others statements) 23 | parseFunc :: PuppetDirPaths -> FileCacheR PrettyError (V.Vector Statement) -> MStats -> TopLevelType -> Text -> IO (S.Either PrettyError Statement) 24 | parseFunc ppath filecache stats toptype topname = 25 | let nameparts = Text.splitOn "::" topname 26 | topLevelFilePath :: TopLevelType -> Text -> Either PrettyError Text 27 | topLevelFilePath TopNode _ = Right $ Text.pack (ppath ^. manifestPath <> "/site.pp") 28 | topLevelFilePath _ name 29 | | length nameparts == 1 = Right $ Text.pack (ppath ^. modulesPath) <> "/" <> name <> "/manifests/init.pp" 30 | | null nameparts = Left $ PrettyError ("Invalid toplevel" <+> squotes (ppline name)) 31 | | otherwise = Right $ Text.pack (ppath ^. modulesPath) <> "/" <> List.head nameparts <> "/manifests/" <> Text.intercalate "/" (List.tail nameparts) <> ".pp" 32 | in case topLevelFilePath toptype topname of 33 | Left rr -> return (S.Left rr) 34 | Right fname -> do 35 | let sfname = Text.unpack fname 36 | x <- measure stats fname (FileCache.query filecache sfname (parseFile sfname)) 37 | case x of 38 | S.Right stmts -> filterStatements toptype topname stmts 39 | S.Left rr -> return (S.Left rr) 40 | 41 | parseFile :: FilePath -> IO (S.Either PrettyError (V.Vector Statement)) 42 | parseFile fname = do 43 | traceEventIO ("START parsing " ++ fname) 44 | cnt <- readFile fname 45 | o <- case runPuppetParser fname cnt of 46 | Right r -> traceEventIO ("Stopped parsing " ++ fname) >> return (S.Right r) 47 | Left rr -> do 48 | traceEventIO ("Stopped parsing " ++ fname ++ " (failure: " ++ Megaparsec.errorBundlePretty rr ++ ")") 49 | pure (S.Left $ prettyParseError rr) 50 | traceEventIO ("STOP parsing " ++ fname) 51 | return o 52 | 53 | -- TODO pre-triage stuff 54 | filterStatements :: TopLevelType -> Text -> V.Vector Statement -> IO (S.Either PrettyError Statement) 55 | -- the most complicated case, node matching 56 | filterStatements TopNode ndename stmts = 57 | -- this operation should probably get cached 58 | let (!spurious, !directnodes, !regexpmatches, !defaultnode) = V.foldl' triage (V.empty, Map.empty, V.empty, Nothing) stmts 59 | triage curstuff n@(NodeDeclaration (NodeDecl (NodeName !nm) _ _ _)) = curstuff & _2 . at nm ?~ n 60 | triage curstuff n@(NodeDeclaration (NodeDecl (NodeMatch (CompRegex _ !rg)) _ _ _)) = curstuff & _3 %~ (|> (rg :!: n)) 61 | triage curstuff n@(NodeDeclaration (NodeDecl NodeDefault _ _ _)) = curstuff & _4 ?~ n 62 | triage curstuff x = curstuff & _1 %~ (|> x) 63 | bsnodename = Text.encodeUtf8 ndename 64 | checkRegexp :: [Pair Regex Statement] -> ExceptT PrettyError IO (Maybe Statement) 65 | checkRegexp [] = return Nothing 66 | checkRegexp ((regexp :!: s) : xs) = 67 | case Regex.execute' regexp bsnodename of 68 | Left rr -> throwError (PrettyError ("Regexp match error:" <+> ppline (show rr))) 69 | Right Nothing -> checkRegexp xs 70 | Right (Just _) -> return (Just s) 71 | strictEither (Left x) = S.Left x 72 | strictEither (Right x) = S.Right x 73 | in case directnodes ^. at ndename of -- check if there is a node specifically called after my name 74 | Just r -> return (S.Right (TopContainer spurious r)) 75 | Nothing -> fmap strictEither $ runExceptT $ do 76 | regexpMatchM <- checkRegexp (V.toList regexpmatches) -- match regexps 77 | case regexpMatchM <|> defaultnode of -- check for regexp matches or use the default node 78 | Just r -> return (TopContainer spurious r) 79 | Nothing -> throwError (PrettyError ("Couldn't find node" <+> ppline ndename)) 80 | filterStatements x ndename stmts = 81 | let (!spurious, !defines, !classes) = V.foldl' triage (V.empty, Map.empty, Map.empty) stmts 82 | triage curstuff n@(ClassDeclaration (ClassDecl cname _ _ _ _)) = curstuff & _3 . at cname ?~ n 83 | triage curstuff n@(DefineDeclaration (DefineDecl cname _ _ _)) = curstuff & _2 . at cname ?~ n 84 | triage curstuff n = curstuff & _1 %~ (|> n) 85 | tc n = 86 | if V.null spurious 87 | then n 88 | else TopContainer spurious n 89 | in case x of 90 | TopDefine -> case defines ^. at ndename of 91 | Just n -> return (S.Right (tc n)) 92 | Nothing -> return (S.Left (PrettyError ("Couldn't find define " <+> ppline ndename))) 93 | TopClass -> case classes ^. at ndename of 94 | Just n -> return (S.Right (tc n)) 95 | Nothing -> return (S.Left (PrettyError ("Couldn't find class " <+> ppline ndename))) 96 | -------------------------------------------------------------------------------- /src/Puppet/Runner/Daemon/OptionalTests.hs: -------------------------------------------------------------------------------- 1 | -- | The module accumulates 'PrettyError's in the ExceptT monad transformer. 2 | module Puppet.Runner.Daemon.OptionalTests (testCatalog) where 3 | 4 | import qualified Data.HashSet as Set 5 | import qualified Data.Text as Text 6 | import Puppet.Language 7 | import Puppet.Runner.Preferences 8 | import qualified System.Directory as Directory 9 | import XPrelude 10 | 11 | -- | Entry point for all optional tests 12 | testCatalog :: 13 | Preferences IO -> 14 | FinalCatalog -> 15 | IO (Either PrettyError ()) 16 | testCatalog prefs c = 17 | runExceptT $ 18 | testFileSources (prefs ^. prefPuppetPaths . baseDir) c 19 | *> testUsersGroups (prefs ^. prefKnownusers) (prefs ^. prefKnowngroups) c 20 | 21 | -- | Tests that all users and groups are defined 22 | testUsersGroups :: [Text] -> [Text] -> FinalCatalog -> ExceptT PrettyError IO () 23 | testUsersGroups kusers kgroups c = do 24 | let users = Set.fromList $ "" : "0" : map (view (rid . iname)) (getResourceFrom "user") ++ kusers 25 | groups = Set.fromList $ "" : "0" : map (view (rid . iname)) (getResourceFrom "group") ++ kgroups 26 | checkResource lu lg = mapM_ (checkResource' lu lg) 27 | checkResource' lu lg res = do 28 | let msg att name = 29 | align 30 | ( vsep 31 | [ "Resource" 32 | <+> ppline (res ^. rid . itype) 33 | <+> ppline (res ^. rid . iname) 34 | <+> showPos (res ^. rpos . _1), 35 | "references the unknown" <+> att <+> squotes (ppline name) 36 | ] 37 | ) 38 | <> line 39 | case lu of 40 | Just lu' -> do 41 | let u = res ^. rattributes . lu' . _PString 42 | unless (Set.member u users) $ throwE $ PrettyError (msg "user" u) 43 | Nothing -> pure () 44 | case lg of 45 | Just lg' -> do 46 | let g = res ^. rattributes . lg' . _PString 47 | unless (Set.member g groups) $ throwE $ PrettyError (msg "group" g) 48 | Nothing -> pure () 49 | do 50 | checkResource (Just $ ix "owner") (Just $ ix "group") (getResourceFrom "file") 51 | checkResource (Just $ ix "user") (Just $ ix "group") (getResourceFrom "exec") 52 | checkResource (Just $ ix "user") Nothing (getResourceFrom "cron") 53 | checkResource (Just $ ix "user") Nothing (getResourceFrom "ssh_authorized_key") 54 | checkResource (Just $ ix "user") Nothing (getResourceFrom "ssh_authorized_key_secure") 55 | checkResource Nothing (Just $ ix "gid") (getResourceFrom "users") 56 | where 57 | getResourceFrom t = c ^.. traverse . filtered (\r -> r ^. rid . itype == t && r ^. rattributes . at "ensure" /= Just "absent") 58 | 59 | -- | Test source for every file resources in the catalog. 60 | testFileSources :: FilePath -> FinalCatalog -> ExceptT PrettyError IO () 61 | testFileSources basedir c = do 62 | let getfiles = filter presentFile . toList 63 | presentFile r = 64 | r ^. rid . itype == "file" 65 | && (r ^. rattributes . at "ensure") `elem` [Nothing, Just "present"] 66 | && r ^. rattributes . at "source" /= Just PUndef 67 | recurse r = case r ^? rattributes . ix "recurse" of 68 | Just (PString "true") -> True 69 | Just (PBoolean b) -> b 70 | _ -> False 71 | getsource = mapMaybe (\r -> (,,) r <$> r ^. rattributes . at "source" <*> pure (recurse r)) 72 | checkAllSources basedir $ (getsource . getfiles) c 73 | 74 | -- | Check source for all file resources and append failures along. 75 | checkAllSources :: FilePath -> [(Resource, PValue, Bool)] -> ExceptT PrettyError IO () 76 | checkAllSources fp fs = 77 | -- we could just do : 78 | -- traverse_ (\(res, src) -> catchE (checkFile fp src) (throwE ...)) fs 79 | -- but that would print the first encountered failure. 80 | go fs [] 81 | where 82 | go :: [(Resource, PValue, Bool)] -> [PrettyError] -> ExceptT PrettyError IO () 83 | go ((res, filesrc, recurse) : xs) es = ExceptT $ do 84 | runExceptT (checkFile fp filesrc recurse) >>= \case 85 | Right () -> runExceptT $ go xs es 86 | Left err -> 87 | runExceptT $ 88 | go 89 | xs 90 | ( PrettyError 91 | ( align 92 | ( vsep 93 | [ "Could not find" <+> pretty filesrc, 94 | getError err, 95 | showPos (res ^. (rpos . _1)) 96 | ] 97 | ) 98 | ) 99 | : es 100 | ) 101 | go [] [] = pure () 102 | go [] es = throwE (mconcat es) 103 | 104 | testFile :: Bool -> FilePath -> ExceptT PrettyError IO () 105 | testFile recurse fp = do 106 | p <- liftIO (Directory.doesFileExist fp) 107 | p' <- 108 | if recurse && not p 109 | then liftIO (Directory.doesDirectoryExist fp) 110 | else return p 111 | unless p' (throwE $ PrettyError $ "searched in" <+> squotes (pptext fp)) 112 | 113 | -- | Only test the `puppet:///` protocol (files managed by the puppet server) 114 | -- we don't test absolute path (puppet client files) 115 | checkFile :: FilePath -> PValue -> Bool -> ExceptT PrettyError IO () 116 | checkFile basedir (PString f) recurse = 117 | case Text.stripPrefix "puppet:///" f of 118 | Just stringdir -> case Text.splitOn "/" stringdir of 119 | ("modules" : modname : rest) -> testFile recurse (basedir <> "/modules/" <> toS modname <> "/files/" <> toS (Text.intercalate "/" rest)) 120 | ("files" : rest) -> testFile recurse (basedir <> "/files/" <> toS (Text.intercalate "/" rest)) 121 | ("private" : _) -> pure () 122 | _ -> throwE (PrettyError $ "Invalid file source:" <+> ppline f) 123 | Nothing -> return () 124 | -- source is always an array of possible paths. We only fails if none of them check. 125 | checkFile basedir (PArray xs) recurse = asum [checkFile basedir x recurse | x <- toList xs] 126 | checkFile _ x _ = throwE (PrettyError $ "Source was not a string, but" <+> pretty x) 127 | -------------------------------------------------------------------------------- /src/Puppet/Runner/Erb/Evaluate.hs: -------------------------------------------------------------------------------- 1 | -- | Private module. Evaluates a ruby template from what's generated by "Erb.Parser". 2 | module Puppet.Runner.Erb.Evaluate 3 | ( rubyEvaluate, 4 | ) 5 | where 6 | 7 | import qualified Data.Char as Char 8 | import qualified Data.HashMap.Strict as HM 9 | import qualified Data.Text as Text 10 | import qualified Data.Vector as V 11 | import Erb.Ruby 12 | import Puppet.Interpreter 13 | import XPrelude 14 | 15 | type ScopeName = Text 16 | 17 | -- | Evaluate a list of ruby statements. 18 | rubyEvaluate :: 19 | Container ScopeInformation -> 20 | ScopeName -> 21 | [RubyStatement] -> 22 | Either Doc Text 23 | rubyEvaluate vars ctx = foldl (evalruby vars ctx) (Right "") . optimize 24 | where 25 | optimize [] = [] 26 | optimize (Puts x : DropPrevSpace' : xs) = optimize $ DropPrevSpace (Puts x) : xs 27 | optimize (x : xs) = x : optimize xs 28 | 29 | spaceNotCR :: Char -> Bool 30 | spaceNotCR c = Char.isSpace c && c /= '\n' && c /= '\r' 31 | 32 | evalruby :: Container ScopeInformation -> ScopeName -> Either Doc Text -> RubyStatement -> Either Doc Text 33 | evalruby _ _ (Left err) _ = Left err 34 | evalruby _ _ (Right _) DropPrevSpace' = Left "Could not evaluate a non optimize DropPrevSpace'" 35 | evalruby mp ctx (Right curstr) (DropNextSpace x) = 36 | case evalruby mp ctx (Right curstr) x of 37 | Left err -> Left err 38 | Right y -> Right (Text.dropWhile spaceNotCR y) 39 | evalruby mp ctx (Right curstr) (DropPrevSpace x) = 40 | case evalruby mp ctx (Right curstr) x of 41 | Left err -> Left err 42 | Right y -> Right (Text.dropWhileEnd spaceNotCR y) 43 | evalruby mp ctx (Right curstr) (Puts e) = 44 | case evalExpression mp ctx e >>= evalValue of 45 | Left err -> Left err 46 | Right ex -> Right (curstr <> ex) 47 | 48 | evalExpression :: Container ScopeInformation -> ScopeName -> Expression -> Either Doc PValue 49 | evalExpression mp ctx (LookupOperation expvar expidx) = do 50 | val <- evalExpression mp ctx expvar 51 | idx <- evalExpression mp ctx expidx 52 | case val of 53 | PArray arr -> 54 | case idx ^? _PValueInteger of 55 | Nothing -> Left $ "Can't convert index to integer when resolving" <+> pretty val <> brackets (pretty idx) 56 | Just i -> 57 | if fromIntegral (V.length arr) <= i 58 | then Left $ "Array out of bound" <+> pretty val <> brackets (pretty idx) 59 | else Right (arr V.! fromIntegral i) 60 | PHash hs -> 61 | case idx of 62 | PString idx' -> 63 | case hs ^. at idx' of 64 | Just x' -> Right x' 65 | _ -> Left $ "Can't index variable" <+> pretty val <+> ", it is " <+> pretty (PHash hs) 66 | _ -> Left $ "Can't index variable" <+> pretty val <+> ", it is " <+> pretty (PHash hs) 67 | unexpectedval -> Left $ "Can't index variable" <+> pretty val <+> ", it is " <+> pretty unexpectedval 68 | evalExpression _ _ (Value (Literal x)) = Right (PString x) 69 | evalExpression mp ctx (ScopeObject (Value (Literal x))) = getVariable mp ctx x 70 | evalExpression mp ctx (Object (Value (Literal x))) = do 71 | case Text.stripPrefix "@" x of 72 | Nothing -> Left $ "Erb variables '" <> ppline x <> "' should be prefixed by '@' in puppet version 4 and above." 73 | Just x' -> getVariable mp ctx x' 74 | evalExpression _ _ x = Left $ "Can't evaluate" <+> pretty x 75 | 76 | evalValue :: PValue -> Either Doc Text 77 | evalValue = go False 78 | where 79 | go escaped p = case p of 80 | PString x -> Right $ if escaped then show x else x 81 | PNumber x -> Right (scientific2text x) 82 | PUndef -> Right "nil" 83 | PBoolean True -> Right "true" 84 | PBoolean False -> Right "false" 85 | PArray lst -> fmap (\c -> "[" <> Text.intercalate ", " c <> "]") (mapM (go True) (V.toList lst)) 86 | PHash hash -> fmap (\l -> "{" <> Text.intercalate ", " (map (\(k, v) -> show k <> "=>" <> v) l) <> "}") (mapM (traverse (go True)) (HM.toList hash)) 87 | _ -> Left ("Can't display the ruby equivalent of" <+> pretty p) 88 | -------------------------------------------------------------------------------- /src/Puppet/Runner/Stats.hs: -------------------------------------------------------------------------------- 1 | -- | A quickly done module that exports utility functions used to collect various 2 | -- statistics. All statistics are stored in a MVar holding a HashMap. 3 | -- 4 | -- This is not accurate in the presence of lazy evaluation. Nothing is forced. 5 | module Puppet.Runner.Stats 6 | ( measure, 7 | newStats, 8 | getStats, 9 | StatsPoint (..), 10 | MStats, 11 | ) 12 | where 13 | 14 | import qualified Data.HashMap.Strict as Map 15 | import Data.Time.Clock.POSIX (getPOSIXTime) 16 | import XPrelude 17 | 18 | data StatsPoint = StatsPoint 19 | { -- | Total number of calls to a computation 20 | _statspointCount :: !Int, 21 | -- | Total time spent during this computation 22 | _statspointTotal :: !Double, 23 | -- | Minimum execution time 24 | _statspointMin :: !Double, 25 | -- | Maximum execution time 26 | _statspointMax :: !Double 27 | } 28 | deriving (Show) 29 | 30 | -- | A table where keys are the names of the computations, and values are 31 | -- 'StatsPoint's. 32 | type StatsTable = HashMap Text StatsPoint 33 | 34 | newtype MStats = MStats {unMStats :: MVar StatsTable} 35 | 36 | -- | Returns the actual statistical values. 37 | getStats :: MStats -> IO StatsTable 38 | getStats = readMVar . unMStats 39 | 40 | -- | Create a new statistical container. 41 | newStats :: IO MStats 42 | newStats = MStats `fmap` newMVar Map.empty 43 | 44 | -- | Wraps a computation, and measures related execution statistics. 45 | measure :: 46 | -- | Statistics container 47 | MStats -> 48 | -- | Action identifier 49 | Text -> 50 | -- | Computation 51 | IO a -> 52 | IO a 53 | measure (MStats mtable) statsname action = do 54 | (!tm, !out) <- time action 55 | !stats <- takeMVar mtable 56 | let nstats :: StatsTable 57 | !nstats = case stats ^. at statsname of 58 | Nothing -> stats & at statsname ?~ StatsPoint 1 tm tm tm 59 | Just (StatsPoint sc st smi sma) -> 60 | let !nmax = max tm sma 61 | !nmin = min tm smi 62 | in stats & at statsname ?~ StatsPoint (sc + 1) (st + tm) nmin nmax 63 | putMVar mtable nstats 64 | return $! out 65 | 66 | getTime :: IO Double 67 | getTime = realToFrac `fmap` getPOSIXTime 68 | 69 | time :: IO a -> IO (Double, a) 70 | time action = do 71 | start <- getTime 72 | !result <- action 73 | end <- getTime 74 | let !delta = end - start 75 | return (delta, result) 76 | -------------------------------------------------------------------------------- /src/PuppetDB.hs: -------------------------------------------------------------------------------- 1 | -- | Common data types for PuppetDB. 2 | module PuppetDB 3 | ( dummyPuppetDB, 4 | getDefaultDB, 5 | pdbConnect, 6 | loadTestDB, 7 | generateWireCatalog, 8 | puppetDBFacts, 9 | module PuppetDB.Core, 10 | ) 11 | where 12 | 13 | import Control.Arrow ((***)) 14 | import qualified Data.HashMap.Strict as Map 15 | import qualified Data.Text as Text 16 | import Data.Vector.Lens 17 | import Facter 18 | import Network.HTTP.Client 19 | import Puppet.Language 20 | import PuppetDB.Core 21 | import PuppetDB.Remote 22 | import PuppetDB.TestDB 23 | import System.Environment 24 | import XPrelude 25 | 26 | -- | Given a 'PDBType', will try return a sane default implementation. 27 | getDefaultDB :: PDBType -> IO (Either PrettyError (PuppetDBAPI IO)) 28 | getDefaultDB PDBDummy = return (Right dummyPuppetDB) 29 | getDefaultDB PDBRemote = do 30 | let url = "http://localhost:8080" 31 | mgr <- newManager defaultManagerSettings 32 | pdbConnect mgr url 33 | getDefaultDB PDBTest = 34 | lookupEnv "HOME" >>= \case 35 | Just h -> loadTestDB (h <> "/.testdb") 36 | Nothing -> fmap Right initTestDB 37 | 38 | -- | A dummy implementation of 'PuppetDBAPI', that will return empty responses. 39 | dummyPuppetDB :: (Monad m) => PuppetDBAPI m 40 | dummyPuppetDB = 41 | PuppetDBAPI 42 | (return "dummy") 43 | (const (return ())) 44 | (const (return ())) 45 | (const (return ())) 46 | (const (throwError "not implemented")) 47 | (const (return [])) 48 | (const (return [])) 49 | (throwError "not implemented") 50 | (\_ _ -> return []) 51 | 52 | -- | Turns a 'FinalCatalog' and 'EdgeMap' into a document that can be 53 | -- serialized and fed to @puppet apply@. 54 | generateWireCatalog :: NodeName -> FinalCatalog -> EdgeMap -> WireCatalog 55 | generateWireCatalog node cat edgemap = WireCatalog node "version" edges resources "uiid" 56 | where 57 | edges = toVectorOf (folded . to (\li -> PuppetEdge (li ^. linksrc) (li ^. linkdst) (li ^. linkType))) (concatOf folded edgemap) 58 | resources = toVectorOf folded cat 59 | 60 | puppetDBFacts :: NodeName -> PuppetDBAPI IO -> IO (HashMap Text PValue) 61 | puppetDBFacts node pdbapi = 62 | runExceptT (getPDBFacts pdbapi (QEqual FCertname node)) >>= \case 63 | Right facts@(_ : _) -> return (Map.fromList (map (\f -> (f ^. factInfoName, f ^. factInfoVal)) facts)) 64 | _ -> do 65 | rawFacts <- fmap concat (sequence [factNET, factRAM, factOS, fversion, factMountPoints, factOS, factUser, factUName, fenv, factProcessor]) 66 | let ofacts = genFacts $ map (Text.pack *** Text.pack) rawFacts 67 | (hostname, ddomainname) = Text.break (== '.') node 68 | domainname = 69 | if Text.null ddomainname 70 | then "" 71 | else Text.tail ddomainname 72 | nfacts = 73 | genFacts 74 | [ ("fqdn", node), 75 | ("hostname", hostname), 76 | ("domain", domainname), 77 | ("rootrsa", "xxx"), 78 | ("operatingsystem", "Ubuntu"), 79 | ("puppetversion", "language-puppet"), 80 | ("virtual", "xenu"), 81 | ("clientcert", node), 82 | ("is_virtual", "true"), 83 | ("concat_basedir", "/var/lib/puppet/concat") 84 | ] 85 | allfacts = nfacts `Map.union` ofacts 86 | genFacts = Map.fromList 87 | return (allfacts & traverse %~ PString & buildOSHash) 88 | 89 | buildOSHash :: Facts -> Facts 90 | buildOSHash facts = case buildObject topLevel of 91 | Nothing -> facts 92 | Just os -> facts & at "os" ?~ os 93 | where 94 | buildObject keys = 95 | let nobject = foldl' addKey mempty keys 96 | in if nobject == mempty 97 | then Nothing 98 | else Just (PHash nobject) 99 | g k = facts ^? ix k 100 | topLevel = 101 | [ ("name", g "operatingsystem"), 102 | ("family", g "osfamily"), 103 | ("release", buildObject [("major", g "lsbdistrelease"), ("full", g "lsbdistrelease")]), 104 | ( "lsb", 105 | buildObject 106 | [ ("distcodename", g "lsbdistcodename"), 107 | ("distid", g "lsbdistid"), 108 | ("distdescription", g "lsbdistdescription"), 109 | ("distrelease", g "lsbdistrelease"), 110 | ("majdistrelease", g "lsbmajdistrelease") 111 | ] 112 | ) 113 | ] 114 | addKey hash (k, mv) = case mv of 115 | Nothing -> hash 116 | Just v -> hash & at k ?~ v 117 | -------------------------------------------------------------------------------- /src/PuppetDB/Remote.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module PuppetDB.Remote (pdbConnect) where 9 | 10 | import Facter 11 | import Network.HTTP.Client (Manager) 12 | import Puppet.Language 13 | import PuppetDB.Core 14 | import Servant.API 15 | import Servant.Client 16 | import XPrelude 17 | 18 | type PDBAPIv3 = 19 | "nodes" :> QueryParam "query" (Query NodeField) :> Get '[JSON] [NodeInfo] 20 | :<|> "nodes" :> Capture "resourcename" Text :> "resources" :> QueryParam "query" (Query ResourceField) :> Get '[JSON] [Resource] 21 | :<|> "facts" :> QueryParam "query" (Query FactField) :> Get '[JSON] [FactInfo] 22 | :<|> "resources" :> QueryParam "query" (Query ResourceField) :> Get '[JSON] [Resource] 23 | 24 | type PDBAPI = "v3" :> PDBAPIv3 25 | 26 | api :: Proxy PDBAPI 27 | api = Proxy 28 | 29 | #if !MIN_VERSION_servant(0,13,0) 30 | mkClientEnv :: Manager -> BaseUrl -> ClientEnv 31 | mkClientEnv = ClientEnv 32 | #endif 33 | 34 | #if !MIN_VERSION_servant_client(0,16,0) 35 | #define ClientError ServantError 36 | #endif 37 | 38 | -- | Given an URL (ie. @http://localhost:8080@), will return an incomplete 'PuppetDBAPI'. 39 | pdbConnect :: Manager -> String -> IO (Either PrettyError (PuppetDBAPI IO)) 40 | pdbConnect mgr url = do 41 | url' <- parseBaseUrl url 42 | let env = mkClientEnv mgr url' 43 | pure $ 44 | Right $ 45 | PuppetDBAPI 46 | (return (ppline $ fromString url)) 47 | (const (throwError "operation not supported")) 48 | (const (throwError "operation not supported")) 49 | (const (throwError "operation not supported")) 50 | (\q -> prettyError $ runClientM (sgetFacts (Just q)) env) 51 | (\q -> prettyError $ runClientM (sgetResources (Just q)) env) 52 | (\q -> prettyError $ runClientM (sgetNodes (Just q)) env) 53 | (throwError "operation not supported") 54 | (\node q -> prettyError $ runClientM (sgetNodeResources node (Just q)) env) 55 | where 56 | sgetNodes :: Maybe (Query NodeField) -> ClientM [NodeInfo] 57 | sgetNodeResources :: Text -> Maybe (Query ResourceField) -> ClientM [Resource] 58 | sgetFacts :: Maybe (Query FactField) -> ClientM [FactInfo] 59 | sgetResources :: Maybe (Query ResourceField) -> ClientM [Resource] 60 | (sgetNodes :<|> sgetNodeResources :<|> sgetFacts :<|> sgetResources) = client api 61 | 62 | prettyError :: IO (Either ClientError b) -> ExceptT PrettyError IO b 63 | prettyError = ExceptT . fmap (_Left %~ PrettyError . pplines . show) 64 | -------------------------------------------------------------------------------- /src/XPrelude.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- General specific prelude for language-puppet. 3 | -- Customization of the with extra specific utilities. 4 | module XPrelude 5 | ( module XPrelude.Extra, 6 | module XPrelude.PP, 7 | ) 8 | where 9 | 10 | import XPrelude.Extra 11 | import XPrelude.PP hiding (width, ()) 12 | -------------------------------------------------------------------------------- /src/XPrelude/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# OPTIONS_HADDOCK ignore-exports #-} 3 | 4 | module XPrelude.Extra 5 | ( module Exports, 6 | String, 7 | Container, 8 | unwrapError, 9 | dropInitialColons, 10 | strictifyEither, 11 | scientific2text, 12 | text2Scientific, 13 | ifromList, 14 | ikeys, 15 | ifromListWith, 16 | iunionWith, 17 | iinsertWith, 18 | 19 | -- * Logger 20 | loggerName, 21 | logDebug, 22 | logDebugStr, 23 | logInfo, 24 | logInfoStr, 25 | logWarning, 26 | logWarningStr, 27 | logError, 28 | logErrorStr, 29 | logCritical, 30 | logCriticalStr, 31 | 32 | -- * Lenses for json 33 | avalues, 34 | nth, 35 | ) 36 | where 37 | 38 | import Control.Exception.Lens as Exports (catching) 39 | import Control.Lens as Exports hiding 40 | ( Strict, 41 | argument, 42 | noneOf, 43 | op, 44 | (<.>), 45 | ) 46 | import Control.Monad as Exports (fail) 47 | import Control.Monad.Trans.Except as Exports (except) 48 | import Control.Monad.Trans.Maybe as Exports (runMaybeT) 49 | import Data.Aeson (Value (..)) 50 | import Data.Aeson as Exports (FromJSON, ToJSON, fromJSON, toJSON) 51 | import Data.Aeson.Lens as Exports (key, _Array, _Object, _String) 52 | import Data.Attoparsec.Text (parseOnly, rational) 53 | import qualified Data.Either.Strict as S 54 | import Data.HashMap.Strict as Exports (HashMap) 55 | import qualified Data.HashMap.Strict as Map 56 | import Data.HashSet as Exports (HashSet) 57 | import qualified Data.HashSet as HS 58 | import Data.Scientific as Exports (Scientific) 59 | import qualified Data.Scientific as Scientific 60 | import Data.String (String) 61 | import Data.String as Exports (IsString (..)) 62 | import qualified Data.Text as Text 63 | import Data.Tuple.Strict as Exports (Pair (..)) 64 | import Data.Vector as Exports (Vector) 65 | import Protolude as Exports hiding 66 | ( Down, 67 | Infix, 68 | Prefix, 69 | Selector, 70 | State, 71 | StateT, 72 | break, 73 | check, 74 | evalState, 75 | evalStateT, 76 | execState, 77 | execStateT, 78 | from, 79 | hash, 80 | list, 81 | moduleName, 82 | runState, 83 | runStateT, 84 | sourceColumn, 85 | sourceLine, 86 | to, 87 | typeOf, 88 | uncons, 89 | unsnoc, 90 | withState, 91 | (%), 92 | (<&>), 93 | (<.>), 94 | ) 95 | import qualified System.Log.Logger as Log 96 | import Text.Regex.PCRE.ByteString.Utils as Exports (Regex) 97 | import XPrelude.PP 98 | 99 | type Container = Map.HashMap Text 100 | 101 | text2Scientific :: Text -> Maybe Scientific 102 | text2Scientific t = rightToMaybe (parseOnly rational t) 103 | 104 | scientific2text :: Scientific -> Text 105 | scientific2text n = 106 | case Scientific.floatingOrInteger n of 107 | Left r -> show (r :: Double) 108 | Right i -> show (i :: Integer) 109 | 110 | strictifyEither :: Either a b -> S.Either a b 111 | strictifyEither (Left x) = S.Left x 112 | strictifyEither (Right x) = S.Right x 113 | 114 | -- | Helper for hashmap, in case we want another kind of map. 115 | ifromList :: (Monoid m, At m, Foldable f) => f (Index m, IxValue m) -> m 116 | {-# INLINEABLE ifromList #-} 117 | ifromList = foldl' (\curm (k, v) -> curm & at k ?~ v) mempty 118 | 119 | -- | Return all the keys of a map in a set. 120 | ikeys :: (Eq k, Hashable k) => HashMap k v -> HS.HashSet k 121 | {-# INLINEABLE ikeys #-} 122 | ikeys = HS.fromList . Map.keys 123 | 124 | ifromListWith :: (Monoid m, At m, Foldable f) => (IxValue m -> IxValue m -> IxValue m) -> f (Index m, IxValue m) -> m 125 | {-# INLINEABLE ifromListWith #-} 126 | ifromListWith f = foldl' (\curmap (k, v) -> iinsertWith f k v curmap) mempty 127 | 128 | iinsertWith :: (At m) => (IxValue m -> IxValue m -> IxValue m) -> Index m -> IxValue m -> m -> m 129 | {-# INLINEABLE iinsertWith #-} 130 | iinsertWith f k v m = 131 | m & at k %~ mightreplace 132 | where 133 | mightreplace Nothing = Just v 134 | mightreplace (Just x) = Just (f v x) 135 | 136 | iunionWith :: (Hashable k, Eq k) => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v 137 | {-# INLINEABLE iunionWith #-} 138 | iunionWith = Map.unionWith 139 | 140 | -- | Remove the '::' token from a text if any. 141 | dropInitialColons :: Text -> Text 142 | dropInitialColons t = fromMaybe t (Text.stripPrefix "::" t) 143 | 144 | loggerName :: String 145 | loggerName = "language-puppet" 146 | 147 | logDebug :: Text -> IO () 148 | logDebug = Log.debugM "language-puppet" . toS 149 | 150 | logInfo :: Text -> IO () 151 | logInfo = Log.infoM "language-puppet" . toS 152 | 153 | logInfoStr :: String -> IO () 154 | logInfoStr = Log.infoM "language-puppet" 155 | 156 | logWarning :: Text -> IO () 157 | logWarning = Log.warningM "language-puppet" . toS 158 | 159 | logWarningStr :: String -> IO () 160 | logWarningStr = Log.warningM "language-puppet" 161 | 162 | logError :: Text -> IO () 163 | logError = Log.errorM "language-puppet" . toS 164 | 165 | logErrorStr :: String -> IO () 166 | logErrorStr = Log.errorM "language-puppet" 167 | 168 | logCritical :: Text -> IO () 169 | logCritical = Log.criticalM "language-puppet" . toS 170 | 171 | logCriticalStr :: String -> IO () 172 | logCriticalStr = Log.criticalM "language-puppet" 173 | 174 | logDebugStr :: String -> IO () 175 | logDebugStr = Log.debugM "language-puppet" 176 | 177 | -- | In case of a Left error, print and exit immediately. 178 | unwrapError :: Doc -> Either PrettyError a -> IO a 179 | unwrapError desc = either exit pure 180 | where 181 | exit err = putDoc (display err) >> exitFailure 182 | display err = red desc <> ":" <+> getError err 183 | 184 | avalues :: IndexedTraversal' Int Value Value 185 | avalues = _Array . traversed 186 | 187 | nth :: Int -> Traversal' Value Value 188 | nth i = _Array . ix i 189 | -------------------------------------------------------------------------------- /src/XPrelude/PP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | {-# OPTIONS_HADDOCK ignore-exports #-} 4 | 5 | module XPrelude.PP 6 | ( module Exports, 7 | PrettyError (..), 8 | ppline, 9 | pplines, 10 | pptext, 11 | ppstring, 12 | ) 13 | where 14 | 15 | import Data.Scientific 16 | import Data.Semigroup as Sem 17 | import Data.String 18 | import qualified Data.Text as Text 19 | import Protolude 20 | import Text.PrettyPrint.ANSI.Leijen (string, text) 21 | import Text.PrettyPrint.ANSI.Leijen as Exports hiding 22 | ( bool, 23 | cat, 24 | char, 25 | double, 26 | empty, 27 | float, 28 | group, 29 | int, 30 | integer, 31 | rational, 32 | string, 33 | text, 34 | (<$>), 35 | ) 36 | 37 | newtype PrettyError = PrettyError 38 | { getError :: Doc 39 | } 40 | deriving (Show) 41 | 42 | instance Sem.Semigroup PrettyError where 43 | a <> b = PrettyError $ align (vsep [getError a, getError b]) 44 | 45 | instance Monoid PrettyError where 46 | mempty = PrettyError mempty 47 | #if !(MIN_VERSION_base(4,11,0)) 48 | mappend = (Sem.<>) 49 | #endif 50 | 51 | instance IsString PrettyError where 52 | fromString = PrettyError . string 53 | 54 | instance Pretty PrettyError where 55 | pretty = getError 56 | 57 | instance Pretty Scientific where 58 | pretty = text . show 59 | 60 | -- | pretty print multiple lines of text. 61 | pplines :: Text -> Doc 62 | pplines = string . Text.unpack 63 | 64 | -- | pretty print a single line of text. 65 | ppline :: Text -> Doc 66 | ppline = text . Text.unpack 67 | 68 | -- | pretty print multiple lines of string. 69 | ppstring :: String -> Doc 70 | ppstring = string 71 | 72 | -- | pretty print one line of string 73 | pptext :: String -> Doc 74 | pptext = text 75 | -------------------------------------------------------------------------------- /stack-21.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | extra-deps: [] 3 | packages: 4 | - '.' 5 | resolver: lts-21.16 6 | extra-deps: 7 | - filecache-0.4.1@sha256:cc1a1e816a7435564c7bd35f87f8f3818ccf987b9b02f7f749d2ef64480d6b71,1779 8 | - fsnotify-0.3.0.1@sha256:fbec8cddd3f991d5b905df16895c67717b0f580e1ef33de34d93de814af1a08a,2988 9 | - hruby-0.5.1.0 10 | -------------------------------------------------------------------------------- /tests/ErbSpec.hs: -------------------------------------------------------------------------------- 1 | module ErbSpec (spec) where 2 | 3 | import Erb 4 | import GHC.Base (error) 5 | import Puppet.Runner 6 | import Test.Hspec 7 | import XPrelude 8 | 9 | parsingtests :: [(String, [RubyStatement])] 10 | parsingtests = 11 | [ ("port = 5432", [Puts (Value (Literal "port = 5432"))]), 12 | ( "mode = host=<%= @var %>", 13 | [ Puts (Value (Literal "mode = host=")), 14 | Puts (Object (Value (Literal "@var"))), 15 | Puts (Value (Literal "")) 16 | ] 17 | ), 18 | ( "mode = host=<%= var %>", 19 | [ Puts (Value (Literal "mode = host=")), 20 | Puts (Object (Value (Literal "var"))), 21 | Puts (Value (Literal "")) 22 | ] 23 | ), 24 | ( "<%= @os['architecture'] %>", 25 | [ Puts (Value (Literal "")), 26 | Puts (LookupOperation (Object (Value (Literal "@os"))) (Value (Literal "architecture"))), 27 | Puts (Value (Literal "")) 28 | ] 29 | ), 30 | ( "<%= @os['release']['major'] %>", 31 | [ Puts (Value (Literal "")), 32 | Puts (LookupOperation (LookupOperation (Object (Value (Literal "@os"))) (Value (Literal "release"))) (Value (Literal "major"))), 33 | Puts (Value (Literal "")) 34 | ] 35 | ), 36 | ( "<%= @processors['models'] %>", 37 | [ Puts (Value (Literal "")), 38 | Puts (LookupOperation (Object (Value (Literal "@processors"))) (Value (Literal "models"))), 39 | Puts (Value (Literal "")) 40 | ] 41 | ), 42 | ( "<%= scope.lookupvar('::fqdn') %>", 43 | [ Puts (Value (Literal "")), 44 | Puts (ScopeObject (Value (Literal "::fqdn"))), 45 | Puts (Value (Literal "")) 46 | ] 47 | ), 48 | ( "<%= scope.lookupvar(\"::fqdn\") %>", 49 | [ Puts (Value (Literal "")), 50 | Puts (ScopeObject (Value (Literal "::fqdn"))), 51 | Puts (Value (Literal "")) 52 | ] 53 | ) 54 | ] 55 | 56 | resolvetests :: [([RubyStatement], Text)] 57 | resolvetests = 58 | [ ( [Puts (Object (Value (Literal "@hostname")))], 59 | "dummy" 60 | ), 61 | ( [Puts (LookupOperation (Object (Value (Literal "@os"))) (Value (Literal "architecture")))], 62 | "amd64" 63 | ), 64 | ( [Puts (LookupOperation (LookupOperation (Object (Value (Literal "@os"))) (Value (Literal "release"))) (Value (Literal "major")))], 65 | "7" 66 | ), 67 | ( [Puts (LookupOperation (Object (Value (Literal "@processors"))) (Value (Literal "models")))], 68 | expectedmodels 69 | ), 70 | ( [Puts (ScopeObject (Value (Literal "::fqdn")))], 71 | "dummy.dummy.domain" 72 | ) 73 | ] 74 | where 75 | expectedmodels = "[\"Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz\", \"Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz\", \"Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz\", \"Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz\", \"Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz\", \"Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz\", \"Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz\", \"Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz\", \"Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz\"]" 76 | 77 | parsingspec = 78 | for_ parsingtests $ \(s, e) -> 79 | let item = it ("should parse " <> s) 80 | in case parseErbString s of 81 | Left err -> item $ expectationFailure (show err) 82 | Right r -> item $ r `shouldBe` e 83 | 84 | resolvespec = 85 | let state0 = initialState dummyFacts mempty 86 | (scope_name, scope) = case extractScope state0 of 87 | Just p -> p 88 | Nothing -> error "should not happen" 89 | in for_ resolvetests $ \(s, e) -> 90 | let item = it ("should resolve " <> show s) 91 | in case rubyEvaluate scope scope_name s of 92 | Left err -> item $ expectationFailure (show err) 93 | Right r -> item $ r `shouldBe` e 94 | 95 | spec = describe "Erb" $ do 96 | parsingspec 97 | resolvespec 98 | -------------------------------------------------------------------------------- /tests/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE OverloadedLists #-} 3 | 4 | module Helpers 5 | ( module Exports, 6 | checkExprsSuccess, 7 | checkExprsError, 8 | pureCatalog, 9 | getResource, 10 | getAttribute, 11 | renderToString, 12 | withStdlibFunction, 13 | ) 14 | where 15 | 16 | import qualified Data.HashMap.Strict as HM 17 | import qualified Data.Maybe.Strict as S 18 | import qualified Data.Vector as Vector 19 | import Puppet.Interpreter as Exports 20 | import Puppet.Parser as Exports 21 | import Puppet.Runner as Exports hiding (getCatalog) 22 | import Test.Hspec as Exports 23 | import XPrelude as Exports 24 | 25 | -- | Given a raw text input to be parsed, compute the manifest in a pure setting. 26 | -- The 'InterpreterWriter' might be useful for debugging purpose. 27 | pureCatalog :: Text -> Either String (FinalCatalog, InterpreterWriter) 28 | pureCatalog = runExcept . fmap (\s -> (s ^. _1, s ^. _6)) . compileCatalog 29 | where 30 | compileCatalog :: Text -> Except String (FinalCatalog, EdgeMap, FinalCatalog, [Resource], InterpreterState, InterpreterWriter) 31 | compileCatalog input = do 32 | statements <- either (throwError . show) pure (runPuppetParser mempty input) 33 | let nodename = "pure" 34 | top_node = [((TopNode, nodename), NodeDeclaration (NodeDecl (NodeName nodename) statements S.Nothing (initialPPos mempty)))] 35 | (res, finalState, logs) = pureEval top_node (computeCatalog nodename) 36 | (catalog, em, exported, defResources) <- either (throwError . show) pure res 37 | pure (catalog, em, exported, defResources, finalState, logs) 38 | 39 | getResource :: (MonadFail m) => RIdentifier -> FinalCatalog -> m Resource 40 | getResource resid catalog = maybe (fail ("Unknown resource " <> renderToString resid)) pure (HM.lookup resid catalog) 41 | 42 | getAttribute :: (MonadFail m) => Text -> Resource -> m PValue 43 | getAttribute att res = 44 | case res ^? rattributes . ix att of 45 | Nothing -> fail ("Unknown attribute: " <> toS att) 46 | Just x -> return x 47 | 48 | withStdlibFunction :: Text -> (([PValue] -> InterpreterMonad PValue) -> Spec) -> Spec 49 | withStdlibFunction fname testsuite = 50 | case stdlibFunctions ^? ix fname of 51 | Just f -> testsuite f 52 | Nothing -> panic ("Don't know this function: " <> fname) 53 | 54 | checkExprsSuccess :: Text -> [Expression] -> Text -> Expectation 55 | checkExprsSuccess fname args res = 56 | case evalExprs fname args of 57 | Left rr -> expectationFailure (show rr) 58 | Right res' -> res' `shouldBe` res 59 | 60 | checkExprsError :: Text -> [Expression] -> String -> Expectation 61 | checkExprsError fname args msg = 62 | case evalExprs fname args of 63 | Left rr -> show rr `shouldContain` msg 64 | Right r -> expectationFailure ("Should have errored, received this instead: " <> show r) 65 | 66 | evalExprs :: Text -> [Expression] -> Either PrettyError Text 67 | evalExprs fname = 68 | dummyEval . resolveValue . UFunctionCall fname . Vector.fromList >=> \case 69 | PString s -> return s 70 | v -> Left ("Expected a string, not " <> PrettyError (pretty v)) 71 | 72 | renderToString :: (Pretty a) => a -> String 73 | renderToString d = displayS (renderCompact (pretty d)) "" 74 | -------------------------------------------------------------------------------- /tests/Interpreter/ClassSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Interpreter.ClassSpec (spec) where 4 | 5 | import Control.Lens 6 | import qualified Data.Text as Text 7 | import Helpers 8 | import Test.Hspec 9 | 10 | spec = do 11 | describe "Class" $ do 12 | it "should work when using several include statements" $ 13 | pureCatalog (Text.unlines ["class foo {}", "include foo", "include foo"]) `shouldSatisfy` has _Right 14 | it "should work when using class before include" $ 15 | pureCatalog (Text.unlines ["class foo {}", "class { 'foo': }", "include foo"]) `shouldSatisfy` has _Right 16 | it "should fail when using include before class" $ 17 | pureCatalog (Text.unlines ["class foo {}", "include foo", "class { 'foo': }"]) `shouldSatisfy` has _Left 18 | it "should fail if the class is not defined" $ 19 | pureCatalog (Text.unlines ["include foo"]) `shouldSatisfy` has _Left 20 | describe "Parameters" $ do 21 | it "should fail when declaring a class with an unknown params" $ 22 | pureCatalog (Text.unlines ["class foo ($param0){}", "class {'foo': param1 => 1 }"]) `shouldSatisfy` has _Left 23 | it "should succeed when declaring a class with a correct param" $ 24 | pureCatalog (Text.unlines ["class foo ($param0){}", "class {'foo': param0 => 1 }"]) `shouldSatisfy` has _Right 25 | it "should fail when the type of the attribute is wrong" $ 26 | pureCatalog (Text.unlines ["class foo (String $param0){}", "class {'foo': param0 => 1 }"]) `shouldSatisfy` has _Left 27 | it "should fail when declaring with a missing param" $ 28 | pureCatalog (Text.unlines ["class foo ($param0){}", "class {'foo': }"]) `shouldSatisfy` has _Left 29 | it "should succeed with missing param and an optional type" $ 30 | pureCatalog (Text.unlines ["class foo (Optional[String] $param0){}", "class {'foo': }"]) `shouldSatisfy` has _Right 31 | -------------------------------------------------------------------------------- /tests/Interpreter/EvalSpec.hs: -------------------------------------------------------------------------------- 1 | module Interpreter.EvalSpec (spec) where 2 | 3 | import Puppet.Interpreter 4 | import Puppet.Parser.Internal 5 | import Puppet.Runner 6 | import Test.Hspec 7 | import Text.Megaparsec (eof, errorBundlePretty, parse) 8 | import XPrelude 9 | 10 | evaluations = 11 | [ "4 + 2 == 6", 12 | "[1,2][1] == 2", 13 | "[1,[1,2]][1][0] == 1", 14 | "[1,2,3] + [4,5,6] == [1,2,3,4,5,6]", 15 | "{a => 1} + {b => 2} == {a=>1, b=>2 }", 16 | "[1,2,3] << 10 == [1,2,3,10]", 17 | "[1,2,3] << [4,5] == [1,2,3,[4,5]]", 18 | "4 / 2.0 == 2", 19 | "$kernel == 'Linux'", 20 | "$facts['os']['architecture'] == 'amd64'", 21 | -- string interpolation 22 | "\"$kernel\" == 'Linux'", 23 | "\"${kernel} box\" == 'Linux box'", 24 | "\"${os['architecture']}\" == 'amd64'", 25 | "\"${os['release']['major']}\" == '7'", 26 | "\"${facts['kernel']}\" == 'Linux'", 27 | "\"${facts['os']['architecture']}\" == 'amd64'", 28 | -- 29 | "$settings::confdir == '/etc/puppet'", 30 | "regsubst('127', '([0-9]+)', '<\\1>', 'G') == '<127>'", 31 | "regsubst(['1','2','3'], '([0-9]+)', '<\\1>', 'G') == ['<1>','<2>','<3>']", 32 | "versioncmp('2.1','2.2') == -1", 33 | "inline_template('a','b') == 'ab'" 34 | ] 35 | 36 | testEvaluation t = 37 | let item = it ("should evaluate " <> t) 38 | in case check (toS t) of 39 | Left ctx -> context ctx $ item False 40 | Right b -> item b 41 | 42 | check :: Text -> Either String Bool 43 | check t = 44 | case parse (expression <* eof) "dummy" t of 45 | Left err -> Left $ "Parsing error. Are you sure the input is correct ?\n" <> errorBundlePretty err 46 | Right e -> case dummyEval (resolveExpression e) of 47 | Right (PBoolean True) -> Right True 48 | _ -> Right False 49 | 50 | spec = do 51 | describe "Evaluation of expressions" $ mapM_ testEvaluation evaluations 52 | -------------------------------------------------------------------------------- /tests/Interpreter/EvaluateStatementSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Interpreter.EvaluateStatementSpec where 4 | 5 | import qualified Data.Text as Text 6 | import Helpers 7 | 8 | main :: IO () 9 | main = hspec spec 10 | 11 | shouldNotify :: [Text] -> PValue -> Expectation 12 | shouldNotify s expected = do 13 | catalog <- case pureCatalog (Text.unlines s) of 14 | Left rr -> fail rr 15 | Right (x, _) -> pure x 16 | let msg = catalog ^? at (RIdentifier "notify" "test") . _Just . rattributes . ix "message" 17 | msg `shouldBe` Just expected 18 | 19 | spec :: Spec 20 | spec = do 21 | describe "evaluate statement" $ do 22 | it "should evaluate simple variable assignment" $ 23 | ["$a = 0", "notify { 'test': message => \"a is ${a}\"}"] `shouldNotify` "a is 0" 24 | it "should evaluate chained variables assignment" $ 25 | ["$a = $b = 0", "notify { 'test': message => \"b is ${b}\"}"] `shouldNotify` "b is 0" 26 | -------------------------------------------------------------------------------- /tests/Interpreter/Function/AssertPrivateSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Interpreter.Function.AssertPrivateSpec where 4 | 5 | import Helpers 6 | 7 | main :: IO () 8 | main = hspec spec 9 | 10 | evalWithScope :: 11 | ([PValue] -> InterpreterMonad PValue) -> 12 | -- | caller scope 13 | Text -> 14 | -- | module scope 15 | Text -> 16 | -- | function args 17 | [Expression] -> 18 | Either String PValue 19 | evalWithScope apFunc callerScope moduleScope = 20 | (_Left %~ show) . view _1 . ctxEval . (mapM resolveExpression >=> apFunc) 21 | where 22 | ctxEval = pureEval' mempty state0 Nothing 23 | state0 = dummyInitialState & curScope .~ [ContClass moduleScope, ContClass callerScope] 24 | 25 | spec :: Spec 26 | spec = withStdlibFunction "assert_private" $ \apFunc -> do 27 | let errorWith a b = case a of 28 | Right x -> fail ("Should have failed, got this instead: " ++ show x) 29 | Left rr -> rr `shouldContain` b 30 | it "should work when called from inside module" (evalWithScope apFunc "bar" "bar" [] `shouldBe` Right PUndef) 31 | it "should fail with the default message" (evalWithScope apFunc "bar" "baz" [] `errorWith` "is private") 32 | it "should fail with an explicit failure message" (evalWithScope apFunc "bar" "baz" ["lalala"] `errorWith` "lalala") 33 | -------------------------------------------------------------------------------- /tests/Interpreter/Function/DeleteAtSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Interpreter.Function.DeleteAtSpec (spec, main) where 4 | 5 | import Helpers 6 | 7 | main :: IO () 8 | main = hspec spec 9 | 10 | spec :: Spec 11 | spec = withStdlibFunction "delete_at" $ \deleteAtFunc -> do 12 | let evalArgs' = dummyEval . deleteAtFunc 13 | narray = PArray . fmap PNumber 14 | check a b res = case evalArgs' [narray a, PNumber b] of 15 | Left rr -> expectationFailure (show rr) 16 | Right res' -> res' `shouldBe` narray res 17 | checkError args ins = case evalArgs' args of 18 | Left rr -> show rr `shouldContain` ins 19 | Right r -> expectationFailure ("Should have errored, received this instead: " <> show r) 20 | it "should error with invalid arguments" $ do 21 | checkError [] "expects 2 arguments" 22 | checkError [PNumber 1] "expects 2 arguments" 23 | checkError ["foo", "bar"] "expects its first argument to be an array" 24 | checkError [narray [0, 1, 2], PNumber 3] "Out of bounds access" 25 | it "should work otherwise" $ do 26 | check [0, 1, 2] 1 [0, 2] 27 | it "should work for negative positions" $ do 28 | pending 29 | check [0, 1, 2] (-1) [0, 1] 30 | check [0, 1, 2] (-4) [0, 1, 2] 31 | -------------------------------------------------------------------------------- /tests/Interpreter/Function/EachSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Interpreter.Function.EachSpec (spec, main) where 4 | 5 | import Helpers 6 | 7 | main :: IO () 8 | main = hspec spec 9 | 10 | spec :: Spec 11 | spec = do 12 | let getCatalog x = case pureCatalog x of 13 | Left rr -> fail rr 14 | Right (y, _) -> pure y 15 | describe "should be callable as" $ do 16 | let checkEnsure f v c = 17 | getResource (RIdentifier "file" f) c >>= getAttribute "ensure" >>= \a -> a `shouldBe` v 18 | checks :: [(Text, PValue)] -> FinalCatalog -> IO () 19 | checks lst c = mapM_ (\(f, v) -> checkEnsure f v c) lst 20 | it "each on an array selecting each value" $ 21 | getCatalog "$a = [1,2,3]\n $a.each |$v| {\n file { \"/file_$v\": ensure => present } \n } " 22 | >>= checks 23 | [ ("/file_1", "present"), 24 | ("/file_2", "present"), 25 | ("/file_3", "present") 26 | ] 27 | it "each on an array selecting each value - function call style" $ 28 | getCatalog "$a = [1,2,3]\n each ($a) |$index, $v| {\n file { \"/file_$v\": ensure => present }\n }" 29 | >>= checks 30 | [ ("/file_1", "present"), 31 | ("/file_2", "present"), 32 | ("/file_3", "present") 33 | ] 34 | it "each on an array with index" $ 35 | getCatalog "$a = [present, absent, present]\n $a.each |$k,$v| {\n file { \"/file_$k\": ensure => $v }\n }" 36 | >>= checks 37 | [ ("/file_0", "present"), 38 | ("/file_1", "absent"), 39 | ("/file_2", "present") 40 | ] 41 | it "each on a hash selecting entries" $ 42 | getCatalog "$a = {'a'=>'present','b'=>'absent','c'=>'present'}\n $a.each |$e| {\n $num = $e[0]\n file { \"/file_${num}\": ensure => $e[1] }\n }" 43 | >>= checks 44 | [ ("/file_a", "present"), 45 | ("/file_b", "absent"), 46 | ("/file_c", "present") 47 | ] 48 | it "each on a hash selecting key and value" $ 49 | getCatalog "$a = {'a'=>present,'b'=>absent,'c'=>present}\n $a.each |$k, $v| {\n file { \"/file_$k\": ensure => $v }\n }" 50 | >>= checks 51 | [ ("/file_a", "present"), 52 | ("/file_b", "absent"), 53 | ("/file_c", "present") 54 | ] 55 | it "each on a hash selecting key and value (using captures-last parameter)" $ do 56 | pending 57 | getCatalog "$a = {'a'=>present,'b'=>absent,'c'=>present}\n $a.each |*$kv| {\n file { \"/file_${kv[0]}\": ensure => $kv[1] }\n }" 58 | >>= checks 59 | [ ("/file_a", "present"), 60 | ("/file_b", "absent"), 61 | ("/file_c", "present") 62 | ] 63 | describe "should produce receiver" $ 64 | it "each checking produced value using single expression" $ do 65 | pending 66 | c <- getCatalog "$a = [1, 3, 2]\n $b = $a.each |$x| { \"unwanted\" }\n $u = $b[1]\n file { \"/file_${u}\":\n ensure => present\n }" 67 | getResource (RIdentifier "file" "/file_3") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" 68 | -------------------------------------------------------------------------------- /tests/Interpreter/Function/JoinKeysToValuesSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Interpreter.Function.JoinKeysToValuesSpec (spec) where 4 | 5 | import qualified Data.Foldable as F 6 | import Data.Monoid 7 | import Helpers 8 | import Puppet.Interpreter 9 | import Test.Hspec 10 | 11 | spec :: Spec 12 | spec = withStdlibFunction "join_keys_to_values" $ \jkvFunc -> it "Should work as expected" $ do 13 | let eval h s = case dummyEval (jkvFunc [PHash h, PString s]) of 14 | Left rr -> Left (renderToString (getError rr)) 15 | Right (PArray vals) -> Right (F.toList vals) 16 | Right v -> Left ("Expected an array, not: " <> renderToString v) 17 | eval [] "" `shouldBe` Right [] 18 | eval [] ":" `shouldBe` Right [] 19 | eval [("key", "value")] "" `shouldBe` Right ["keyvalue"] 20 | eval [("key", "value")] ":" `shouldBe` Right ["key:value"] 21 | eval [("key", PUndef)] ":" `shouldBe` Right ["key:"] 22 | case eval [("key1", "value1"), ("key2", "value2")] ":" of 23 | Left rr -> fail rr 24 | Right lst -> lst `shouldMatchList` ["key1:value1", "key2:value2"] 25 | -------------------------------------------------------------------------------- /tests/Interpreter/Function/LookupSpec.hs: -------------------------------------------------------------------------------- 1 | module Interpreter.Function.LookupSpec (spec, main) where 2 | 3 | import Helpers 4 | 5 | main :: IO () 6 | main = hspec spec 7 | 8 | fname :: Text 9 | fname = "lookup" 10 | 11 | expectedErrMsg :: String 12 | expectedErrMsg = "Wrong set of arguments" 13 | 14 | -- See dummyFacts defined in Pure.hs 15 | testkey :: Expression 16 | testkey = "foo" 17 | 18 | expectedValue :: Text 19 | expectedValue = "dummy" 20 | 21 | checkSuccess :: [Expression] -> Text -> Expectation 22 | checkSuccess = checkExprsSuccess fname 23 | 24 | checkError :: [Expression] -> String -> Expectation 25 | checkError = checkExprsError fname 26 | 27 | boolDatatype, stringDatatype :: Expression 28 | boolDatatype = Terminal (UDataType UDTBoolean) 29 | stringDatatype = Terminal (UDataType (UDTString Nothing Nothing)) 30 | 31 | spec :: Spec 32 | spec = do 33 | it "should fail with no argument" (checkError [] expectedErrMsg) 34 | it "should succeed with one argument" (checkSuccess [testkey] expectedValue) 35 | it "should succeed with 4 arguments" (checkSuccess [testkey, stringDatatype, "unique", "default"] expectedValue) 36 | it "should fail with an unknown merge strategy" (checkError [testkey, stringDatatype, "joe", "default"] "Unknown merge strategy") 37 | it "should succeed with two arguments, the second one being a datatype" (checkSuccess [testkey, stringDatatype] expectedValue) 38 | it "should fail when the type mismatched" (checkError [testkey, boolDatatype] "Datatype mismatched") 39 | it "should fail with two arguments both strings" (checkError [testkey, "default"] expectedErrMsg) 40 | -------------------------------------------------------------------------------- /tests/Interpreter/Function/MergeSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Interpreter.Function.MergeSpec (spec, main) where 4 | 5 | import qualified Data.HashMap.Strict as HM 6 | import Helpers 7 | 8 | main :: IO () 9 | main = hspec spec 10 | 11 | spec = do 12 | spec0 13 | spec1 14 | 15 | evalArgs :: InterpreterMonad PValue -> Either PrettyError (HM.HashMap Text PValue) 16 | evalArgs = 17 | dummyEval 18 | >=> \pv -> case pv of 19 | PHash s -> return s 20 | _ -> Left ("Expected a string, not " <> PrettyError (pretty pv)) 21 | 22 | spec0 :: Spec 23 | spec0 = do 24 | withStdlibFunction "merge" $ \mergeFunc -> do 25 | let evalArgs' = evalArgs . mergeFunc 26 | let check args res = case evalArgs' (map PHash args) of 27 | Left rr -> expectationFailure (show rr) 28 | Right res' -> res' `shouldBe` res 29 | checkError args ins = case evalArgs' args of 30 | Left rr -> show rr `shouldContain` ins 31 | Right r -> expectationFailure ("Should have errored, received this instead: " <> show r) 32 | it "should error with invalid arguments" $ do 33 | checkError [] "Expects at least two hashes" 34 | checkError [PNumber 1] "Expects at least two hashes" 35 | checkError [PBoolean True] "Expects at least two hashes" 36 | checkError ["foo"] "Expects at least two hashes" 37 | it "should handle empty hashes" $ do 38 | check [[], []] [] 39 | check [[], [], []] [] 40 | it "should merge hashes" $ do 41 | check [[("key", "value")], []] [("key", "value")] 42 | check [[], [("key", "value")]] [("key", "value")] 43 | check [[("key1", "value1")], [("key2", "value2")], [("key3", "value3")]] [("key1", "value1"), ("key2", "value2"), ("key3", "value3")] 44 | check [[("key", "value1")], [("key", "value2")]] [("key", "value2")] 45 | 46 | spec1 :: Spec 47 | spec1 = 48 | describe "deep_merge" $ 49 | withStdlibFunction "deep_merge" $ \mergeFunc -> do 50 | let evalArgs' = evalArgs . mergeFunc 51 | let check args res = case evalArgs' (map PHash args) of 52 | Left rr -> expectationFailure (show rr) 53 | Right res' -> res' `shouldBe` res 54 | checkError args ins = case evalArgs' args of 55 | Left rr -> show rr `shouldContain` ins 56 | Right r -> expectationFailure ("Should have errored, received this instead: " <> show r) 57 | 58 | it "should error with invalid arguments" $ do 59 | checkError [] "Expects at least two hashes" 60 | checkError [PNumber 1] "Expects at least two hashes" 61 | checkError [PBoolean True] "Expects at least two hashes" 62 | checkError ["foo"] "Expects at least two hashes" 63 | it "should handle empty hashes" $ do 64 | check [[], []] [] 65 | check [[], [], []] [] 66 | it "should deeply merge hashes" $ do 67 | check [[("key", "value")], []] [("key", "value")] 68 | check [[], [("key", "value")]] [("key", "value")] 69 | check 70 | [ [("key1", "value1")], 71 | [("key2", "value2")], 72 | [("key3", "value3")] 73 | ] 74 | [("key1", "value1"), ("key2", "value2"), ("key3", "value3")] 75 | check 76 | [ [("key", "value1")], 77 | [("key", "value2")] 78 | ] 79 | [("key", "value2")] 80 | check 81 | [ [("key", PHash [("key00", "value00")])], 82 | [("key", PHash [("key01", "value01")])] 83 | ] 84 | [("key", PHash [("key01", PString "value01"), ("key00", PString "value00")])] 85 | check 86 | [ [("key", PHash [("key01", "value00")])], 87 | [("key", PHash [("key01", "value01")])] 88 | ] 89 | [("key", PHash [("key01", PString "value01")])] 90 | -------------------------------------------------------------------------------- /tests/Interpreter/Function/PrefixSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Interpreter.Function.PrefixSpec (spec, main) where 4 | 5 | import qualified Data.Text as T 6 | import Helpers 7 | 8 | main :: IO () 9 | main = hspec spec 10 | 11 | fname :: Text 12 | fname = "prefix" 13 | 14 | spec :: Spec 15 | spec = withStdlibFunction fname $ \tester -> do 16 | let checkError input expectederror = 17 | case dummyEval (tester input) of 18 | Left rr -> show (getError rr) `shouldStartWith` (T.unpack fname ++ ": " ++ expectederror) 19 | Right _ -> expectationFailure "should have failed" 20 | checkSuccess input expected = 21 | case dummyEval (tester input) of 22 | Left rr -> expectationFailure (show rr) 23 | Right r -> r `shouldBe` expected 24 | it "should fail with no argument" (checkError [] "expects two arguments") 25 | it "should fail if the first argument isn't an array or hash" (checkError ["lol"] "expects the first argument to be an array or a hash") 26 | it "should fail if the second argument isn't a string" $ do 27 | checkError [PArray [], PNumber 1] "expects the second argument to be a string" 28 | checkError [PArray [], PArray []] "expects the second argument to be a string" 29 | it "should work with arrays" $ do 30 | checkSuccess [PArray []] (PArray []) 31 | checkSuccess [PArray [], ""] (PArray []) 32 | checkSuccess [PArray ["one"], "pre"] (PArray ["preone"]) 33 | checkSuccess [PArray ["one", "two", "three"], "pre"] (PArray ["preone", "pretwo", "prethree"]) 34 | it "should work with hashes" $ do 35 | checkSuccess [PHash mempty] (PHash mempty) 36 | checkSuccess [PHash mempty, ""] (PHash mempty) 37 | checkSuccess [PHash [("one", PNumber 5)], "pre"] (PHash [("preone", PNumber 5)]) 38 | checkSuccess [PHash [("one", PNumber 5), ("two", "lol"), ("three", PNumber 7)], "pre"] (PHash [("preone", PNumber 5), ("pretwo", "lol"), ("prethree", PNumber 7)]) 39 | -------------------------------------------------------------------------------- /tests/Interpreter/Function/ShellquoteSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Interpreter.Function.ShellquoteSpec (spec, main) where 4 | 5 | import Helpers 6 | 7 | main :: IO () 8 | main = hspec spec 9 | 10 | check :: [Expression] -> Text -> Expectation 11 | check = checkExprsSuccess "shellquote" 12 | 13 | spec :: Spec 14 | spec = do 15 | it "should handle no arguments" (check [] "") 16 | it "should handle array arguments" $ 17 | check 18 | ["foo", ["bar@example.com", "localhost:/dev/null"], "xyzzy+-4711,23"] 19 | "foo bar@example.com localhost:/dev/null xyzzy+-4711,23" 20 | it "should quote unsafe characters" $ 21 | check 22 | ["/etc/passwd ", "(ls)", "*", "[?]", "'&'"] 23 | "\"/etc/passwd \" \"(ls)\" \"*\" \"[?]\" \"'&'\"" 24 | it "should deal with double quotes" $ 25 | check 26 | ["\"foo\"bar\""] 27 | "'\"foo\"bar\"'" 28 | it "should cope with dollar signs" $ 29 | check 30 | ["$PATH", "foo$bar", "\"x$\""] 31 | "'$PATH' 'foo$bar' '\"x$\"'" 32 | it "should deal with apostrophes (single quotes)" $ 33 | check 34 | ["'foo'bar'", "`$'EDITOR'`"] 35 | "\"'foo'bar'\" \"\\`\\$'EDITOR'\\`\"" 36 | it "should cope with grave accents (backquotes)" $ 37 | check 38 | ["`echo *`", "`ls \"$MAILPATH\"`"] 39 | "'`echo *`' '`ls \"$MAILPATH\"`'" 40 | it "should deal with both single and double quotes" $ 41 | check 42 | ["'foo\"bar\"xyzzy'", "\"foo'bar'xyzzy\""] 43 | "\"'foo\\\"bar\\\"xyzzy'\" \"\\\"foo'bar'xyzzy\\\"\"" 44 | it "should handle multiple quotes *and* dollars and backquotes" $ 45 | check 46 | ["'foo\"$x`bar`\"xyzzy'"] 47 | "\"'foo\\\"\\$x\\`bar\\`\\\"xyzzy'\"" 48 | it "should handle linefeeds" $ 49 | check 50 | ["foo \n bar"] 51 | "\"foo \n bar\"" 52 | -------------------------------------------------------------------------------- /tests/Interpreter/Function/SizeSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Interpreter.Function.SizeSpec (spec, main) where 4 | 5 | import Helpers 6 | 7 | main :: IO () 8 | main = hspec spec 9 | 10 | evalArgs :: InterpreterMonad PValue -> Either PrettyError Scientific 11 | evalArgs = 12 | dummyEval 13 | >=> \pv -> case pv of 14 | PNumber s -> return s 15 | _ -> Left ("Expected a string, not " <> PrettyError (pretty pv)) 16 | 17 | spec :: Spec 18 | spec = withStdlibFunction "size" $ \sizeFunc -> do 19 | let evalArgs' = evalArgs . sizeFunc 20 | let check args res = case evalArgs' args of 21 | Left rr -> expectationFailure (show rr) 22 | Right res' -> res' `shouldBe` res 23 | checkError args ins = case evalArgs' args of 24 | Left rr -> show rr `shouldContain` ins 25 | Right r -> expectationFailure ("Should have errored, received this instead: " <> show r) 26 | it "should error with no arguments" (checkError [] "a single argument") 27 | it "should error with numerical arguments" (checkError [PNumber 1] "size(): Expects ") 28 | it "should error with boolean arguments" (checkError [PBoolean True] "size(): Expects ") 29 | -- Not conformant: 30 | -- it "should error with numerical arguments" (checkError ["1"] "size(): Expects ") 31 | it "should handle arrays" $ do 32 | check [PArray []] 0 33 | check [PArray ["a"]] 1 34 | check [PArray ["one", "two", "three"]] 3 35 | check [PArray ["one", "two", "three", "four"]] 4 36 | it "should handle hashes" $ do 37 | check [PHash []] 0 38 | check [PHash [("1", "2")]] 1 39 | check [PHash [("1", "2"), ("3", "4")]] 2 40 | it "should handle strings" $ do 41 | check [""] 0 42 | check ["a"] 1 43 | check ["ab"] 2 44 | check ["abcd"] 4 45 | -------------------------------------------------------------------------------- /tests/Interpreter/Function/SprintfSpec.hs: -------------------------------------------------------------------------------- 1 | module Interpreter.Function.SprintfSpec (spec, main) where 2 | 3 | import Helpers 4 | 5 | main :: IO () 6 | main = hspec spec 7 | 8 | fname = "sprintf" 9 | 10 | checkSuccess :: [Expression] -> Text -> Expectation 11 | checkSuccess = checkExprsSuccess fname 12 | 13 | checkError :: [Expression] -> String -> Expectation 14 | checkError = checkExprsError fname 15 | 16 | spec :: Spec 17 | spec = do 18 | it "should fail with no argument" (checkError [] "Expects a string as its first argument") 19 | it "should succeed with one argument" (checkSuccess ["hello"] "hello") -- puppet sprintf accepts one arg 20 | it "should work with multiple arguments" (checkSuccess ["hello %s %s", "world", "!"] "hello world !") 21 | it "should work with one string argument" (checkSuccess ["hello %s", "world"] "hello world") 22 | it "should work with one int argument" (checkSuccess ["hello %d", 10] "hello 10") 23 | it "should fail if arg is not provided" (checkError ["hello %s"] "not enough arguments") 24 | it "should fail when a wrong format instruction is used" (checkError ["hello %d", "world"] "Don't know how to convert this to a number") 25 | it "should fail when a wrong format instruction is used" (checkError ["hello %f", "world"] "Don't know how to convert this to a number") 26 | it "should work with one int argument" (checkSuccess ["hello %f", 1.0] "hello 1.0") 27 | it "should work with one int argument" (checkSuccess ["hello %.1f", 1.23] "hello 1.2") 28 | it "should pad with zeroes" (checkSuccess ["hello %03d", 10] "hello 010") 29 | it "should pad with spaces" (checkSuccess ["hello % 3d", 10] "hello 10") 30 | it "should format integers" (checkSuccess ["%+05d", 23] "+0023") 31 | it "should format floats" (checkSuccess ["%+.2f", 2.7182818284590451] "+2.72") 32 | it "should format large floats" (pendingWith "Minor formatting difference" >> checkSuccess ["%+.2e", 27182818284590451] "+2.72e+16") 33 | it "should work with " (checkSuccess ["%5d", 5] " 5") 34 | it "should work with 0" (checkSuccess ["%05d", 5] "00005") 35 | it "should work with - " (checkSuccess ["%-5d", 5] "5 ") 36 | it "should work with -0" (checkSuccess ["%-05d", 5] "5 ") 37 | it "should work with + " (checkSuccess ["%+5d", 5] " +5") 38 | it "should work with + 0" (checkSuccess ["%+05d", 5] "+0005") 39 | it "should work with +- " (checkSuccess ["%+-5d", 5] "+5 ") 40 | it "should work with +-0" (checkSuccess ["%+-05d", 5] "+5 ") 41 | it "should perform more complex formatting" (pendingWith "# is not yet supported" >> checkSuccess ["<%.8s:%#5o %#8X (%-8s)>", "overlongstring", 23, 48879, "foo"] "") 42 | -------------------------------------------------------------------------------- /tests/Interpreter/Function/SuffixSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Interpreter.Function.SuffixSpec (spec, main) where 4 | 5 | import qualified Data.Text as T 6 | import Helpers 7 | 8 | main :: IO () 9 | main = hspec spec 10 | 11 | fname :: Text 12 | fname = "suffix" 13 | 14 | spec :: Spec 15 | spec = withStdlibFunction fname $ \tester -> do 16 | let checkError input expectederror = 17 | case dummyEval (tester input) of 18 | Left rr -> show (getError rr) `shouldStartWith` (T.unpack fname ++ ": " ++ expectederror) 19 | Right _ -> expectationFailure "should have failed" 20 | checkSuccess input expected = 21 | case dummyEval (tester input) of 22 | Left rr -> expectationFailure (show rr) 23 | Right r -> r `shouldBe` expected 24 | it "should fail with no argument" (checkError [] "expects two arguments") 25 | it "should fail if the first argument isn't an array or hash" (checkError ["lol"] "expects the first argument to be an array or a hash") 26 | it "should fail if the second argument isn't a string" $ do 27 | checkError [PArray [], PNumber 1] "expects the second argument to be a string" 28 | checkError [PArray [], PArray []] "expects the second argument to be a string" 29 | it "should work with arrays" $ do 30 | checkSuccess [PArray []] (PArray []) 31 | checkSuccess [PArray [], ""] (PArray []) 32 | checkSuccess [PArray ["one"], "post"] (PArray ["onepost"]) 33 | checkSuccess [PArray ["one", "two", "three"], "post"] (PArray ["onepost", "twopost", "threepost"]) 34 | it "should work with hashes" $ do 35 | checkSuccess [PHash mempty] (PHash mempty) 36 | checkSuccess [PHash mempty, ""] (PHash mempty) 37 | checkSuccess [PHash [("one", PNumber 5)], "post"] (PHash [("onepost", PNumber 5)]) 38 | checkSuccess [PHash [("one", PNumber 5), ("two", "lol"), ("three", PNumber 7)], "post"] (PHash [("onepost", PNumber 5), ("twopost", "lol"), ("threepost", PNumber 7)]) 39 | -------------------------------------------------------------------------------- /tests/Interpreter/Function/WithSpec.hs: -------------------------------------------------------------------------------- 1 | module Interpreter.Function.WithSpec where 2 | 3 | import Helpers 4 | 5 | main :: IO () 6 | main = hspec spec 7 | 8 | spec :: Spec 9 | spec = do 10 | let getCatalog x = case pureCatalog x of 11 | Left rr -> fail rr 12 | Right (y, _) -> pure y 13 | describe "should run as" $ do 14 | it "should be callable with an argument" $ 15 | getCatalog "with ( 12 ) |$x| { file {'/f': content => $x; } }" 16 | >>= getResource (RIdentifier "file" "/f") 17 | >>= getAttribute "content" 18 | >>= (`shouldBe` "12") 19 | it "should be callable with two arguments" $ 20 | getCatalog "with ( '/tmp/lal', 12 ) |$f, $x| { file {$f: content => $x; } }" 21 | >>= getResource (RIdentifier "file" "/tmp/lal") 22 | >>= getAttribute "content" 23 | >>= (`shouldBe` "12") 24 | it "should separate scopes scope" $ do 25 | getCatalog "$x='lol' \n with ( 12 ) |$x| { file {'/f': content => $x; } } \n file {'/g': content => $x; }" 26 | >>= getResource (RIdentifier "file" "/f") 27 | >>= getAttribute "content" 28 | >>= (`shouldBe` "12") 29 | getCatalog "$x='lol' \n with ( 12 ) |$x| { file {'/f': content => $x; } } \n file {'/g': content => $x; }" 30 | >>= getResource (RIdentifier "file" "/g") 31 | >>= getAttribute "content" 32 | >>= (`shouldBe` "lol") 33 | it "should work in value mode" $ 34 | getCatalog "$x= with ('a', 'b' ) |$x, $y| { \"${x} and ${y}\" } \n file {'/g': content => $x; }" 35 | >>= getResource (RIdentifier "file" "/g") 36 | >>= getAttribute "content" 37 | >>= (`shouldBe` "a and b") 38 | -------------------------------------------------------------------------------- /tests/Interpreter/IfSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | -- |  Directly ported from puppet specs 4 | module Interpreter.IfSpec (spec) where 5 | 6 | import Control.Lens 7 | import qualified Data.Text as Text 8 | import Helpers 9 | import Test.Hspec 10 | 11 | shouldFail :: [Text] -> Expectation 12 | shouldFail content = 13 | let cat = pureCatalog (Text.unlines content) 14 | in cat `shouldSatisfy` has _Left 15 | 16 | shouldNotFail :: [Text] -> Expectation 17 | shouldNotFail content = 18 | let cat = pureCatalog (Text.unlines content) 19 | in cat `shouldSatisfy` has _Right 20 | 21 | spec :: Spec 22 | spec = do 23 | describe "If" $ do 24 | it "doesn't enter false conditions" $ 25 | shouldNotFail 26 | ["if (false) { fail ':(' }"] 27 | it "enters true conditions" $ 28 | shouldFail 29 | ["if (true) { fail ':(' }"] 30 | it "enters empty string conditions" $ 31 | shouldFail 32 | ["if '' { fail ':(' }"] 33 | it "not (unknown variable) is true" $ 34 | shouldFail 35 | ["if (!$::unknown123) { fail ':(' }"] 36 | -------------------------------------------------------------------------------- /tests/Parser/DT.hs: -------------------------------------------------------------------------------- 1 | module Parser.DT (spec) where 2 | 3 | import GHC.Base (error) 4 | import Helpers 5 | import Puppet.Parser.Internal 6 | import Test.Hspec.Megaparsec 7 | import Text.Megaparsec (parse) 8 | import qualified Text.Regex.PCRE.ByteString.Utils as Regex 9 | 10 | spec :: Spec 11 | spec = do 12 | let parsed s r = it ("accepts " <> toS s) $ parse datatype "?" s `shouldParse` r 13 | failed s = it ("rejects " <> toS s) $ shouldFailOn (parse datatype "?") s 14 | describe "String" $ do 15 | "String" `parsed` UDTString Nothing Nothing 16 | failed "String[]" 17 | failed "String[4,5,6]" 18 | "String[5]" `parsed` UDTString (Just 5) Nothing 19 | "String[5,8]" `parsed` UDTString (Just 5) (Just 8) 20 | "Regexp" `parsed` UDTRegexp Nothing 21 | let foore = case Regex.compile' Regex.compBlank Regex.execBlank "foo" of 22 | Right ok -> ok 23 | Left rr -> error (show rr) 24 | "Regexp[/foo/]" `parsed` UDTRegexp (Just (CompRegex "foo" foore)) 25 | it "accepts variables" $ pendingWith "to be fixed" *> parse datatype "?" "String[$var]" `shouldParse` UDTString (Just 5) Nothing 26 | describe "Stdlib::" $ do 27 | "Stdlib::HTTPUrl" `parsed` UDTData 28 | -------------------------------------------------------------------------------- /tests/Parser/ExprSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Parser.ExprSpec (spec) where 4 | 5 | import Puppet.Parser 6 | import Puppet.Parser.Internal 7 | import Test.Hspec 8 | import Test.Hspec.Megaparsec 9 | import Text.Megaparsec 10 | import XPrelude 11 | 12 | expressions :: [(Text, Expression)] 13 | expressions = 14 | [ ("5 + 3 * 2", 5 + 3 * 2), 15 | ("5+2 == 7", Equal (5 + 2) 7), 16 | ("include(foo::bar)", Terminal (UFunctionCall "include" ["foo::bar"])), 17 | ("fail(('foo'))", Terminal (UFunctionCall "fail" ["foo"])), 18 | ("test(foo,bar)", Terminal (UFunctionCall "test" ["foo", "bar"])), 19 | ("extlib::test()", Terminal (UFunctionCall "extlib::test" [])), 20 | ("extlib::test(fail('foo'))", Terminal (UFunctionCall "extlib::test" [Terminal (UFunctionCall "fail" [Terminal (UString "foo")])])), 21 | ("test(extlib::test())", Terminal (UFunctionCall "test" [Terminal (UFunctionCall "extlib::test" [])])), 22 | ("test ( foo , bar )", Terminal (UFunctionCall "test" ["foo", "bar"])), 23 | ( "$y ? {\ 24 | \ undef => 'undef',\ 25 | \ default => 'default',\ 26 | \ }", 27 | ConditionalValue 28 | (Terminal (UVariableReference "y")) 29 | [ SelectorValue UUndef :!: Terminal (UString "undef"), 30 | SelectorDefault :!: Terminal (UString "default") 31 | ] 32 | ), 33 | ("$x", Terminal (UVariableReference "x")), 34 | ("x($y)", Terminal (UFunctionCall "x" [Terminal (UVariableReference "y")])), 35 | ("\"$\"", Terminal (UInterpolable [Terminal (UString "$")])), 36 | ("\"${x}\"", Terminal (UInterpolable [Terminal (UVariableReference "x")])), 37 | ("$x[ 3 ]", Lookup (Terminal (UVariableReference "x")) (Terminal (UNumber 3))), 38 | ("\"${ os[ 'architecture' ]}\"", Terminal (UInterpolable [Lookup (Terminal (UVariableReference "os")) (Terminal (UString "architecture"))])), 39 | ("\"${facts['os']['architecture']}\"", Terminal (UInterpolable [Lookup (Lookup (Terminal (UVariableReference "facts")) (Terminal (UString "os"))) (Terminal (UString "architecture"))])), 40 | ("\"${x[$y]}\"", Terminal (UInterpolable [Lookup (Terminal (UVariableReference "x")) (Terminal (UVariableReference "y"))])), 41 | ("\"${x($y)}\"", Terminal (UInterpolable [Terminal (UFunctionCall "x" [Terminal (UVariableReference "y")])])), 42 | ( "\"${x($y)}$'\"", 43 | Terminal 44 | ( UInterpolable 45 | [ Terminal (UFunctionCall "x" [Terminal (UVariableReference "y")]), 46 | Terminal (UString "$"), 47 | Terminal (UString "'") 48 | ] 49 | ) 50 | ) 51 | ] 52 | 53 | invalid :: [Text] 54 | invalid = 55 | [ "$os['name]", 56 | -- pending 57 | -- , "$os ['name']" 58 | -- interpolation 59 | "\"${os['name]}\"", 60 | "\"${os[name}\"", 61 | "\"${os[name]\"" 62 | ] 63 | 64 | testExpression (t, e) = it ("should parse " <> toS t) $ parse (expression <* eof) "" t `shouldParse` e 65 | 66 | testInvalid s = it ("rejects " <> toS s) $ shouldFailOn (parse (expression <* eof) "") s 67 | 68 | spec = do 69 | describe "Expression parser" $ mapM_ testExpression expressions 70 | describe "Invalid expression" $ mapM_ testInvalid invalid 71 | -------------------------------------------------------------------------------- /tests/Parser/LexerSpec.hs: -------------------------------------------------------------------------------- 1 | module Parser.LexerSpec (spec) where 2 | 3 | import Puppet.Parser 4 | import Puppet.Parser.Internal 5 | import System.FilePath.Glob 6 | import Test.Hspec 7 | import Test.Hspec.Megaparsec 8 | import Text.Megaparsec (eof, parse) 9 | import XPrelude 10 | 11 | validFiles = do 12 | files <- runIO $ globDir1 (compile "*.pp") "tests/Parser/lexer" 13 | mapM_ test files 14 | where 15 | test fp = do 16 | r <- runIO $ fmap check (readFile fp) 17 | it ("should parse " <> fp) r 18 | check i = 19 | parse (puppetParser <* eof) empty `shouldSucceedOn` i 20 | 21 | spec = describe "Lexer" $ do 22 | describe "Valid lexer" validFiles 23 | describe "Invalid lexer" $ do 24 | it "should fail to parse resource reference with a space after the resource type" $ invalid resourceReference "File ['/test']" 25 | xit "should fail if there is a space after the variable name" $ invalid interpolableString "\"${os ['name']}\"" 26 | 27 | -- Utils 28 | invalid p s = parse (p <* eof) mempty `shouldFailOn` s 29 | -------------------------------------------------------------------------------- /tests/Parser/lexer/aliastest.pp: -------------------------------------------------------------------------------- 1 | file { "a file": 2 | path => "/tmp/aliastest", 3 | ensure => file 4 | } 5 | 6 | file { "another": 7 | path => "/tmp/aliastest2", 8 | ensure => file, 9 | require => File["a file"] 10 | } 11 | 12 | file { "a third": 13 | path => "/tmp/aliastest3", 14 | ensure => file, 15 | require => File["/tmp/aliastest"] 16 | } 17 | -------------------------------------------------------------------------------- /tests/Parser/lexer/appendArrowAttribute.pp: -------------------------------------------------------------------------------- 1 | node test { 2 | user { 'jenkins': 3 | groups => "docker" 4 | } 5 | User <| title == 'jenkins' |> { groups +> "dockerroot" } 6 | } 7 | -------------------------------------------------------------------------------- /tests/Parser/lexer/argumentdefaults.pp: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | define testargs($file, $mode = 755) { 4 | file { $file: ensure => file, mode => $mode } 5 | } 6 | 7 | testargs { "testingname": 8 | file => "/tmp/argumenttest1" 9 | } 10 | 11 | testargs { "testingother": 12 | file => "/tmp/argumenttest2", 13 | mode => 644 14 | } 15 | -------------------------------------------------------------------------------- /tests/Parser/lexer/arithmeticexpression.pp: -------------------------------------------------------------------------------- 1 | 2 | $one = 1.30 3 | $two = 2.034e-2 4 | 5 | $result = ((( $two + 2) / $one) + 4 * 5.45) - (6 << 7) + (0x800 + -9) 6 | 7 | 8 | notice("result is $result == 1295.87692307692") 9 | -------------------------------------------------------------------------------- /tests/Parser/lexer/arraytrailingcomma.pp: -------------------------------------------------------------------------------- 1 | file { 2 | ["/tmp/arraytrailingcomma1","/tmp/arraytrailingcomma2", ]: content => "tmp" 3 | } 4 | -------------------------------------------------------------------------------- /tests/Parser/lexer/assert_types.pp: -------------------------------------------------------------------------------- 1 | if $storage_driver { 2 | if $::osfamily == 'windows' { 3 | assert_type($storage_driver) |$a, $b| { 4 | fail(translate(('Valid values for storage_driver on windows are windowsfilter'))) 5 | } 6 | } else { 7 | assert_type($storage_driver) |$a, $b| { 8 | fail(translate(('Valid values for storage_driver are aufs, devicemapper, btrfs, overlay, overlay2, vfs, zfs.'))) 9 | } 10 | } 11 | } 12 | -------------------------------------------------------------------------------- /tests/Parser/lexer/case143.pp: -------------------------------------------------------------------------------- 1 | $sources_list_content = $_purge['sources.list'] ? { 2 | true => "# Repos managed by puppet.\n", 3 | default => undef, 4 | } 5 | 6 | -------------------------------------------------------------------------------- /tests/Parser/lexer/casestatement.pp: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | $var = "value" 4 | 5 | case $var { 6 | "nope": { 7 | file { "/tmp/fakefile": mode => 644, ensure => file } 8 | } 9 | "value": { 10 | file { "/tmp/existsfile": mode => 755, ensure => file } 11 | } 12 | } 13 | 14 | $ovar = "yayness" 15 | 16 | case $ovar { 17 | "fooness": { 18 | file { "/tmp/nostillexistsfile": mode => 644, ensure => file } 19 | } 20 | "booness", "yayness": { 21 | case $var { 22 | "nep": { 23 | file { "/tmp/noexistsfile": mode => 644, ensure => file } 24 | } 25 | "value": { 26 | file { "/tmp/existsfile2": mode => 755, ensure => file } 27 | } 28 | } 29 | } 30 | } 31 | 32 | case $ovar { 33 | "fooness": { 34 | file { "/tmp/nostillexistsfile": mode => 644, ensure => file } 35 | } 36 | default: { 37 | file { "/tmp/existsfile3": mode => 755, ensure => file } 38 | } 39 | } 40 | 41 | $bool = true 42 | 43 | case $bool { 44 | true: { 45 | file { "/tmp/existsfile4": mode => 755, ensure => file } 46 | } 47 | } 48 | 49 | $yay = yay 50 | $a = yay 51 | $b = boo 52 | 53 | case $yay { 54 | $a: { file { "/tmp/existsfile5": mode => 755, ensure => file } } 55 | $b: { file { "/tmp/existsfile5": mode => 644, ensure => file } } 56 | default: { file { "/tmp/existsfile5": mode => 711, ensure => file } } 57 | 58 | } 59 | 60 | $regexvar = "exists regex" 61 | case $regexvar { 62 | "no match": { file { "/tmp/existsfile6": mode => 644, ensure => file } } 63 | /(.*) regex$/: { file { "/tmp/${1}file6": mode => 755, ensure => file } } 64 | default: { file { "/tmp/existsfile6": mode => 711, ensure => file } } 65 | } 66 | -------------------------------------------------------------------------------- /tests/Parser/lexer/classheirarchy.pp: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | class base { 4 | file { "/tmp/classheir1": ensure => file, mode => 755 } 5 | } 6 | 7 | class sub1 inherits base { 8 | file { "/tmp/classheir2": ensure => file, mode => 755 } 9 | } 10 | 11 | class sub2 inherits base { 12 | file { "/tmp/classheir3": ensure => file, mode => 755 } 13 | } 14 | 15 | include sub1, sub2 16 | -------------------------------------------------------------------------------- /tests/Parser/lexer/classpathtest.pp: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | define mytype { 4 | file { "/tmp/classtest": ensure => file, mode => 755 } 5 | } 6 | 7 | class testing { 8 | mytype { "componentname": } 9 | } 10 | 11 | include testing 12 | -------------------------------------------------------------------------------- /tests/Parser/lexer/collection.pp: -------------------------------------------------------------------------------- 1 | class one { 2 | @file { "/tmp/colltest1": content => "one" } 3 | @file { "/tmp/colltest2": content => "two" } 4 | } 5 | 6 | class two { 7 | File <| content == "one" |> 8 | } 9 | 10 | include one, two 11 | -------------------------------------------------------------------------------- /tests/Parser/lexer/collection_override.pp: -------------------------------------------------------------------------------- 1 | @file { 2 | "/tmp/collection": 3 | content => "whatever" 4 | } 5 | 6 | File<| |> { 7 | mode => 0600 8 | } 9 | -------------------------------------------------------------------------------- /tests/Parser/lexer/collection_within_virtual_definitions.pp: -------------------------------------------------------------------------------- 1 | define test($name) { 2 | file {"/tmp/collection_within_virtual_definitions1_$name.txt": 3 | content => "File name $name\n" 4 | } 5 | Test2 <||> 6 | } 7 | 8 | define test2() { 9 | file {"/tmp/collection_within_virtual_definitions2_$name.txt": 10 | content => "This is a test\n" 11 | } 12 | } 13 | 14 | node default { 15 | @test {"foo": 16 | name => "foo" 17 | } 18 | @test2 {"foo2": } 19 | Test <||> 20 | } 21 | -------------------------------------------------------------------------------- /tests/Parser/lexer/componentmetaparams.pp: -------------------------------------------------------------------------------- 1 | file { "/tmp/component1": 2 | ensure => file 3 | } 4 | 5 | define thing { 6 | file { $name: ensure => file } 7 | } 8 | 9 | thing { "/tmp/component2": 10 | require => File["/tmp/component1"] 11 | } 12 | -------------------------------------------------------------------------------- /tests/Parser/lexer/componentrequire.pp: -------------------------------------------------------------------------------- 1 | define testfile($mode) { 2 | file { $name: mode => $mode, ensure => present } 3 | } 4 | 5 | testfile { "/tmp/testing_component_requires2": mode => 755 } 6 | 7 | file { "/tmp/testing_component_requires1": mode => 755, ensure => present, 8 | require => Testfile["/tmp/testing_component_requires2"] } 9 | -------------------------------------------------------------------------------- /tests/Parser/lexer/conversions.pp: -------------------------------------------------------------------------------- 1 | $a_number = Integer("0xFF", 16) # results in 255 2 | $a_number = Numeric("010") # results in 8 3 | $a_number = Numeric("010", 10) # results in 10 4 | $a_number = Integer(true) # results in 1 5 | $a_number = Numeric("0x10", 10) # this is an error. Prefix and radix does not match. 6 | 7 | -------------------------------------------------------------------------------- /tests/Parser/lexer/deepclassheirarchy.pp: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | class base { 4 | file { "/tmp/deepclassheir1": ensure => file, mode => 755 } 5 | } 6 | 7 | class sub1 inherits base { 8 | file { "/tmp/deepclassheir2": ensure => file, mode => 755 } 9 | } 10 | 11 | class sub2 inherits sub1 { 12 | file { "/tmp/deepclassheir3": ensure => file, mode => 755 } 13 | } 14 | 15 | class sub3 inherits sub2 { 16 | file { "/tmp/deepclassheir4": ensure => file, mode => 755 } 17 | } 18 | 19 | class sub4 inherits sub3 { 20 | file { "/tmp/deepclassheir5": ensure => file, mode => 755 } 21 | } 22 | 23 | include sub4 24 | -------------------------------------------------------------------------------- /tests/Parser/lexer/defineoverrides.pp: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | $file = "/tmp/defineoverrides1" 4 | 5 | define myfile($mode) { 6 | file { $name: ensure => file, mode => $mode } 7 | } 8 | 9 | class base { 10 | myfile { $file: mode => 644 } 11 | } 12 | 13 | class sub inherits base { 14 | Myfile[$file] { mode => 755, } # test the end-comma 15 | } 16 | 17 | include sub 18 | -------------------------------------------------------------------------------- /tests/Parser/lexer/emptyclass.pp: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | define component { 4 | } 5 | 6 | class testing { 7 | } 8 | 9 | include testing 10 | -------------------------------------------------------------------------------- /tests/Parser/lexer/emptyexec.pp: -------------------------------------------------------------------------------- 1 | exec { "touch /tmp/emptyexectest": 2 | path => "/usr/bin:/bin" 3 | } 4 | -------------------------------------------------------------------------------- /tests/Parser/lexer/falsevalues.pp: -------------------------------------------------------------------------------- 1 | $value = false 2 | 3 | file { "/tmp/falsevalues$value": ensure => file } 4 | -------------------------------------------------------------------------------- /tests/Parser/lexer/filecreate.pp: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | file { 4 | "/tmp/createatest": ensure => file, mode => 755; 5 | "/tmp/createbtest": ensure => file, mode => 755 6 | } 7 | 8 | file { 9 | "/tmp/createctest": ensure => file; 10 | "/tmp/createdtest": ensure => file; 11 | } 12 | -------------------------------------------------------------------------------- /tests/Parser/lexer/fqdefinition.pp: -------------------------------------------------------------------------------- 1 | define one::two($ensure) { 2 | file { "/tmp/fqdefinition": ensure => $ensure } 3 | } 4 | 5 | one::two { "/tmp/fqdefinition": ensure => file } 6 | -------------------------------------------------------------------------------- /tests/Parser/lexer/fqparents.pp: -------------------------------------------------------------------------------- 1 | class base { 2 | class one { 3 | file { "/tmp/fqparent1": ensure => file } 4 | } 5 | } 6 | 7 | class two::three inherits base::one { 8 | file { "/tmp/fqparent2": ensure => file } 9 | } 10 | 11 | include two::three 12 | -------------------------------------------------------------------------------- /tests/Parser/lexer/funccomma.pp: -------------------------------------------------------------------------------- 1 | @file { 2 | ["/tmp/funccomma1","/tmp/funccomma2"]: content => "1" 3 | } 4 | 5 | realize( File["/tmp/funccomma1"], File["/tmp/funccomma2"] , ) 6 | -------------------------------------------------------------------------------- /tests/Parser/lexer/hashindefault.pp: -------------------------------------------------------------------------------- 1 | class bind::master ($testcheck = '', $domains = { "${::domain}" => {} } , $slaves = [], $query_nets = ['10.2.1.0/24'], $forwarders = '') 2 | { 3 | validate_hash($domains) 4 | validate_array($slaves) 5 | validate_array($query_nets) 6 | 7 | include bind 8 | include bind::statichosts 9 | 10 | create_resources('bind::zonefile', $bind::master::domains) 11 | bind::zonefile { 'zone.rev': ; } 12 | 13 | file { 14 | '/etc/bind/named.conf.local': 15 | content => template("bind/master.named.conf.local.erb"), 16 | owner => 'root', 17 | group => 'root', 18 | mode => '644', 19 | require => Package['bind9'], 20 | notify => Service['bind9']; 21 | '/etc/bind/named.conf.options': 22 | content => template("bind/named.conf.options.erb"), 23 | owner => 'root', 24 | group => 'root', 25 | mode => '644', 26 | require => Package['bind9'], 27 | notify => Service['bind9']; 28 | } 29 | 30 | Zone_record<<| |>> 31 | } 32 | 33 | -------------------------------------------------------------------------------- /tests/Parser/lexer/ifexpression.pp: -------------------------------------------------------------------------------- 1 | $one = 1 2 | $two = 2 3 | 4 | if (($one < $two) and (($two < 3) or ($two == 2))) { 5 | notice("True!") 6 | } 7 | 8 | if ("test regex" =~ /(.*) regex/) { 9 | file { 10 | "/tmp/${1}iftest": ensure => file, mode => 0755 11 | } 12 | } 13 | -------------------------------------------------------------------------------- /tests/Parser/lexer/ifupdown.pp: -------------------------------------------------------------------------------- 1 | node 'test' { 2 | ifupdown_route { 'other': vlans => ['8','11']; } 3 | } 4 | -------------------------------------------------------------------------------- /tests/Parser/lexer/implicititeration.pp: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | $files = ["/tmp/iterationatest", "/tmp/iterationbtest"] 4 | 5 | file { $files: ensure => file, mode => 755 } 6 | 7 | file { ["/tmp/iterationctest", "/tmp/iterationdtest"]: 8 | ensure => file, 9 | mode => 755 10 | } 11 | 12 | file { 13 | ["/tmp/iterationetest", "/tmp/iterationftest"]: ensure => file, mode => 755; 14 | ["/tmp/iterationgtest", "/tmp/iterationhtest"]: ensure => file, mode => 755; 15 | } 16 | -------------------------------------------------------------------------------- /tests/Parser/lexer/include.pp: -------------------------------------------------------------------------------- 1 | include ::java::params 2 | include java::params 3 | -------------------------------------------------------------------------------- /tests/Parser/lexer/interpolableindexing.pp: -------------------------------------------------------------------------------- 1 | 2 | $v = "a${x}" 3 | $w = "a${y[10]}" 4 | 5 | -------------------------------------------------------------------------------- /tests/Parser/lexer/lambda.pp: -------------------------------------------------------------------------------- 1 | $binaries = ["facter", "hiera", "mco", "puppet", "puppetserver"] 2 | 3 | $binaries.each | $binary | { 4 | file {"/usr/bin/$binary": 5 | ensure => link, 6 | target => "/opt/puppetlabs/bin/$binary", 7 | } 8 | } 9 | 10 | each($binaries) |$binary| { 11 | file {"/usr/bin/$binary": 12 | ensure => link, 13 | target => "/opt/puppetlabs/bin/$binary", 14 | } 15 | } 16 | 17 | $entries = {} 18 | $entries.each | String $e_name, Hash $e_params | { 19 | limits::limits { $e_name: 20 | * => $e_params, 21 | } 22 | } 23 | -------------------------------------------------------------------------------- /tests/Parser/lexer/multilinecomments.pp: -------------------------------------------------------------------------------- 1 | 2 | /* 3 | file { 4 | "/tmp/multilinecomments": content => "pouet" 5 | } 6 | */ 7 | 8 | /* and another one for #2333, the whitespace after the 9 | end comment is here on purpose */ 10 | 11 | -------------------------------------------------------------------------------- /tests/Parser/lexer/multilookup.pp: -------------------------------------------------------------------------------- 1 | $a = $b[1][2][3] 2 | -------------------------------------------------------------------------------- /tests/Parser/lexer/multipleclass.pp: -------------------------------------------------------------------------------- 1 | class one { 2 | file { "/tmp/multipleclassone": content => "one" } 3 | } 4 | 5 | class one { 6 | file { "/tmp/multipleclasstwo": content => "two" } 7 | } 8 | 9 | include one 10 | -------------------------------------------------------------------------------- /tests/Parser/lexer/multipleinstances.pp: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | file { 4 | "/tmp/multipleinstancesa": ensure => file, mode => 755; 5 | "/tmp/multipleinstancesb": ensure => file, mode => 755; 6 | "/tmp/multipleinstancesc": ensure => file, mode => 755; 7 | } 8 | -------------------------------------------------------------------------------- /tests/Parser/lexer/multisubs.pp: -------------------------------------------------------------------------------- 1 | class base { 2 | file { "/tmp/multisubtest": content => "base", mode => 644 } 3 | } 4 | 5 | class sub1 inherits base { 6 | File["/tmp/multisubtest"] { mode => 755 } 7 | } 8 | 9 | class sub2 inherits base { 10 | File["/tmp/multisubtest"] { content => sub2 } 11 | } 12 | 13 | include sub1, sub2 14 | -------------------------------------------------------------------------------- /tests/Parser/lexer/namevartest.pp: -------------------------------------------------------------------------------- 1 | define filetest($mode, $ensure = file) { 2 | file { $name: 3 | mode => $mode, 4 | ensure => $ensure 5 | } 6 | } 7 | 8 | filetest { "/tmp/testfiletest": mode => 644} 9 | filetest { "/tmp/testdirtest": mode => 755, ensure => directory} 10 | -------------------------------------------------------------------------------- /tests/Parser/lexer/nodes.pp: -------------------------------------------------------------------------------- 1 | 2 | node 'www1.example.com', 'www2.example.com', 'www3.example.com' { 3 | include common 4 | include apache, squid 5 | } 6 | 7 | 8 | node /^www\d+$/ { 9 | include common 10 | } 11 | 12 | node 'www1.example.com' inherits 'common' { 13 | include ntp 14 | include apache 15 | include squid 16 | } 17 | -------------------------------------------------------------------------------- /tests/Parser/lexer/rawresref.pp: -------------------------------------------------------------------------------- 1 | class test { 2 | file { 3 | "/etc/udp2log/${name}": 4 | require => Package[udplog]; 5 | } 6 | } 7 | -------------------------------------------------------------------------------- /tests/Parser/lexer/scopetest.pp: -------------------------------------------------------------------------------- 1 | 2 | $mode = 640 3 | 4 | define thing { 5 | file { "/tmp/$name": ensure => file, mode => $mode } 6 | } 7 | 8 | class testing { 9 | $mode = 755 10 | thing {scopetest: } 11 | } 12 | 13 | include testing 14 | -------------------------------------------------------------------------------- /tests/Parser/lexer/selectorvalues.pp: -------------------------------------------------------------------------------- 1 | $value1 = "" 2 | $value2 = true 3 | $value3 = false 4 | $value4 = yay 5 | 6 | $test = "yay" 7 | 8 | $mode1 = $value1 ? { 9 | "" => 755, 10 | default => 644 11 | } 12 | 13 | $mode2 = $value2 ? { 14 | true => 755, 15 | default => 644 16 | } 17 | 18 | $mode3 = $value3 ? { 19 | false => 755, 20 | default => 644 21 | } 22 | 23 | $mode4 = $value4 ? { 24 | $test => 755, 25 | default => 644 26 | } 27 | 28 | $mode5 = yay ? { 29 | $test => 755, 30 | default => 644 31 | } 32 | 33 | $mode6 = $mode5 ? { 34 | 755 => 755, 35 | -2 => 3 36 | } 37 | 38 | $mode7 = "test regex" ? { 39 | /regex$/ => 755, 40 | default => 644 41 | } 42 | 43 | 44 | file { "/tmp/selectorvalues1": ensure => file, mode => $mode1 } 45 | file { "/tmp/selectorvalues2": ensure => file, mode => $mode2 } 46 | file { "/tmp/selectorvalues3": ensure => file, mode => $mode3 } 47 | file { "/tmp/selectorvalues4": ensure => file, mode => $mode4 } 48 | file { "/tmp/selectorvalues5": ensure => file, mode => $mode5 } 49 | file { "/tmp/selectorvalues6": ensure => file, mode => $mode6 } 50 | file { "/tmp/selectorvalues7": ensure => file, mode => $mode7 } 51 | -------------------------------------------------------------------------------- /tests/Parser/lexer/simpledefaults.pp: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | File { mode => 755 } 4 | 5 | file { "/tmp/defaulttest": ensure => file } 6 | -------------------------------------------------------------------------------- /tests/Parser/lexer/simpleselector.pp: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | /* 3 | $var = "value" 4 | 5 | file { "/tmp/snippetselectatest": 6 | ensure => file, 7 | mode => $var ? { 8 | nottrue => 641, 9 | value => 755 10 | } 11 | } 12 | */ 13 | file { "/tmp/snippetselectbtest": 14 | ensure => file, 15 | mode => $var ? { 16 | nottrue => 644, 17 | default => 755 18 | } 19 | } 20 | /* 21 | $othervar = "complex value" 22 | 23 | file { "/tmp/snippetselectctest": 24 | ensure => file, 25 | mode => $othervar ? { 26 | "complex value" => 755, 27 | default => 644 28 | } 29 | } 30 | $anothervar = Yayness 31 | 32 | file { "/tmp/snippetselectdtest": 33 | ensure => file, 34 | mode => $anothervar ? { 35 | Yayness => 755, 36 | default => 644 37 | } 38 | } 39 | */ 40 | -------------------------------------------------------------------------------- /tests/Parser/lexer/singleary.pp: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | file { "/tmp/singleary1": 4 | ensure => file 5 | } 6 | 7 | file { "/tmp/singleary2": 8 | ensure => file 9 | } 10 | 11 | file { "/tmp/singleary3": 12 | ensure => file, 13 | require => [File["/tmp/singleary1"], File["/tmp/singleary2"]] 14 | } 15 | 16 | file { "/tmp/singleary4": 17 | ensure => file, 18 | require => [File["/tmp/singleary1"]] 19 | } 20 | -------------------------------------------------------------------------------- /tests/Parser/lexer/singlequote.pp: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | file { "/tmp/singlequote1": 4 | ensure => file, 5 | content => 'a $quote' 6 | } 7 | 8 | file { "/tmp/singlequote2": 9 | ensure => file, 10 | content => 'some "\\yayness\"' 11 | } 12 | -------------------------------------------------------------------------------- /tests/Parser/lexer/singleselector.pp: -------------------------------------------------------------------------------- 1 | $value1 = "" 2 | $value2 = true 3 | $value3 = false 4 | $value4 = yay 5 | 6 | $test = "yay" 7 | 8 | $mode1 = $value1 ? { 9 | "" => 755 10 | } 11 | 12 | $mode2 = $value2 ? { 13 | true => 755 14 | } 15 | 16 | $mode3 = $value3 ? { 17 | default => 755 18 | } 19 | 20 | file { "/tmp/singleselector1": ensure => file, mode => $mode1 } 21 | file { "/tmp/singleselector2": ensure => file, mode => $mode2 } 22 | file { "/tmp/singleselector3": ensure => file, mode => $mode3 } 23 | -------------------------------------------------------------------------------- /tests/Parser/lexer/subclass_name_duplication.pp: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env puppet 2 | 3 | class one::fake { 4 | file { "/tmp/subclass_name_duplication1": ensure => present } 5 | } 6 | 7 | class two::fake { 8 | file { "/tmp/subclass_name_duplication2": ensure => present } 9 | } 10 | 11 | include one::fake, two::fake 12 | -------------------------------------------------------------------------------- /tests/Parser/lexer/tagged.pp: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | tag(testing) 4 | tag(funtest) 5 | 6 | class tagdefine { 7 | $path = tagged(tagdefine) ? { 8 | rtrue => "true", rfalse => "false" 9 | } 10 | 11 | file { "/tmp/taggeddefine$path": ensure => file } 12 | } 13 | 14 | include tagdefine 15 | 16 | $yayness = tagged(yayness) ? { 17 | true => "true", false => "false" 18 | } 19 | 20 | $funtest = tagged(testing) ? { 21 | true => "true", false => "false" 22 | } 23 | 24 | $both = tagged(testing, yayness) ? { 25 | true => "true", false => "false" 26 | } 27 | 28 | $bothtrue = tagged(testing, testing) ? { 29 | true => "true", false => "false" 30 | } 31 | 32 | file { "/tmp/taggedyayness$yayness": ensure => file } 33 | file { "/tmp/taggedtesting$funtest": ensure => file } 34 | file { "/tmp/taggedboth$both": ensure => file } 35 | file { "/tmp/taggedbothtrue$bothtrue": ensure => file } 36 | -------------------------------------------------------------------------------- /tests/Parser/lexer/tricky_wikimedia_1.pp: -------------------------------------------------------------------------------- 1 | define create_pkcs12( $certname="$name", $cert_alias="", $password="", $user="root", $group="ssl-cert", $location="/etc/ssl/private" ) { 2 | 3 | if ( $cert_alias == "" ) { 4 | $certalias = $certname 5 | } else { 6 | $certalias = $cert_alias 7 | } 8 | 9 | if ( $password == "" ) { 10 | $defaultpassword = $passwords::certs::certs_default_pass 11 | } else { 12 | $defaultpassword = $password 13 | } 14 | 15 | exec { 16 | # pkcs12 file, used by things like opendj, nss, and tomcat 17 | "${name}_create_pkcs12": 18 | creates => "${location}/${certname}.p12", 19 | command => "/usr/bin/openssl pkcs12 -export -name \"${certalias}\" -passout pass:${defaultpassword} -in /etc/ssl/certs/${certname}.pem -inkey /etc/ssl/private/${certname}.key -out ${location}/${certname}.p12", 20 | require => [Package["openssl"], File["/etc/ssl/private/${certname}.key", "/etc/ssl/certs/${certname}.pem"]]; 21 | } 22 | 23 | file { 24 | # Fix permissions on the p12 file, and make it available as 25 | # a puppet resource 26 | "${location}/${certname}.p12": 27 | mode => 0440, 28 | owner => $user, 29 | group => $group, 30 | require => Exec["${name}_create_pkcs12"], 31 | ensure => file; 32 | } 33 | } 34 | -------------------------------------------------------------------------------- /tests/Parser/lexer/varassignment.pp: -------------------------------------------------------------------------------- 1 | # $Id$ 2 | 3 | $a = 0 4 | 5 | $a = { 6 | c => 1, 7 | d => $x 8 | } 9 | 10 | $a = { 11 | c => { 12 | d => 1 13 | } 14 | } 15 | 16 | $a = $b = 0 17 | 18 | $a = $b = { 19 | c => 1, 20 | d => $x 21 | } 22 | 23 | $a = $b = { 24 | c => { 25 | d => 1 26 | } 27 | } 28 | 29 | $a = $b == 0 30 | -------------------------------------------------------------------------------- /tests/Parser/lexer/virtualresources.pp: -------------------------------------------------------------------------------- 1 | class one { 2 | @file { "/tmp/virtualtest1": content => "one" } 3 | @file { "/tmp/virtualtest2": content => "two" } 4 | @file { "/tmp/virtualtest3": content => "three" } 5 | @file { "/tmp/virtualtest4": content => "four" } 6 | } 7 | 8 | class two { 9 | File <| content == "one" |> 10 | realize(File["/tmp/virtualtest2"]) 11 | realize(File["/tmp/virtualtest3"], File["/tmp/virtualtest4"]) 12 | } 13 | 14 | include one, two 15 | -------------------------------------------------------------------------------- /tests/Parser/lexer/wget_double_regexp.pp: -------------------------------------------------------------------------------- 1 | ################################################################################ 2 | # Definition: wget::fetch 3 | # 4 | # This defined type will download files from the internet. You may define a 5 | # web proxy using $http_proxy if necessary. 6 | # 7 | # == Parameters: 8 | # $source_hash: MD5-sum of the content to be downloaded, 9 | # if content exists, but does not match it is removed 10 | # before downloading 11 | # 12 | ################################################################################ 13 | define wget::fetch ( 14 | $destination, 15 | $source = $title, 16 | $source_hash = undef, 17 | $timeout = '0', 18 | $verbose = false, 19 | $redownload = false, 20 | $nocheckcertificate = false, 21 | $no_cookies = false, 22 | $execuser = undef, 23 | $user = undef, 24 | $password = undef, 25 | $headers = undef, 26 | $cache_dir = undef, 27 | $cache_file = undef, 28 | $flags = undef, 29 | $backup = true, 30 | $mode = undef, 31 | $unless = undef, 32 | ) { 33 | 34 | include wget 35 | 36 | # Does $destination end in a slash? If so, treat as a directory 37 | case $destination { 38 | # This is a nasty looking regex but it's simply checking to see if the $destination 39 | # ends in either forward slash "\" (Linux) or backwards slash "/" (Windows) 40 | /^.*\/$/, /^.*\$/: { 41 | $source_split = split($source, '/') # split the URL into arrays, using "/" as a delimiter 42 | $source_filename = $source_split[-1] # take the very last value in the array. this is the filename 43 | $_destination = "${destination}/${source_filename}" 44 | } 45 | default: { 46 | $_destination = $destination 47 | } 48 | } 49 | 50 | $http_proxy_env = $::http_proxy ? { 51 | undef => [], 52 | default => [ "HTTP_PROXY=${::http_proxy}", "http_proxy=${::http_proxy}" ], 53 | } 54 | $https_proxy_env = $::https_proxy ? { 55 | undef => [], 56 | default => [ "HTTPS_PROXY=${::https_proxy}", "https_proxy=${::https_proxy}" ], 57 | } 58 | $password_env = $user ? { 59 | undef => [], 60 | default => [ "WGETRC=${_destination}.wgetrc" ], 61 | } 62 | 63 | # not using stdlib.concat to avoid extra dependency 64 | $environment = split(inline_template('<%= (@http_proxy_env+@https_proxy_env+@password_env).join(\',\') %>'),',') 65 | 66 | $verbose_option = $verbose ? { 67 | true => '--verbose', 68 | false => '--no-verbose' 69 | } 70 | 71 | # Windows exec unless testing requires different syntax 72 | if ($::operatingsystem == 'windows') { 73 | $exec_path = $::path 74 | $unless_test = "cmd.exe /c \"dir ${_destination}\"" 75 | } else { 76 | $exec_path = '/usr/bin:/usr/sbin:/bin:/usr/local/bin:/opt/local/bin:/usr/sfw/bin' 77 | if $unless != undef { 78 | $unless_test = $unless 79 | } 80 | elsif $redownload == true or $cache_dir != undef { 81 | $unless_test = 'test' 82 | } else { 83 | $unless_test = "test -s '${_destination}'" 84 | } 85 | } 86 | 87 | $nocheckcert_option = $nocheckcertificate ? { 88 | true => ' --no-check-certificate', 89 | false => '' 90 | } 91 | 92 | $no_cookies_option = $no_cookies ? { 93 | true => ' --no-cookies', 94 | false => '', 95 | } 96 | 97 | $user_option = $user ? { 98 | undef => '', 99 | default => " --user=${user}", 100 | } 101 | 102 | if $user != undef { 103 | $wgetrc_content = $::operatingsystem ? { 104 | # This is to work around an issue with macports wget and out of date CA cert bundle. This requires 105 | # installing the curl-ca-bundle package like so: 106 | # 107 | # sudo port install curl-ca-bundle 108 | 'Darwin' => "password=${password}\nCA_CERTIFICATE=/opt/local/share/curl/curl-ca-bundle.crt\n", 109 | default => "password=${password}", 110 | } 111 | 112 | file { "${_destination}.wgetrc": 113 | owner => $execuser, 114 | mode => '0600', 115 | content => $wgetrc_content, 116 | before => Exec["wget-${name}"], 117 | schedule => $schedule, 118 | } 119 | } 120 | 121 | $output_option = $cache_dir ? { 122 | undef => " --output-document=\"${_destination}\"", 123 | default => " -N -P \"${cache_dir}\"", 124 | } 125 | 126 | # again, not using stdlib.concat, concatanate array of headers into a single string 127 | if $headers != undef { 128 | $headers_all = inline_template('<% @headers.each do | header | -%> --header "<%= header -%>"<% end -%>') 129 | } 130 | 131 | $header_option = $headers ? { 132 | undef => '', 133 | default => $headers_all, 134 | } 135 | 136 | $flags_joined = $flags ? { 137 | undef => '', 138 | default => inline_template(' <%= @flags.join(" ") %>') 139 | } 140 | 141 | $exec_user = $cache_dir ? { 142 | undef => $execuser, 143 | default => undef, 144 | } 145 | 146 | case $source_hash{ 147 | '', undef: { 148 | $command = "wget ${verbose_option}${nocheckcert_option}${no_cookies_option}${header_option}${user_option}${output_option}${flags_joined} \"${source}\"" 149 | } 150 | default: { 151 | $command = "wget ${verbose_option}${nocheckcert_option}${no_cookies_option}${header_option}${user_option}${output_option}${flags_joined} \"${source}\" && echo '${source_hash} ${_destination}' | md5sum -c --quiet" 152 | } 153 | } 154 | 155 | 156 | 157 | 158 | exec { "wget-${name}": 159 | command => $command, 160 | timeout => $timeout, 161 | unless => $unless_test, 162 | environment => $environment, 163 | user => $exec_user, 164 | path => $exec_path, 165 | require => Class['wget'], 166 | schedule => $schedule, 167 | } 168 | 169 | if $cache_dir != undef { 170 | $cache = $cache_file ? { 171 | undef => inline_template('<%= require \'uri\'; File.basename(URI::parse(@source).path) %>'), 172 | default => $cache_file, 173 | } 174 | file { $_destination: 175 | ensure => file, 176 | source => "${cache_dir}/${cache}", 177 | owner => $execuser, 178 | mode => $mode, 179 | require => Exec["wget-${name}"], 180 | backup => $backup, 181 | schedule => $schedule, 182 | } 183 | } 184 | 185 | # remove destination if source_hash is invalid 186 | if $source_hash != undef { 187 | exec { "wget-source_hash-check-${name}": 188 | command => "test ! -e '${_destination}' || rm ${_destination}", 189 | path => '/usr/bin:/usr/sbin:/bin:/usr/local/bin:/opt/local/bin', 190 | # only remove destination if md5sum does not match $source_hash 191 | unless => "echo '${source_hash} ${_destination}' | md5sum -c --quiet", 192 | notify => Exec["wget-${name}"], 193 | schedule => $schedule, 194 | } 195 | } 196 | } 197 | -------------------------------------------------------------------------------- /tests/PuppetdbSpec.hs: -------------------------------------------------------------------------------- 1 | module PuppetdbSpec (spec) where 2 | 3 | import qualified Data.Text as Text 4 | import PuppetDB 5 | import System.IO.Temp as Temp 6 | import Test.Hspec 7 | import XPrelude 8 | 9 | checkPanicE :: (Show x) => Text -> ExceptT x IO a -> IO a 10 | checkPanicE msg = runExceptT >=> either (panic . ((msg <> " ") <>) . show) return 11 | 12 | fqdn = "node.site.com" 13 | 14 | spec :: SpecWith () 15 | spec = 16 | around (Temp.withSystemTempDirectory "puppetdbtest") $ do 17 | describe "PuppetDB" $ do 18 | it "should save facts" $ \tmpfp -> do 19 | let pdbfile = tmpfp <> "/puppetdb.yaml" 20 | -- generate an empty puppetdb 21 | pdb <- loadTestDB pdbfile >>= unwrapError "While loading a test DB" 22 | -- get some dummy facts 23 | facts <- puppetDBFacts fqdn pdb 24 | -- and add a custom fact 25 | let nfacts = facts & at "customfact" ?~ "MyCustomFactValue" 26 | -- save the facts 27 | checkPanicE "replaceFacts" (replaceFacts pdb [(fqdn, nfacts)]) 28 | checkPanicE "commitDB" (commitDB pdb) 29 | -- check that our custom fact was indeed saved 30 | dblines <- fmap Text.strip . Text.lines <$> readFile pdbfile 31 | dblines `shouldContain` ["customfact: MyCustomFactValue"] 32 | -- initiate a new puppetdbapi 33 | fpdb <- loadTestDB pdbfile >>= unwrapError "loadTestDB" 34 | ffacts <- puppetDBFacts fqdn pdb 35 | ffacts `shouldBe` nfacts 36 | checkPanicE "replaceCatalog" (replaceCatalog fpdb (generateWireCatalog fqdn mempty mempty)) 37 | checkPanicE "commit 2" (commitDB fpdb) 38 | -- check our facts again 39 | fdblines <- (fmap Text.strip . Text.lines) `fmap` readFile pdbfile 40 | fdblines `shouldContain` ["customfact: MyCustomFactValue"] 41 | -------------------------------------------------------------------------------- /tests/Spec.hs: -------------------------------------------------------------------------------- 1 | import qualified ErbSpec 2 | import Helpers 3 | import qualified HieraSpec 4 | import qualified Interpreter.ClassSpec 5 | import qualified Interpreter.CollectorSpec 6 | import qualified Interpreter.EvalSpec 7 | import qualified Interpreter.EvaluateStatementSpec 8 | import qualified Interpreter.Function.AssertPrivateSpec 9 | import qualified Interpreter.Function.DeleteAtSpec 10 | import qualified Interpreter.Function.EachSpec 11 | import qualified Interpreter.Function.JoinKeysToValuesSpec 12 | import qualified Interpreter.Function.LookupSpec 13 | import qualified Interpreter.Function.MergeSpec 14 | import qualified Interpreter.Function.PrefixSpec 15 | import qualified Interpreter.Function.ShellquoteSpec 16 | import qualified Interpreter.Function.SizeSpec 17 | import qualified Interpreter.Function.SprintfSpec 18 | import qualified Interpreter.Function.SuffixSpec 19 | import qualified Interpreter.Function.WithSpec 20 | import qualified Interpreter.IfSpec 21 | import qualified Parser.DT 22 | import qualified Parser.ExprSpec 23 | import qualified Parser.LexerSpec 24 | import qualified PuppetdbSpec 25 | import Test.Hspec 26 | 27 | main :: IO () 28 | main = hspec spec 29 | 30 | spec :: Spec 31 | spec = do 32 | describe "Parser" $ do 33 | describe "Data types" $ do 34 | Parser.DT.spec 35 | Parser.ExprSpec.spec 36 | Parser.LexerSpec.spec 37 | describe "Interpreter" $ do 38 | Interpreter.CollectorSpec.spec 39 | Interpreter.ClassSpec.spec 40 | Interpreter.EvalSpec.spec 41 | Interpreter.IfSpec.spec 42 | Interpreter.EvaluateStatementSpec.spec 43 | describe "stdlib functions" $ do 44 | describe "The assert_private function" Interpreter.Function.AssertPrivateSpec.spec 45 | describe "The join_keys_to_values function" Interpreter.Function.JoinKeysToValuesSpec.spec 46 | describe "The function" Interpreter.Function.MergeSpec.spec 47 | describe "The size function" Interpreter.Function.SizeSpec.spec 48 | describe "The delete_at function" Interpreter.Function.DeleteAtSpec.spec 49 | describe "puppet functions" $ do 50 | describe "The shellquote function" Interpreter.Function.ShellquoteSpec.spec 51 | describe "The sprintf function" Interpreter.Function.SprintfSpec.spec 52 | describe "The each function" Interpreter.Function.EachSpec.spec 53 | describe "The with function" Interpreter.Function.WithSpec.spec 54 | describe "The lookup function" Interpreter.Function.LookupSpec.spec 55 | describe "The suffix function" Interpreter.Function.SuffixSpec.spec 56 | describe "The prefix function" Interpreter.Function.PrefixSpec.spec 57 | ErbSpec.spec 58 | PuppetdbSpec.spec 59 | HieraSpec.spec 60 | -------------------------------------------------------------------------------- /tests/colors: -------------------------------------------------------------------------------- 1 | green 2 | black 3 | red 4 | yellow 5 | blue 6 | magenta 7 | cyan 8 | white 9 | dullgreen 10 | dullblack 11 | dullred 12 | dullyellow 13 | dullblue 14 | dullmagenta 15 | dullcyan 16 | dullwhite 17 | -------------------------------------------------------------------------------- /tests/defaults.yaml: -------------------------------------------------------------------------------- 1 | knownusers: 2 | - nginx 3 | - postgres 4 | - puppet 5 | - root 6 | - syslog 7 | 8 | knowngroups: 9 | - adm 10 | - postgres 11 | - puppet 12 | - root 13 | - syslog 14 | - www-data 15 | 16 | factsdefault: 17 | subgroup: 18 | 19 | factsoverride: 20 | puppetversion: 3.7.5 21 | id: unitesting 22 | fqdn: utesting 23 | os: 24 | architecture: x86_64 25 | osfamily: RedHat 26 | operatingsystem: CentOS 27 | operatingsystemmajrelease: '7' 28 | lsbmajdistrelease: 6 29 | lsbdistid: RH 30 | operatingsystemrelease: '7.1' 31 | kernel: linux 32 | kernelrelease: 3.10.42-1-lts 33 | kernelversion: 2.6.32 34 | kernelmajversion: '2.6.5' 35 | ipaddress: 127.0.0.1 36 | concat_basedir: /tmp 37 | path: /usr/local/sbin:/usr/local/bin:/usr/bin 38 | 39 | ignoredmodules: 40 | - maven 41 | 42 | externalmodules: 43 | - nginx 44 | - postgresql 45 | - docker 46 | 47 | strict: true 48 | 49 | extratests: true 50 | 51 | settings: 52 | confdir: /etc/puppet 53 | -------------------------------------------------------------------------------- /tests/hiera/common.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | http_port: 8080 3 | ntp_servers: ['0.ntp.puppetlabs.com', '1.ntp.puppetlabs.com'] 4 | interp1: "**%{::fqdn}**" 5 | global: 'glob' 6 | users: 7 | pete: 8 | uid: 2000 9 | tom: 10 | uid: 2001 11 | optional_value: ~ 12 | -------------------------------------------------------------------------------- /tests/hiera/hiera-v3.yaml: -------------------------------------------------------------------------------- 1 | :backends: 2 | - "yaml" 3 | - "json" 4 | :logger: "console" 5 | :hierarchy: 6 | - "%{::fqdn}" 7 | - "%{::environment}" 8 | - common 9 | :yaml: 10 | :datadir: . 11 | :json: 12 | :datadir: . 13 | -------------------------------------------------------------------------------- /tests/hiera/hiera-v5.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | version: 5 3 | default: 4 | datadir: data 5 | hierarchy: 6 | - name: "hiera config for unit test" 7 | data_hash: yaml_data 8 | datadir: . 9 | paths: 10 | - "%{::fqdn}.yaml" 11 | - "%{::environment}.yaml" 12 | - name: "Second hierarchy not used for now" 13 | path: 'common.yaml' 14 | -------------------------------------------------------------------------------- /tests/hiera/interpolate/README.md: -------------------------------------------------------------------------------- 1 | This is taken from [https://github.com/puppetlabs/hiera/blob/master/spec/unit/interpolate_spec.rb](the Hiera test suite.) 2 | -------------------------------------------------------------------------------- /tests/hiera/interpolate/config/hiera.yaml: -------------------------------------------------------------------------------- 1 | :backends: 2 | - yaml 3 | 4 | :hierarchy: 5 | - recursive 6 | - niltest 7 | - complex 8 | - empty_%{}inter%{::}polation 9 | - dotted_keys 10 | - weird_keys 11 | - bad_interpolation 12 | 13 | :yaml: 14 | :datadir: '../data' 15 | -------------------------------------------------------------------------------- /tests/hiera/interpolate/config/hiera_iplm_hiera.yaml: -------------------------------------------------------------------------------- 1 | :backends: 2 | - json 3 | 4 | :hierarchy: 5 | - role 6 | - "%{hiera('role')}" 7 | -------------------------------------------------------------------------------- /tests/hiera/interpolate/config/hiera_iplm_hiera_bad.yaml: -------------------------------------------------------------------------------- 1 | :backends: 2 | - yaml 3 | 4 | :hierarchy: 5 | - "%{hiera('role')}" 6 | -------------------------------------------------------------------------------- /tests/hiera/interpolate/data/bad_interpolation.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | quote_mismatch: 'Key delimited with singe quote on one side aand double qoute on the other: %{''the.key"}' 3 | quote_mismatch_arg: 'Arg delimited with singe quote on one side and double qoute on the other: %{hiera(''the.key")}' 4 | non_existing_method: 'The method flubber does not exist: %{flubber("hello")}' 5 | 6 | one_quote: 'Key with only one quote: %{the.''key}' 7 | empty_segment: 'Key with only one quote: %{the..key}' 8 | empty_quoted_segment: 'Key with only one quote: %{the.''''.key}' 9 | partly_quoted_segment: 'Key with only one quote: %{the.''pa''key}' 10 | -------------------------------------------------------------------------------- /tests/hiera/interpolate/data/complex.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | root: 3 | a: 4 | aa: "%{alias('aaa')}" 5 | 6 | aaa: 7 | b: 8 | bb: "%{alias('bbb')}" 9 | 10 | bbb: [ "%{alias('ccc')}" ] 11 | 12 | ccc: text 13 | -------------------------------------------------------------------------------- /tests/hiera/interpolate/data/dotted_keys.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | a.b: '(hiera) a dot b' 3 | a.c.scope: "a dot c: %{'a.b'}" 4 | a.c.hiera: 'a dot c: %{hiera("''a.b''")}' 5 | a.c.scope: "a dot c: %{'a.b'}" 6 | a.c.hiera: 'a dot c: %{hiera("''a.b''")}' 7 | a.c.alias: '%{alias("''a.b''")}' 8 | a: 9 | d: '(hiera) a dot d is a hash entry' 10 | d.x: '(hiera) a dot d.x is a hash entry' 11 | d.z: 12 | g: '(hiera) a dot d.z dot g is a hash entry' 13 | 14 | a.x: 15 | d: '(hiera) a.x dot d is a hash entry' 16 | d.x: '(hiera) a.x dot d.x is a hash entry' 17 | d.z: 18 | g: '(hiera) a.x dot d.z dot g is a hash entry' 19 | 20 | a.e.scope: "a dot e: %{a.d}" 21 | a.e.hiera: "a dot e: %{hiera('a.d')}" 22 | 23 | a.ex.scope: "a dot ex: %{a.'d.x'}" 24 | a.ex.hiera: 'a dot ex: %{hiera("a.''d.x''")}' 25 | 26 | a.xe.scope: "a dot xe: %{'a.x'.d}" 27 | a.xe.hiera: 'a dot xe: %{hiera("''a.x''.d")}' 28 | 29 | a.xm.scope: "a dot xm: %{a.'d.z'.g}" 30 | a.xm.hiera: 'a dot xm: %{hiera("a.''d.z''.g")}' 31 | 32 | a.xx.scope: "a dot xx: %{'a.x'.'d.z'.g}" 33 | a.xx.hiera: 'a dot xx: %{hiera("''a.x''.''d.z''.g")}' 34 | 35 | a.f.scope: "a dot f: %{'a.d'}" 36 | a.f.hiera: 'a dot f: %{hiera("''a.d''")}' 37 | 38 | x.1: '(hiera) x dot 1' 39 | x.2.scope: "x dot 2: %{'x.1'}" 40 | x.2.hiera: 'x dot 2: %{hiera("''x.1''")}' 41 | 42 | key: subkey 43 | ipl_key: '- %{hiera("key.subkey")} -' 44 | -------------------------------------------------------------------------------- /tests/hiera/interpolate/data/empty_interpolation.yaml: -------------------------------------------------------------------------------- 1 | empty_interpolation: 'clown%{}shoe' 2 | escaped_empty_interpolation: 'clown%%{}{shoe}s' 3 | only_empty_interpolation: '%{}' 4 | empty_namespace: '%{::}' 5 | whitespace1: '%{ :: }' 6 | whitespace2: '%{ }' 7 | 8 | quoted_empty_interpolation: 'clown%{""}shoe' 9 | quoted_escaped_empty_interpolation: 'clown%%{""}{shoe}s' 10 | quoted_only_empty_interpolation: '%{""}' 11 | quoted_empty_namespace: '%{"::"}' 12 | quoted_whitespace1: '%{ "::" }' 13 | quoted_whitespace2: '%{ "" }' 14 | -------------------------------------------------------------------------------- /tests/hiera/interpolate/data/frontend.json: -------------------------------------------------------------------------------- 1 | { "foo": "Foo" } -------------------------------------------------------------------------------- /tests/hiera/interpolate/data/niltest.yaml: -------------------------------------------------------------------------------- 1 | niltest: 'Missing key #%{hiera("knotfound")}#. Key with nil #%{hiera("knil")}#' 2 | knil: null 3 | -------------------------------------------------------------------------------- /tests/hiera/interpolate/data/recursive.yaml: -------------------------------------------------------------------------------- 1 | foo: '%{hiera("bar")}' 2 | 3 | bar: '%{hiera("foo")}' 4 | -------------------------------------------------------------------------------- /tests/hiera/interpolate/data/role.json: -------------------------------------------------------------------------------- 1 | { "role": "frontend" } -------------------------------------------------------------------------------- /tests/hiera/interpolate/data/weird_keys.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | 3 | 'a key with whitespace': 'value for a ws key' 4 | ws_key: '%{alias("a key with whitespace")}' 5 | 6 | '#@!&%|§': 'not happy' 7 | angry: '%{alias("#@!&%|§")}' 8 | 9 | '!$\%!': 10 | '#@!&%|§': 'not happy at all' 11 | 12 | very_angry: '%{alias("!$\%!.#@!&%|§")}' 13 | -------------------------------------------------------------------------------- /tests/hiera/misc/config/hiera.yaml: -------------------------------------------------------------------------------- 1 | :backends: 2 | - yaml 3 | 4 | :hierarchy: 5 | - common 6 | 7 | :yaml: 8 | :datadir: '../data' 9 | -------------------------------------------------------------------------------- /tests/hiera/misc/data/common.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | 3 | foo: bar 4 | literal: "%{literal('%')}{SERVER_NAME}" 5 | -------------------------------------------------------------------------------- /tests/hiera/misc/production.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | foo: bar 3 | 4 | -------------------------------------------------------------------------------- /tests/hiera/node.com.json: -------------------------------------------------------------------------------- 1 | { "testnode": 2 | { "1": "**%{::fqdn}**", 3 | "2": "nothing special"}, 4 | "testjson": "ok", 5 | "arraytest": [ "a", "%{::fqdn}", "c"] 6 | } 7 | -------------------------------------------------------------------------------- /tests/hiera/production.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | http_port: 9090 3 | ntp_servers: ['2.ntp.puppetlabs.com', '3.ntp.puppetlabs.com'] 4 | interp1: "**%{::fqdn}**" 5 | users: 6 | bob: 7 | uid: 100 8 | tom: 9 | uid: 12 10 | original: 11 | - a 12 | - b 13 | aliased: "%{alias('original')}" 14 | server: "127.0.0.1:%{lookup('http_port')}" 15 | aliased_lookup: "%{alias('users.bob.uid')}" 16 | --------------------------------------------------------------------------------