packages feed

language-puppet 1.4.6.5 → 1.5.1

raw patch · 87 files changed

+5798/−5270 lines, 87 filesdep +lens-aesondep ~aesondep ~base16-bytestringdep ~bytestringsetup-changed

Dependencies added: lens-aeson

Dependency ranges changed: aeson, base16-bytestring, bytestring, formatting, hashable, hruby, http-api-data, lens, megaparsec, memory, protolude, servant, servant-client, text, vector

Files

README.md view
@@ -47,7 +47,7 @@   - `--node` will display all resources on screen in a nice     user-friendly colored fashion. -  - `--all` displays statitics and optionally shows dead code.+  - `--all` displays statistics and optionally shows dead code.    - `--parse` only goes as far as parsing. No interpretation. @@ -167,7 +167,7 @@ dummy ones). It can be used to:    - export data from production PuppetDB to a file (in order to debug-    some issue with `puppetresources**).+    some issue with `puppetresources`).   - query a Puppetdb  **Command line arguments**
− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
language-puppet.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                language-puppet-version:             1.4.6.5+version:             1.5.1 synopsis:            Tools to parse and evaluate the Puppet DSL. description:         This is a set of tools that is supposed to fill all your Puppet needs : syntax checks, catalog compilation, PuppetDB queries, simulation of complex interactions between nodes, Puppet master replacement, and more ! homepage:            http://lpuppet.banquise.net/@@ -16,7 +16,7 @@ cabal-version:       >=1.10 bug-reports:         https://github.com/bartavelle/language-puppet/issues -Tested-With:         GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1+Tested-With:         GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7  extra-source-files:     CHANGELOG@@ -102,47 +102,48 @@   default-extensions:    OverloadedStrings, BangPatterns, LambdaCase, NoImplicitPrelude, FlexibleContexts, FlexibleInstances   ghc-options:         -Wall -funbox-strict-fields   -- ghc-prof-options:    -auto-all -caf-all-  build-depends:       aeson                >= 1.0.0.0 && < 1.6+  build-depends:       aeson                >= 2.0     && < 2.2                      , ansi-wl-pprint       >= 0.6.8                      , attoparsec           >= 0.12                      , base                 >= 4.9     && < 5-                     , base16-bytestring    == 0.1.*-                     , bytestring                         < 0.11+                     , base16-bytestring    >= 1.0     && < 1.1+                     , bytestring                         < 0.12                      , case-insensitive     == 1.2.*                      , containers           >= 0.5     && < 0.7                      , cryptonite           >= 0.6                      , directory            >= 1.2     && < 1.4                      , filecache            >= 0.2.9   && < 0.5                      , filepath             >= 1.4-                     , formatting                         < 7-                     , hashable             >= 1.2     && < 1.4-                     , http-api-data        >= 0.2     && < 0.5+                     , formatting                         < 8+                     , hashable             >= 1.2     && < 1.5+                     , http-api-data        >= 0.2     && < 0.6                      , http-client          >= 0.4.30  && < 0.8-                     , hruby                >= 0.3.5   && < 0.4+                     , hruby                >= 0.5.1   && < 0.6                      , hslogger             >= 1.2     && < 1.4-                     , lens                 >= 4.12    && < 5-                     , megaparsec           >= 7       && < 9-                     , memory               >= 0.14    && < 0.16+                     , lens                 >= 4.12    && < 6+                     , lens-aeson           >= 1.2+                     , megaparsec           >= 7       && < 10+                     , memory               >= 0.14    && < 0.19                      , mtl                  >= 2.2.1   && < 2.3                      , operational          >= 0.2.3   && < 0.3                      , parsec               == 3.1.*                      , parser-combinators   == 1.*                      , pcre-utils           >= 0.1.7   && < 0.2-                     , protolude            >= 0.2     && < 0.4+                     , protolude            >= 0.3     && < 0.4                      , random                      , regex-pcre-builtin   >= 0.94.4                      , scientific           >= 0.2     && < 0.4-                     , servant              >= 0.9     && < 0.18-                     , servant-client       >= 0.9     && < 0.18+                     , servant              >= 0.9     && < 0.20+                     , servant-client       >= 0.9     && < 0.20                      , split                == 0.2.*                      , stm                  >= 2.4     && < 2.6                      , strict-base-types    >= 0.3-                     , text                 >= 0.11    && < 1.3+                     , text                 >= 0.11    && < 2.1                      , time                 >= 1.5     && < 2                      , transformers         >= 0.4     && < 0.6                      , unix                 >= 2.7     && < 2.8                      , unordered-containers == 0.2.*-                     , vector               >= 0.10    && < 0.13+                     , vector               >= 0.10    && < 0.14                      , yaml                 >= 0.8.31  && < 0.12 Test-Suite spec   hs-source-dirs: tests@@ -158,7 +159,7 @@                   , hspec-megaparsec                   , megaparsec                   , language-puppet-                  , lens                    >= 4.12  && < 5+                  , lens                   , mtl                     >= 2.2.1 && < 2.3                   , scientific              >= 0.2   && < 0.4                   , strict-base-types@@ -199,7 +200,7 @@   hs-source-dirs:      progs   default-extensions:  BangPatterns, OverloadedStrings   default-language:    Haskell2010-  ghc-options:         -Wall -rtsopts -funbox-strict-fields -threaded -with-rtsopts "-A2M" -eventlog+  ghc-options:         -Wall -rtsopts -funbox-strict-fields -threaded -with-rtsopts "-A2M"   -- ghc-prof-options:    -auto-all -caf-all -fprof-auto   other-modules:       Paths_language_puppet   build-depends:       base
progs/PuppetResources.hs view
@@ -1,19 +1,18 @@ {-# LANGUAGE LambdaCase        #-}-{-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE StrictData        #-} {-# LANGUAGE CPP               #-} module Main where -import           XPrelude                      hiding (option, (<>))+import           XPrelude                      hiding ((<>))  import qualified Control.Concurrent.Async      as Async import qualified Data.Aeson                    as Aeson import qualified Data.HashMap.Strict           as Map import qualified Data.HashSet                  as HS import qualified Data.List                     as List-import           Data.Semigroup                as Sem   hiding (option)+import           Data.Semigroup                as Sem import qualified Data.Set                      as Set import qualified Data.Text                     as Text import           Data.Text.Strict.Lens         (unpacked)@@ -32,6 +31,7 @@ import           PuppetDB                      (PuppetDBAPI, dummyPuppetDB, pdbConnect,                                                 puppetDBFacts) import qualified PuppetDB+import Data.Maybe (fromJust)  type QueryFunc = NodeName -> IO (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) @@ -163,15 +163,15 @@                 (Just _, Just _)   -> panic "You must choose between a testing PuppetDB and a remote one"                 (Just url, _)      -> pdbConnect mgr url >>= unwrapError "Error when connecting to the remote PuppetDB"                 (_, Just file)     -> PuppetDB.loadTestDB file >>= unwrapError "Error when initializing the PuppetDB API"-    pref <- dfPreferences workingdir <&> prefPDB .~ pdbapi-                                     <&> prefHieraPath .~ _optHieraFile-                                     <&> prefIgnoredmodules %~ (`fromMaybe` _optIgnoredMods)-                                     <&> (if _optStrictMode then prefStrictness .~ Strict else identity)-                                     <&> (if _optNoExtraTests then prefExtraTests .~ False else identity)-                                     <&> prefLogLevel .~ _optLoglevel-                                     <&> prefRebaseFile .~ _optRebaseFile+    pref <- dfPreferences workingdir <&> (prefPDB .~ pdbapi)+                                       . (prefHieraPath .~ _optHieraFile)+                                       . (prefIgnoredmodules %~ (`fromMaybe` _optIgnoredMods))+                                       . (if _optStrictMode then prefStrictness .~ Strict else identity)+                                       . (if _optNoExtraTests then prefExtraTests .~ False else identity)+                                       . (prefLogLevel .~ _optLoglevel)+                                       . (prefRebaseFile .~ _optRebaseFile)     d <- initDaemon pref-    let queryfunc = \node -> fmap (unifyFacts (pref ^. prefFactsDefault) (pref ^. prefFactsOverride)) (puppetDBFacts node pdbapi) >>= getCatalog d node+    let queryfunc node = puppetDBFacts node pdbapi >>= getCatalog d node . unifyFacts (pref ^. prefFactsDefault) (pref ^. prefFactsOverride)     pure (queryfunc, pdbapi, parserStats d, catalogStats d, templateStats d)     where       -- merge 3 sets of facts : some defaults, the original set and some override@@ -288,15 +288,15 @@       allfiles = Set.fromList $ map Text.unpack $ Map.keys pStats   when _optDeadcode $ findDeadCode workingdir allres allfiles   -- compute statistics-  let (parsing,    Just (wPName, wPMean)) = worstAndSum pStats-      (cataloging, Just (wCName, wCMean)) = worstAndSum cStats-      (templating, Just (wTName, wTMean)) = worstAndSum tStats+  let (parsing,    (wPName, wPMean)) = worstAndSum pStats+      (cataloging, (wCName, wCMean)) = worstAndSum cStats+      (templating, (wTName, wTMean)) = worstAndSum tStats       parserShare = 100 * parsing / cataloging       templateShare = 100 * templating / cataloging       formatDouble = Text.take 5 . show -- yeah, well ...       nbnodes = length topnodes       worstAndSum =   (_1 %~ getSum)-                    . (_2 %~ fmap swap . getMaximum)+                    . (_2 %~ swap . fromJust . getMaximum)                     . ifoldMap (\k (StatsPoint cnt total _ _) -> (Sum total, Maximum $ Just (total / fromIntegral cnt, k)))   putStr ("\nTested " ++ show nbnodes ++ " nodes. ")   unless (nbnodes == 0) $ do@@ -367,7 +367,7 @@   run :: Options -> IO ()-run Options {_optVersion = True, ..} = putStrLn ("language-puppet " ++ Data.Version.showVersion Meta.version)+run Options {_optVersion = True} = putStrLn ("language-puppet " ++ Data.Version.showVersion Meta.version)  -- Parse mode run Options {_optParse = Just fp, ..} = do
progs/pdbQuery.hs view
@@ -92,12 +92,12 @@  showHelpText :: ParserPrefs -> ParserInfo a -> IO () showHelpText pprefs pinfo = handleParseResult . Failure $-  parserFailure pprefs pinfo ShowHelpText mempty+  parserFailure pprefs pinfo (ShowHelpText Nothing) mempty  run :: Options -> IO () run Options {_pdbversion = False, _pdbcmd = Nothing} =   putText "Please provide one of the available command (see --help for more information) " *> exitFailure-run Options {_pdbversion = True, ..} = putStrLn ("language-puppet " ++ Meta.showVersion Meta.version)+run Options {_pdbversion = True} = putStrLn ("language-puppet " ++ Meta.showVersion Meta.version)  run Options{_pdbcmd = Just pdbcmd, ..} = do   mgr <- Http.newManager Http.defaultManagerSettings
progs/yera.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE StrictData        #-} module Main (main) where -import           XPrelude            hiding (option)+import           XPrelude  import qualified Data.HashMap.Strict as Map import qualified Data.List           as List
src/Erb.hs view
@@ -1,9 +1,10 @@ -- | Entry point to general Erb service -- This module share no dependency with Puppet modules-module Erb (-    module Erb.Ruby-  , module Erb.Parser-) where+module Erb+  ( module Erb.Ruby,+    module Erb.Parser,+  )+where -import           Erb.Parser-import           Erb.Ruby+import Erb.Parser+import Erb.Ruby
src/Erb/Parser.hs view
@@ -1,33 +1,31 @@ module Erb.Parser where -import           XPrelude.Extra         hiding (option, try)--import           Control.Exception      (catch)-import qualified Data.Text              as Text-import           Text.Parsec.Char-import           Text.Parsec.Combinator hiding (optional)-import           Text.Parsec.Error-import           Text.Parsec.Expr-import           Text.Parsec.Language   (emptyDef)-import           Text.Parsec.Pos-import           Text.Parsec.Prim       hiding (many, (<|>))-import           Text.Parsec.String-import qualified Text.Parsec.Token      as P--import           Erb.Ruby+import qualified Data.Text as Text+import Erb.Ruby+import Text.Parsec.Char+import Text.Parsec.Combinator hiding (optional)+import Text.Parsec.Error+import Text.Parsec.Expr+import Text.Parsec.Language (emptyDef)+import Text.Parsec.Pos+import Text.Parsec.Prim hiding (many, (<|>))+import Text.Parsec.String+import qualified Text.Parsec.Token as P+import XPrelude.Extra hiding (try)  def :: P.GenLanguageDef String u Identity-def = emptyDef-  { P.commentStart   = "/*"-  , P.commentEnd     = "*/"-  , P.commentLine    = "#"-  , P.nestedComments = True-  , P.identStart     = letter-  , P.identLetter    = alphaNum <|> oneOf "_"-  , P.reservedNames  = ["if", "else", "case", "elsif"]-  , P.reservedOpNames= ["=>","=","+","-","/","*","+>","->","~>","!"]-  , P.caseSensitive  = True-  }+def =+  emptyDef+    { P.commentStart = "/*",+      P.commentEnd = "*/",+      P.commentLine = "#",+      P.nestedComments = True,+      P.identStart = letter,+      P.identLetter = alphaNum <|> oneOf "_",+      P.reservedNames = ["if", "else", "case", "elsif"],+      P.reservedOpNames = ["=>", "=", "+", "-", "/", "*", "+>", "->", "~>", "!"],+      P.caseSensitive = True+    }  lexer :: P.GenTokenParser String u Identity lexer = P.makeTokenParser def@@ -60,34 +58,43 @@ rubyexpression = buildExpressionParser table term <?> "expression"  table :: [[Operator String () Identity Expression]]-table =  [ [ Infix  ( reservedOp "+" >> return PlusOperation        ) AssocLeft-           , Infix  ( reservedOp "-" >> return MinusOperation       ) AssocLeft ]-         , [ Infix  ( reservedOp "/" >> return DivOperation         ) AssocLeft-           , Infix  ( reservedOp "*" >> return MultiplyOperation    ) AssocLeft ]-         , [ Infix  ( reservedOp "<<" >> return ShiftLeftOperation  ) AssocLeft-           , Infix  ( reservedOp ">>" >> return ShiftRightOperation ) AssocLeft ]-         , [ Infix  ( reservedOp "and" >> return AndOperation       ) AssocLeft-           , Infix  ( reservedOp "or" >> return OrOperation         ) AssocLeft ]-         , [ Infix  ( reservedOp "==" >> return EqualOperation      ) AssocLeft-           , Infix  ( reservedOp "!=" >> return DifferentOperation  ) AssocLeft ]-         , [ Infix  ( reservedOp ">" >> return AboveOperation       ) AssocLeft-           , Infix  ( reservedOp ">=" >> return AboveEqualOperation ) AssocLeft-           , Infix  ( reservedOp "<=" >> return UnderEqualOperation ) AssocLeft-           , Infix  ( reservedOp "<" >> return UnderOperation       ) AssocLeft ]-         , [ Infix  ( reservedOp "=~" >> return RegexpOperation     ) AssocLeft-           , Infix  ( reservedOp "!~" >> return NotRegexpOperation  ) AssocLeft ]-         , [ Prefix ( symbol "!" >> return NotOperation             )           ]-         , [ Prefix ( symbol "-" >> return NegOperation             )           ]-         , [ Infix  ( reservedOp "?" >> return ConditionalValue     ) AssocLeft ]-         -- , [ Infix  ( reservedOp "." >> return MethodCall           ) AssocLeft ]-         ]+table =+  [ [ Infix (reservedOp "+" >> return PlusOperation) AssocLeft,+      Infix (reservedOp "-" >> return MinusOperation) AssocLeft+    ],+    [ Infix (reservedOp "/" >> return DivOperation) AssocLeft,+      Infix (reservedOp "*" >> return MultiplyOperation) AssocLeft+    ],+    [ Infix (reservedOp "<<" >> return ShiftLeftOperation) AssocLeft,+      Infix (reservedOp ">>" >> return ShiftRightOperation) AssocLeft+    ],+    [ Infix (reservedOp "and" >> return AndOperation) AssocLeft,+      Infix (reservedOp "or" >> return OrOperation) AssocLeft+    ],+    [ Infix (reservedOp "==" >> return EqualOperation) AssocLeft,+      Infix (reservedOp "!=" >> return DifferentOperation) AssocLeft+    ],+    [ Infix (reservedOp ">" >> return AboveOperation) AssocLeft,+      Infix (reservedOp ">=" >> return AboveEqualOperation) AssocLeft,+      Infix (reservedOp "<=" >> return UnderEqualOperation) AssocLeft,+      Infix (reservedOp "<" >> return UnderOperation) AssocLeft+    ],+    [ Infix (reservedOp "=~" >> return RegexpOperation) AssocLeft,+      Infix (reservedOp "!~" >> return NotRegexpOperation) AssocLeft+    ],+    [Prefix (symbol "!" >> return NotOperation)],+    [Prefix (symbol "-" >> return NegOperation)],+    [Infix (reservedOp "?" >> return ConditionalValue) AssocLeft]+    -- , [ Infix  ( reservedOp "." >> return MethodCall           ) AssocLeft ]+  ]+ term :: Parser Expression term =-      parens rubyexpression-  <|> scopeLookup-  <|> stringLiteral-  <|> objectterm-  <|> variablereference+  parens rubyexpression+    <|> scopeLookup+    <|> stringLiteral+    <|> objectterm+    <|> variablereference  scopeLookup :: Parser Expression scopeLookup = do@@ -121,11 +128,11 @@ objectterm = do   arobase <- optional (char '@')   methodname' <- toS <$> identifier-  let methodname = Value (Literal $ maybe methodname' (\a -> Text.cons a methodname') arobase)+  let methodname = Value (Literal $ maybe methodname' (`Text.cons` methodname') arobase)   lookAhead anyChar >>= \case     '[' -> do-        hr <- many (symbol "[" *> rubyexpression <* symbol "]")-        pure $! foldl LookupOperation (Object methodname) hr+      hr <- many (symbol "[" *> rubyexpression <* symbol "]")+      pure $! foldl LookupOperation (Object methodname) hr     '{' -> fmap (MethodCall methodname . BlockOperation . Text.pack) (braces (many1 $ noneOf "}"))     '(' -> fmap (MethodCall methodname . Value . Array) (parens (rubyexpression `sepBy` symbol ","))     _ -> return $ Object methodname@@ -136,20 +143,21 @@ rubystatement :: Parser RubyStatement rubystatement = fail "statements not supported yet" -textblockW :: Maybe Char ->  Parser [RubyStatement]+textblockW :: Maybe Char -> Parser [RubyStatement] textblockW c = do   s <- many (noneOf "<")   let ns = case c of-        Just x  -> x:s+        Just x -> x : s         Nothing -> s       returned = Puts $ Value $ Literal $ Text.pack ns   optionMaybe eof >>= \case-    Just _  -> return [returned]+    Just _ -> return [returned]     Nothing -> do       void $ char '<'-      n <- optionMaybe (char '%') >>= \case-        Just _  -> rubyblock-        Nothing -> textblockW (Just '<')+      n <-+        optionMaybe (char '%') >>= \case+          Just _ -> rubyblock+          Nothing -> textblockW (Just '<')       pure (returned : n)  textblock :: Parser [RubyStatement]@@ -158,12 +166,13 @@ rubyblock :: Parser [RubyStatement] rubyblock = do   ps <- option [] (char '-' >> return [DropPrevSpace'])-  parsed <- optionMaybe (char '=') >>= \case-    Just _  -> spaces >> fmap (return . Puts) rubyexpression-    Nothing -> spaces >> many1 rubystatement+  parsed <-+    optionMaybe (char '=') >>= \case+      Just _ -> spaces >> fmap (return . Puts) rubyexpression+      Nothing -> spaces >> many1 rubystatement   spaces-  let dn (x:xs) = DropNextSpace x : xs-      dn x      = x+  let dn (x : xs) = DropNextSpace x : xs+      dn x = x   ns <- option identity (char '-' >> return dn)   void $ string "%>"   n <- textblock@@ -177,8 +186,9 @@   parseContent `catch` handler   where     parseContent = (runParser erbparser () fname . Text.unpack) `fmap` readFile fname-    handler e = let msg = show (e :: SomeException)-                in  return $ Left $ newErrorMessage (Message msg) (initialPos fname)+    handler e =+      let msg = show (e :: SomeException)+       in return $ Left $ newErrorMessage (Message msg) (initialPos fname)  parseErbString :: String -> Either ParseError [RubyStatement] parseErbString = runParser erbparser () mempty
src/Erb/Ruby.hs view
@@ -1,57 +1,57 @@ -- | Base types for the internal ruby parser ("Erb.Parser"). module Erb.Ruby where -import           XPrelude+import XPrelude  data Value-    = Literal !Text-    | Interpolable ![Expression]-    | Symbol !Text-    | Array ![Expression]-    deriving (Show, Ord, Eq)+  = Literal !Text+  | Interpolable ![Expression]+  | Symbol !Text+  | Array ![Expression]+  deriving (Show, Ord, Eq)  data Expression-    = LookupOperation !Expression !Expression-    | PlusOperation !Expression !Expression-    | MinusOperation !Expression !Expression-    | DivOperation !Expression !Expression-    | MultiplyOperation !Expression !Expression-    | ShiftLeftOperation !Expression !Expression-    | ShiftRightOperation !Expression !Expression-    | AndOperation !Expression !Expression-    | OrOperation !Expression !Expression-    | EqualOperation !Expression !Expression-    | DifferentOperation !Expression !Expression-    | AboveOperation !Expression !Expression-    | AboveEqualOperation !Expression !Expression-    | UnderEqualOperation !Expression !Expression-    | UnderOperation !Expression !Expression-    | RegexpOperation !Expression !Expression-    | NotRegexpOperation !Expression !Expression-    | NotOperation !Expression-    | NegOperation !Expression-    | ConditionalValue !Expression !Expression-    | Object !Expression-    | ScopeObject !Expression-    | MethodCall !Expression !Expression-    | BlockOperation !Text-    | Value !Value-    | BTrue-    | BFalse-    | Error !String-    deriving (Show, Ord, Eq)+  = LookupOperation !Expression !Expression+  | PlusOperation !Expression !Expression+  | MinusOperation !Expression !Expression+  | DivOperation !Expression !Expression+  | MultiplyOperation !Expression !Expression+  | ShiftLeftOperation !Expression !Expression+  | ShiftRightOperation !Expression !Expression+  | AndOperation !Expression !Expression+  | OrOperation !Expression !Expression+  | EqualOperation !Expression !Expression+  | DifferentOperation !Expression !Expression+  | AboveOperation !Expression !Expression+  | AboveEqualOperation !Expression !Expression+  | UnderEqualOperation !Expression !Expression+  | UnderOperation !Expression !Expression+  | RegexpOperation !Expression !Expression+  | NotRegexpOperation !Expression !Expression+  | NotOperation !Expression+  | NegOperation !Expression+  | ConditionalValue !Expression !Expression+  | Object !Expression+  | ScopeObject !Expression+  | MethodCall !Expression !Expression+  | BlockOperation !Text+  | Value !Value+  | BTrue+  | BFalse+  | Error !String+  deriving (Show, Ord, Eq)  instance Pretty Expression where-    pretty (LookupOperation a b) = pretty a <> brackets (pretty b)-    pretty (PlusOperation a b) = parens (pretty a <+> "+" <+> pretty b)-    pretty (MinusOperation a b) = parens (pretty a <+> "-" <+> pretty b)-    pretty (DivOperation a b) = parens (pretty a <+> "/" <+> pretty b)-    pretty (MultiplyOperation a b) = parens (pretty a <+> "*" <+> pretty b)-    pretty op = ppline (show op)+  pretty (LookupOperation a b) = pretty a <> brackets (pretty b)+  pretty (PlusOperation a b) = parens (pretty a <+> "+" <+> pretty b)+  pretty (MinusOperation a b) = parens (pretty a <+> "-" <+> pretty b)+  pretty (DivOperation a b) = parens (pretty a <+> "/" <+> pretty b)+  pretty (MultiplyOperation a b) = parens (pretty a <+> "*" <+> pretty b)+  pretty op = ppline (show op)  data RubyStatement-    = Puts !Expression-    | DropPrevSpace !RubyStatement-    | DropPrevSpace'-    | DropNextSpace !RubyStatement-    deriving(Show,Eq)+  = Puts !Expression+  | DropPrevSpace !RubyStatement+  | DropPrevSpace'+  | DropNextSpace !RubyStatement+  deriving (Show, Eq)
src/Facter.hs view
@@ -1,33 +1,32 @@ {-# LANGUAGE TemplateHaskell #-}-module Facter where -import           Prelude+module Facter where -import           Control.Lens-import           Data.Aeson-import           Data.Char+import Control.Lens+import Data.Aeson+import Data.Char import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet        as HS-import qualified Data.List           as List-import qualified Data.List.Split     as List-import           Data.Maybe          (mapMaybe)-import           Data.Semigroup-import qualified Data.Text           as T-import qualified System.Directory    as Directory-import           System.Environment-import           System.Posix.Unistd (SystemID (..), getSystemID)-import           System.Posix.User-import           Text.Printf--import           Puppet.Language+import qualified Data.HashSet as HS+import qualified Data.List as List+import qualified Data.List.Split as List+import Data.Maybe (mapMaybe)+import qualified Data.Text as T+import Puppet.Language+import qualified System.Directory as Directory+import System.Environment+import System.Posix.Unistd (SystemID (..), getSystemID)+import System.Posix.User+import Text.Printf+import Prelude  type Facts = HM.HashMap T.Text PValue  data FactInfo = FactInfo-  { _factInfoNodename :: !NodeName-  , _factInfoName     :: !T.Text-  , _factInfoVal      :: !PValue+  { _factInfoNodename :: !NodeName,+    _factInfoName :: !T.Text,+    _factInfoVal :: !PValue   }+ makeClassy ''FactInfo  instance ToJSON FactInfo where@@ -35,155 +34,199 @@  instance FromJSON FactInfo where   parseJSON (Object v) = FactInfo <$> v .: "certname" <*> v .: "name" <*> v .: "value"-  parseJSON _          = fail "invalid fact info"+  parseJSON _ = fail "invalid fact info"  storageunits :: [(String, Int)]-storageunits = [ ("", 0), ("K", 1), ("M", 2), ("G", 3), ("T", 4) ]+storageunits = [("", 0), ("K", 1), ("M", 2), ("G", 3), ("T", 4)]  getPrefix :: Int -> String-getPrefix n | null fltr = error $ "Could not get unit prefix for order " <> show n-            | otherwise = fst $ head fltr-  where fltr = filter (\(_, x) -> x == n) storageunits+getPrefix n+  | null fltr = error $ "Could not get unit prefix for order " <> show n+  | otherwise = fst $ head fltr+  where+    fltr = filter (\(_, x) -> x == n) storageunits  getOrder :: String -> Int-getOrder n | null fltr = error $ "Could not get order for unit prefix " <> show n-           | otherwise = snd $ head fltr+getOrder n+  | null fltr = error $ "Could not get order for unit prefix " <> show n+  | otherwise = snd $ head fltr   where     nu = map toUpper n     fltr = filter (\(x, _) -> x == nu) storageunits  normalizeUnit :: (Double, Int) -> Double -> (Double, Int)-normalizeUnit (unit, order) base | unit > base = normalizeUnit (unit/base, order + 1) base-                                 | otherwise = (unit, order)+normalizeUnit (unit, order) base+  | unit > base = normalizeUnit (unit / base, order + 1) base+  | otherwise = (unit, order)  storagedesc :: (String, String) -> String-storagedesc (ssize, unit) = let-  size = read ssize :: Double-  uprefix | unit == "B" = ""-          | otherwise = [head unit]-  uorder = getOrder uprefix-  (osize, oorder) = normalizeUnit (size, uorder) 1024-  in printf "%.2f %sB" osize (getPrefix oorder)+storagedesc (ssize, unit) =+  let size = read ssize :: Double+      uprefix+        | unit == "B" = ""+        | otherwise = [head unit]+      uorder = getOrder uprefix+      (osize, oorder) = normalizeUnit (size, uorder) 1024+   in printf "%.2f %sB" osize (getPrefix oorder)  factRAM :: IO [(String, String)] factRAM = do-    meminfo <- fmap (map words . lines) (readFile "/proc/meminfo")-    let memtotal  = ginfo "MemTotal:"-        memfree   = ginfo "MemFree:"-        swapfree  = ginfo "SwapFree:"-        swaptotal = ginfo "SwapTotal:"-        ginfo st  = sdesc $ head $ filter ((== st) . head) meminfo-        sdesc [_, size, unit] = storagedesc (size, unit)-        sdesc _               = storagedesc ("1","B")-    return [("memorysize", memtotal), ("memoryfree", memfree), ("swapfree", swapfree), ("swapsize", swaptotal)]+  meminfo <- fmap (map words . lines) (readFile "/proc/meminfo")+  let memtotal = ginfo "MemTotal:"+      memfree = ginfo "MemFree:"+      swapfree = ginfo "SwapFree:"+      swaptotal = ginfo "SwapTotal:"+      ginfo st = sdesc $ head $ filter ((== st) . head) meminfo+      sdesc [_, size, unit] = storagedesc (size, unit)+      sdesc _ = storagedesc ("1", "B")+  return [("memorysize", memtotal), ("memoryfree", memfree), ("swapfree", swapfree), ("swapsize", swaptotal)]  factNET :: IO [(String, String)] factNET = return [("ipaddress", "192.168.0.1")]  factOS :: IO [(String, String)] factOS = do-    islsb <- Directory.doesFileExist "/etc/lsb-release"-    isdeb <- Directory.doesFileExist "/etc/debian_version"-    case (islsb, isdeb) of-        (True, _) -> factOSLSB-        (_, True) -> factOSDebian-        _         -> return []+  islsb <- Directory.doesFileExist "/etc/lsb-release"+  isdeb <- Directory.doesFileExist "/etc/debian_version"+  case (islsb, isdeb) of+    (True, _) -> factOSLSB+    (_, True) -> factOSDebian+    _ -> return []  factOSDebian :: IO [(String, String)] factOSDebian = fmap (toV . head . lines) (readFile "/etc/debian_version")-    where-        toV v = [ ("lsbdistid"              , "Debian")-                , ("operatingsystem"        , "Debian")-                , ("lsbdistrelease"         , v)-                , ("operatingsystemrelease" , v)-                , ("lsbmajdistrelease"      , takeWhile (/='.') v)-                , ("osfamily"               , "Debian")-                , ("lsbdistcodename"        , codename v)-                , ("lsbdistdescription"     , "Debian GNU/Linux " <> v <> " (" <> codename v <> ")")-                ]-        codename v | null v = "unknown"-                   | h '7' = "wheezy"-                   | h '6' = "squeeze"-                   | h '5' = "lenny"-                   | h '4' = "etch"-                   | v == "3.1" = "sarge"-                   | v == "3.0" = "woody"-                   | v == "2.2" = "potato"-                   | v == "2.1" = "slink"-                   | v == "2.0" = "hamm"-                   | otherwise = "unknown"-            where h x = head v == x+  where+    toV v =+      [ ("lsbdistid", "Debian"),+        ("operatingsystem", "Debian"),+        ("lsbdistrelease", v),+        ("operatingsystemrelease", v),+        ("lsbmajdistrelease", takeWhile (/= '.') v),+        ("osfamily", "Debian"),+        ("lsbdistcodename", codename v),+        ("lsbdistdescription", "Debian GNU/Linux " <> v <> " (" <> codename v <> ")")+      ]+    codename v+      | null v = "unknown"+      | h '7' = "wheezy"+      | h '6' = "squeeze"+      | h '5' = "lenny"+      | h '4' = "etch"+      | v == "3.1" = "sarge"+      | v == "3.0" = "woody"+      | v == "2.2" = "potato"+      | v == "2.1" = "slink"+      | v == "2.0" = "hamm"+      | otherwise = "unknown"+      where+        h x = head v == x  factOSLSB :: IO [(String, String)] factOSLSB = do-    lsb <- fmap (map (break (== '=')) . lines) (readFile "/etc/lsb-release")-    let getval st | null filterd = "?"-                  | otherwise = rvalue-                  where filterd = filter (\(k,_) -> k == st) lsb-                        value    = (tail . snd . head) filterd-                        rvalue | head value == '"' = read value-                               | otherwise         = value-        lrelease = getval "DISTRIB_RELEASE"-        distid  = getval "DISTRIB_ID"-        maj     | lrelease == "?" = "?"-                | otherwise = takeWhile (/= '.') lrelease-        osfam   | distid == "Ubuntu" = "Debian"-                | otherwise = distid-    return  [ ("lsbdistid"                 , distid)-            , ("operatingsystem"           , distid)-            , ("lsbdistrelease"            , lrelease)-            , ("operatingsystemrelease"    , lrelease)-            , ("operatingsystemmajrelease" , lrelease)-            , ("lsbmajdistrelease"         , maj)-            , ("lsbminordistrelease"       , "")-            , ("osfamily"                  , osfam)-            , ("lsbdistcodename"           , getval "DISTRIB_CODENAME")-            , ("lsbdistdescription"        , getval "DISTRIB_DESCRIPTION")-            ]+  lsb <- fmap (map (break (== '=')) . lines) (readFile "/etc/lsb-release")+  let getval st+        | null filterd = "?"+        | otherwise = rvalue+        where+          filterd = filter (\(k, _) -> k == st) lsb+          value = (tail . snd . head) filterd+          rvalue+            | head value == '"' = read value+            | otherwise = value+      lrelease = getval "DISTRIB_RELEASE"+      distid = getval "DISTRIB_ID"+      maj+        | lrelease == "?" = "?"+        | otherwise = takeWhile (/= '.') lrelease+      osfam+        | distid == "Ubuntu" = "Debian"+        | otherwise = distid+  return+    [ ("lsbdistid", distid),+      ("operatingsystem", distid),+      ("lsbdistrelease", lrelease),+      ("operatingsystemrelease", lrelease),+      ("operatingsystemmajrelease", lrelease),+      ("lsbmajdistrelease", maj),+      ("lsbminordistrelease", ""),+      ("osfamily", osfam),+      ("lsbdistcodename", getval "DISTRIB_CODENAME"),+      ("lsbdistdescription", getval "DISTRIB_DESCRIPTION")+    ]  factMountPoints :: IO [(String, String)] factMountPoints = do-    mountinfo <- fmap (map words . lines) (readFile "/proc/mounts")-    let ignorefs = HS.fromList-                    ["NFS", "nfs", "nfs4", "nfsd", "afs", "binfmt_misc", "proc", "smbfs",-                    "autofs", "iso9660", "ncpfs", "coda", "devpts", "ftpfs", "devfs",-                    "mfs", "shfs", "sysfs", "cifs", "lustre_lite", "tmpfs", "usbfs", "udf",-                    "fusectl", "fuse.snapshotfs", "rpc_pipefs", "configfs", "devtmpfs",-                    "debugfs", "securityfs", "ecryptfs", "fuse.gvfs-fuse-daemon", "rootfs"-                    ]-        goodlines = filter (\x -> not $ HS.member (x !! 2) ignorefs) mountinfo-        goodfs = map (!! 1) goodlines-    return [("mountpoints", unwords goodfs)]+  mountinfo <- fmap (map words . lines) (readFile "/proc/mounts")+  let ignorefs =+        HS.fromList+          [ "NFS",+            "nfs",+            "nfs4",+            "nfsd",+            "afs",+            "binfmt_misc",+            "proc",+            "smbfs",+            "autofs",+            "iso9660",+            "ncpfs",+            "coda",+            "devpts",+            "ftpfs",+            "devfs",+            "mfs",+            "shfs",+            "sysfs",+            "cifs",+            "lustre_lite",+            "tmpfs",+            "usbfs",+            "udf",+            "fusectl",+            "fuse.snapshotfs",+            "rpc_pipefs",+            "configfs",+            "devtmpfs",+            "debugfs",+            "securityfs",+            "ecryptfs",+            "fuse.gvfs-fuse-daemon",+            "rootfs"+          ]+      goodlines = filter (\x -> not $ HS.member (x !! 2) ignorefs) mountinfo+      goodfs = map (!! 1) goodlines+  return [("mountpoints", unwords goodfs)]  fversion :: IO [(String, String)]-fversion = return [("facterversion", "0.1"),("environment","test")]+fversion = return [("facterversion", "0.1"), ("environment", "test")]  factUser :: IO [(String, String)] factUser = do-    username <- getEffectiveUserName-    return [("id",username)]+  username <- getEffectiveUserName+  return [("id", username)]  factUName :: IO [(String, String)] factUName = do-    SystemID sn nn rl _ mc <- getSystemID-    let vparts = List.splitOn "." (takeWhile (/='-') rl)-    return [ ("kernel"           , sn)                              -- Linux-           , ("kernelmajversion" , List.intercalate "." (take 2 vparts)) -- 3.5-           , ("kernelrelease"    , rl)                              -- 3.5.0-45-generic-           , ("kernelversion"    , List.intercalate "." (take 3 vparts)) -- 3.5.0-           , ("hardwareisa"      , mc)                              -- x86_64-           , ("hardwaremodel"    , mc)                              -- x86_64-           , ("hostname"         , nn)-           ]+  SystemID sn nn rl _ mc <- getSystemID+  let vparts = List.splitOn "." (takeWhile (/= '-') rl)+  return+    [ ("kernel", sn), -- Linux+      ("kernelmajversion", List.intercalate "." (take 2 vparts)), -- 3.5+      ("kernelrelease", rl), -- 3.5.0-45-generic+      ("kernelversion", List.intercalate "." (take 3 vparts)), -- 3.5.0+      ("hardwareisa", mc), -- x86_64+      ("hardwaremodel", mc), -- x86_64+      ("hostname", nn)+    ] -fenv :: IO [(String,String)]+fenv :: IO [(String, String)] fenv = do-    path <- getEnv "PATH"-    return [ ("path", path) ]+  path <- getEnv "PATH"+  return [("path", path)] -factProcessor :: IO [(String,String)]+factProcessor :: IO [(String, String)] factProcessor = do-    cpuinfo <- readFile "/proc/cpuinfo"-    let cpuinfos = zip [ "processor" <> show (n :: Int) | n <- [0..]] modelnames-        modelnames = mapMaybe (fmap (dropWhile (`elem` ("\t :" :: String))) . List.stripPrefix "model name") (lines cpuinfo)-    return $ ("processorcount", show (length cpuinfos)) : cpuinfos+  cpuinfo <- readFile "/proc/cpuinfo"+  let cpuinfos = zip ["processor" <> show (n :: Int) | n <- [0 ..]] modelnames+      modelnames = mapMaybe (fmap (dropWhile (`elem` ("\t :" :: String))) . List.stripPrefix "model name") (lines cpuinfo)+  return $ ("processorcount", show (length cpuinfos)) : cpuinfos
src/Hiera/Server.hs view
@@ -1,74 +1,79 @@ {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE NamedFieldPuns         #-}-{-# LANGUAGE PatternGuards          #-}-{-# LANGUAGE RecordWildCards        #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TemplateHaskell        #-}-{-# LANGUAGE TypeApplications       #-}--{- | This module runs a Hiera server that caches Hiera data. There is-a huge caveat : only the data files are watched for changes, not the main configuration file.--A minor bug is that interpolation will not work for inputs containing the % character when it isn't used for interpolation.--}-module Hiera.Server (-    startHiera-  , dummyHiera-  , HieraQueryType (..)-  , readQueryType-  , HieraQueryFunc-  , varSplitter-  , HieraVar(..)-  , mergeWith-) where+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} -import           XPrelude hiding (space)+-- | This module runs a Hiera server that caches Hiera data. There is+-- a huge caveat : only the data files are watched for changes, not the main configuration file.+--+-- A minor bug is that interpolation will not work for inputs containing the % character when it isn't used for interpolation.+module Hiera.Server+  ( startHiera,+    dummyHiera,+    HieraQueryType (..),+    readQueryType,+    HieraQueryFunc,+    varSplitter,+    HieraVar (..),+    mergeWith,+  )+where -import           Data.Aeson-import qualified Data.Aeson                 as Aeson-import qualified Data.Attoparsec.Text       as AT-import qualified Data.ByteString.Lazy       as BS+import Data.Aeson+import qualified Data.Aeson as Aeson+import Data.Aeson.Lens (_Key)+import qualified Data.Attoparsec.Text as AT+import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS8-import qualified Data.Either.Strict         as S-import qualified Data.FileCache             as Cache-import qualified Data.List                  as List-import           Data.String                (fromString)-import qualified Data.Text                  as Text-import qualified Data.Vector                as Vector-import qualified Data.Yaml                  as Yaml-import qualified System.Directory           as Directory-import qualified System.FilePath            as FilePath-import           System.FilePath.Lens       (directory)-import           Text.Megaparsec            (parse, sepBy, sepBy1, Parsec, satisfy)-import           Text.Megaparsec.Char       (char, space)--import           Puppet.Language-+import qualified Data.Either.Strict as S+import qualified Data.FileCache as Cache+import qualified Data.List as List+import qualified Data.Text as Text+import qualified Data.Vector as Vector+import qualified Data.Yaml as Yaml+import Puppet.Language+import qualified System.Directory as Directory+import qualified System.FilePath as FilePath+import System.FilePath.Lens (directory)+import Text.Megaparsec (Parsec, parse, satisfy, sepBy, sepBy1)+import Text.Megaparsec.Char (char, space)+import XPrelude hiding (space)  -- | The different kind of hiera queries. data HieraQueryType-    = QFirst   -- ^ The first match in the hierarchy is returned.-    | QUnique -- ^ Combines array and scalar values to return a merged, flattened array with all duplicate removed.-    | QHash  -- ^ Combines the keys and values of any number of hashes to return a merged hash.+  = -- | The first match in the hierarchy is returned.+    QFirst+  | -- | Combines array and scalar values to return a merged, flattened array with all duplicate removed.+    QUnique+  | -- | Combines the keys and values of any number of hashes to return a merged hash.     -- | Use of an Hash to specify the merge behavior-    | QDeep { _knockoutPrefix :: Maybe Text-            , _sortMerged     :: Bool-            , _mergeHashArray :: Bool-            } deriving (Show)+    QHash+  | QDeep+      { _knockoutPrefix :: Maybe Text,+        _sortMerged :: Bool,+        _mergeHashArray :: Bool+      }+  deriving (Show)  readQueryType :: Text -> Maybe HieraQueryType readQueryType s =   case s of-    "first"  -> Just QFirst+    "first" -> Just QFirst     "unique" -> Just QUnique-    "hash"   -> Just QHash-    _        -> Nothing+    "hash" -> Just QHash+    _ -> Nothing  -- | The type of the Hiera API function associated to given hierarchy.-type HieraQueryFunc m = Container PValue -- ^ Scope: all variables that Hiera can interpolate (the top level ones are prefixed with '::')-                     -> Text -- ^ The query-                     -> HieraQueryType-                     -> ExceptT PrettyError m (Maybe PValue)+type HieraQueryFunc m =+  -- | Scope: all variables that Hiera can interpolate (the top level ones are prefixed with '::')+  Container PValue ->+  -- | The query+  Text ->+  HieraQueryType ->+  ExceptT PrettyError m (Maybe PValue)  data Backend   = YamlBackend FilePath@@ -81,48 +86,55 @@   deriving (Show)  instance Pretty HieraStringPart where-  pretty (HPString t)   = ppline t+  pretty (HPString t) = ppline t   pretty (HPVariable v) = dullred (ppline ("%{" <> v <> "}"))   prettyList = mconcat . map pretty  newtype InterpolableHieraString = InterpolableHieraString   { getInterpolableHieraString :: [HieraStringPart]-  } deriving (Show)+  }+  deriving (Show)  data HieraVar-    = HieraVar (NonEmpty Text)-    | HieraFunction (NonEmpty Text) [Text]-    deriving (Show, Eq)+  = HieraVar (NonEmpty Text)+  | HieraFunction (NonEmpty Text) [Text]+  deriving (Show, Eq) -varSplitter :: Text -> HieraVar -- ^ returns variable parts, function arguments+varSplitter ::+  Text ->+  -- | returns variable parts, function arguments+  HieraVar varSplitter v =-   case parse parser "dummy" v of-     Left _ -> HieraVar (v :| [])-     Right hv -> hv-   where-     parser :: Parsec Void Text HieraVar-     parser = do-       x:xs <- vpart `sepBy1` char '.'-       let nms = x :| xs-       margs <- optional (-         char '(' *> space *>-           (arg `sepBy` (space *> char ',' *> space))-         <* space <* char ')'-         )-       pure $ case margs of-                Nothing -> HieraVar nms-                Just args -> HieraFunction nms args-     arg = squotev <|> dquotev-     vpart = squotev <|> dquotev <|> rawv-     rawv = Text.pack <$> some (satisfy (\c -> c /= '.' && c /= '('))-     -- TODO, escapes-     squotev = Text.pack <$> (char '\'' *> some (satisfy (/= '\'')) <* char '\'')-     dquotev = Text.pack <$> (char '"' *> some (satisfy (/= '"')) <* char '"')+  case parse parser "dummy" v of+    Left _ -> HieraVar (v :| [])+    Right hv -> hv+  where+    parser :: Parsec Void Text HieraVar+    parser = do+      x : xs <- vpart `sepBy1` char '.'+      let nms = x :| xs+      margs <-+        optional+          ( char '('+              *> space+              *> (arg `sepBy` (space *> char ',' *> space))+              <* space+              <* char ')'+          )+      pure $ case margs of+        Nothing -> HieraVar nms+        Just args -> HieraFunction nms args+    arg = squotev <|> dquotev+    vpart = squotev <|> dquotev <|> rawv+    rawv = Text.pack <$> some (satisfy (\c -> c /= '.' && c /= '('))+    -- TODO, escapes+    squotev = Text.pack <$> (char '\'' *> some (satisfy (/= '\'')) <* char '\'')+    dquotev = Text.pack <$> (char '"' *> some (satisfy (/= '"')) <* char '"')  resolveString :: Container PValue -> InterpolableHieraString -> Maybe Text resolveString vars = fmap Text.concat . mapM resolve . getInterpolableHieraString   where-    resolve (HPString x)   = Just x+    resolve (HPString x) = Just x     resolve (HPVariable v) = vars ^? ix v . _PString  instance FromJSON InterpolableHieraString where@@ -142,64 +154,60 @@ parseInterpolableString = AT.parseOnly interpolableString  data HieraConfigFile = HieraConfigFile-  { _version   :: Int-  , _backends  :: [Backend]-  , _hierarchy :: [InterpolableHieraString]-  } deriving (Show)+  { _version :: Int,+    _backends :: [Backend],+    _hierarchy :: [InterpolableHieraString]+  }+  deriving (Show)  data QRead = QRead-  { _qvars :: Container PValue-  , _qtype :: HieraQueryType-  , _qhier :: [Value]+  { _qvars :: Container PValue,+    _qtype :: HieraQueryType,+    _qhier :: [Value]   }  makeLenses ''QRead  instance FromJSON HieraConfigFile where   parseJSON =-    let-      mkHiera5 :: Object -> Yaml.Parser HieraConfigFile-      mkHiera5 v = do-        -- we currently only read the first hierarchy entry to get the hiera path-        -- TODO: change the definition of HieraConfigFile to be [(Backend, InterpolableHieraString)]-        -- to allow defining a Backend per hierarchies-        let paths = Object v ^.. key "hierarchy" . avalues . key "paths" . avalues-            path = Object v ^.. key "hierarchy" .avalues .key "path"-        hierarchy_value <- case Object v ^? key "hierarchy" . nth 0 of-          Just (Object h) -> pure h-          _ -> fail "Hiera config should define at least one hierarchy"-        datadir <- hierarchy_value .:? "datadir" >>= \case-          Just (String dir) -> pure dir-          Just _            -> fail "datadir should be a string"-          Nothing           -> pure $ Object v ^. key "defaults" . key "datadir" . _String-        HieraConfigFile-            <$> pure 5-            <*> pure [ YamlBackend (toS datadir) ] -- TODO: support other backends if needed-            <*> mapM parseJSON (paths <> path)-      mkHiera3 v =-        HieraConfigFile-            <$> pure 3-            <*> (v .:? ":backends" .!= ["yaml"] >>= mapM mkBackend3)+    let mkHiera5 :: Object -> Yaml.Parser HieraConfigFile+        mkHiera5 v = do+          -- we currently only read the first hierarchy entry to get the hiera path+          -- TODO: change the definition of HieraConfigFile to be [(Backend, InterpolableHieraString)]+          -- to allow defining a Backend per hierarchies+          let paths = Object v ^.. key "hierarchy" . avalues . key "paths" . avalues+              path = Object v ^.. key "hierarchy" . avalues . key "path"+          hierarchy_value <- case Object v ^? key "hierarchy" . nth 0 of+            Just (Object h) -> pure h+            _ -> fail "Hiera config should define at least one hierarchy"+          datadir <-+            hierarchy_value .:? "datadir" >>= \case+              Just (String dir) -> pure dir+              Just _ -> fail "datadir should be a string"+              Nothing -> pure $ Object v ^. key "defaults" . key "datadir" . _String+          HieraConfigFile 5 [YamlBackend (toS datadir)] -- TODO: support other backends if needed+            <$> mapM parseJSON (paths <> path)+        mkHiera3 v =+          HieraConfigFile 3+            <$> (v .:? ":backends" .!= ["yaml"] >>= mapM mkBackend3)             <*> (v .:? ":hierarchy" .!= [InterpolableHieraString [HPString "common"]])-       where-         mkBackend3 :: Text -> Yaml.Parser Backend-         mkBackend3 name = do-           (backendConstructor, skey) <- case name of-                                             "yaml" -> return (YamlBackend, ":yaml")-                                             "json" -> return (JsonBackend, ":json")-                                             _      -> fail ("Unknown backend " <> toS name)-           datadir <- case Object v ^? key skey . key ":datadir" of-                             Just (String dir) -> return dir-                             Just _            -> fail ":datadir should be a string"-                             Nothing           -> return "/etc/puppet/hieradata"-           pure (backendConstructor (toS datadir))--    in-    Aeson.withObject "v3 or v5" $ \o ->-      o .:? "version" >>= \case-        Just (5::Int) -> mkHiera5 o-        Just _ -> fail "Hiera configuration version different than 5 is not supported."-        Nothing -> mkHiera3 o+          where+            mkBackend3 :: Text -> Yaml.Parser Backend+            mkBackend3 name = do+              (backendConstructor, skey) <- case name of+                "yaml" -> return (YamlBackend, ":yaml")+                "json" -> return (JsonBackend, ":json")+                _ -> fail ("Unknown backend " <> toS name)+              datadir <- case Object v ^? key skey . key ":datadir" of+                Just (String dir) -> return dir+                Just _ -> fail ":datadir should be a string"+                Nothing -> return "/etc/puppet/hieradata"+              pure (backendConstructor (toS datadir))+     in Aeson.withObject "v3 or v5" $ \o ->+          o .:? "version" >>= \case+            Just (5 :: Int) -> mkHiera5 o+            Just _ -> fail "Hiera configuration version different than 5 is not supported."+            Nothing -> mkHiera3 o  type Cache = Cache.FileCacheR String Value @@ -211,16 +219,16 @@     Left (Yaml.AesonException "Error in $: Hiera configuration version different than 5 is not supported.") -> do       logInfoStr ("Detect a hiera configuration format in " <> fp <> " at version 4. This format is not recognized. Using a dummy hiera.")       pure dummyHiera-    Left ex   -> panic (show ex)-    Right cfg@HieraConfigFile{..} -> do+    Left ex -> panic (show ex)+    Right cfg@HieraConfigFile {..} -> do       logInfoStr ("Detect a hiera " <> layer <> " configuration format in " <> fp <> " at version " <> show _version)       query cfg fp <$> Cache.newFileCache  -- | A dummy hiera function that will be used when hiera is not detected.-dummyHiera :: Monad m => HieraQueryFunc m+dummyHiera :: (Monad m) => HieraQueryFunc m dummyHiera _ _ _ = pure Nothing -exceptt :: Applicative m => Except r a -> ExceptT r m a+exceptt :: (Applicative m) => Except r a -> ExceptT r m a exceptt = ExceptT . pure . runExcept  query :: HieraConfigFile -> FilePath -> Cache -> HieraQueryFunc IO@@ -228,49 +236,54 @@   -- step 1, resolve hierarchies   let searchin = do         mhierarchy <- resolveString vars <$> _hierarchy-        Just h  <- [mhierarchy]-        backend    <- _backends+        Just h <- [mhierarchy]+        backend <- _backends         let decodeInfo :: (FilePath -> IO (Either String Value), String, String)             decodeInfo =               case backend of-                JsonBackend dir -> (fmap Aeson.eitherDecode' . BS.readFile       , dir, ".json")+                JsonBackend dir -> (fmap Aeson.eitherDecode' . BS.readFile, dir, ".json")                 YamlBackend dir -> (fmap (_Left %~ show) . Yaml.decodeFileEither, dir, ".yaml")         pure (decodeInfo, toS h)   -- step 2, read all the files, returning a raw data structure   mvals <- liftIO $ forM searchin $ \((decodefunction, datadir, extension), h) -> do-    let extension' = if snd (FilePath.splitExtension h) == ".yaml"-                       then ""-                       else extension+    let extension' =+          if snd (FilePath.splitExtension h) == ".yaml"+            then ""+            else extension         filename = basedir <> datadir <> "/" <> h <> extension'         basedir = case datadir of           '/' : _ -> mempty-          _       -> fp ^. directory <> "/"+          _ -> fp ^. directory <> "/"         querycache = do           efilecontent <- Cache.query cache filename (strictifyEither <$> decodefunction filename)           case efilecontent of             S.Left r -> do-              logWarningStr $ "Hiera: error when reading file " <> filename <> ": "<> r+              logWarningStr $ "Hiera: error when reading file " <> filename <> ": " <> r               pure Nothing             S.Right val -> pure (Just val)-    ifM (Directory.doesFileExist filename)+    ifM+      (Directory.doesFileExist filename)       querycache       (pure Nothing)   let vals = catMaybes mvals   -- step 3, query through all the results-  liftIO $ logDebugStr ("Looking up '" <> toS hquery <> "' with backends " <> List.unwords (fmap show _backends ))+  liftIO $ logDebugStr ("Looking up '" <> toS hquery <> "' with backends " <> List.unwords (fmap show _backends))   exceptt $ runReaderT (recursiveQuery hquery []) (QRead vars qt vals)  type QM a = ReaderT QRead (Except PrettyError) a  checkLoop :: Text -> [Text] -> QM () checkLoop x xs =-    when (x `elem` xs) (throwError ("Loop in hiera: " <> fromString (Text.unpack (Text.intercalate ", " (x:xs)))))+  when (x `elem` xs) (throwError ("Loop in hiera: " <> fromString (Text.unpack (Text.intercalate ", " (x : xs)))))  -- a helper function that removes prefix and suffix-textBetween :: Text -- ^ prefix-            -> Text -- ^ suffix-            -> Text-            -> Maybe Text+textBetween ::+  -- | prefix+  Text ->+  -- | suffix+  Text ->+  Text ->+  Maybe Text textBetween pr su = Text.stripPrefix pr >=> Text.stripSuffix su  recursiveQuery :: Text -> [Text] -> QM (Maybe PValue)@@ -279,11 +292,11 @@     HieraFunction _ _ -> throwError "Hiera functions not yet handled here (A)"     HieraVar (varname :| allkeys) -> do       checkLoop varname prevqueries-      rawlookups <- mapMaybe (preview (key varname)) <$> view qhier+      rawlookups <- mapMaybe (preview (key (varname ^. _Key))) <$> view qhier       let lookupKeys keys v =             case keys of               [] -> pure v-              k:ks ->+              k : ks ->                 case v of                   Object hs ->                     case hs ^? ix k of@@ -291,14 +304,14 @@                       Just v' -> lookupKeys ks v'                   _ -> Nothing       rlookups <- mapM (resolveValue (varname : prevqueries)) rawlookups-      let lookups = mapMaybe (lookupKeys allkeys) rlookups+      let lookups = mapMaybe (lookupKeys (allkeys ^.. traversed . _Key)) rlookups       case traverse Aeson.fromJSON lookups of         Aeson.Error rr -> throwError ("Something horrible happened in recursiveQuery: " <> fromString rr)         Aeson.Success [] ->           if null rlookups             then return Nothing-            else throwError ("Could not lookup " <> fromString (Text.unpack curquery) <> " in " <> PrettyError (list (map (fromString . BS8.unpack . encode) rlookups)) )-        Aeson.Success (x:xs) -> do+            else throwError ("Could not lookup " <> fromString (Text.unpack curquery) <> " in " <> PrettyError (list (map (fromString . BS8.unpack . encode) rlookups)))+        Aeson.Success (x : xs) -> do           qt <- view qtype           Just <$> foldM (mergeWith qt) x xs @@ -306,20 +319,20 @@ resolveValue prevqueries value =   case value of     String t | Just alias <- Text.stripPrefix "%{alias('" t >>= Text.stripSuffix "')}" -> do-          mr <- recursiveQuery alias (("alias:" <> alias) : prevqueries)-          case mr of-            Nothing -> throwError ("Could not alias " <> fromString (Text.unpack alias))-            Just r -> pure (toJSON r)-    String t  -> String <$> resolveText prevqueries t+      mr <- recursiveQuery alias (("alias:" <> alias) : prevqueries)+      case mr of+        Nothing -> throwError ("Could not alias " <> fromString (Text.unpack alias))+        Just r -> pure (toJSON r)+    String t -> String <$> resolveText prevqueries t     Array arr -> Array <$> mapM (resolveValue prevqueries) arr     Object hh -> Object <$> mapM (resolveValue prevqueries) hh-    _         -> return value+    _ -> return value  resolveText :: [Text] -> Text -> QM Text resolveText prevqueries t =   case parseInterpolableString t of     Right qparts -> Text.concat <$> mapM (resolveStringPart prevqueries) qparts-    Left _       -> return t+    Left _ -> return t  resolveStringPart :: [Text] -> HieraStringPart -> QM Text resolveStringPart prevqueries sp =@@ -330,48 +343,51 @@       let rc vars val =             case vars of               [] -> pure val-              v:vs -> case val of-                        PHash m -> m ^? ix v >>= rc vs-                        _ -> Nothing-          extractFunction txt = textBetween (txt <> "('") "')" varname-                            <|> textBetween (txt <> "(\"") "\")" varname+              v : vs -> case val of+                PHash m -> m ^? ix v >>= rc vs+                _ -> Nothing+          extractFunction txt =+            textBetween (txt <> "('") "')" varname+              <|> textBetween (txt <> "(\"") "\")" varname       r <- case extractFunction "lookup" <|> extractFunction "hiera" <|> extractFunction "alias" of         Just lk -> recursiveQuery lk prevqueries         Nothing -> do-            vmap <- view qvars-            case varSplitter varname of-              HieraVar (mvar :| svars) -> pure (vmap ^? ix mvar >>= rc svars)-              HieraFunction (fname :| []) args ->-                case fname of-                  "literal" ->-                    case args of-                      [x] -> pure (Just (PString x))-                      _ -> throwError "The literal function expects a single argument"-                  _ -> throwError ("Unknown function " <> fromString (Text.unpack fname))-              HieraFunction (fname :| xs) _ ->-                throwError ("Malformed function name: "-                  <> fromString (Text.unpack (Text.intercalate "." (fname:xs))))+          vmap <- view qvars+          case varSplitter varname of+            HieraVar (mvar :| svars) -> pure (vmap ^? ix mvar >>= rc svars)+            HieraFunction (fname :| []) args ->+              case fname of+                "literal" ->+                  case args of+                    [x] -> pure (Just (PString x))+                    _ -> throwError "The literal function expects a single argument"+                _ -> throwError ("Unknown function " <> fromString (Text.unpack fname))+            HieraFunction (fname :| xs) _ ->+              throwError+                ( "Malformed function name: "+                    <> fromString (Text.unpack (Text.intercalate "." (fname : xs)))+                )        case r of         Just (PString v) -> return v         Just (PNumber s) -> pure (scientific2text s)-        Just pvalue      -> throwError (PrettyError ("Variable lookup for " <> fromString (Text.unpack varname) <> " did not return a string, but " <> pretty pvalue))-        _                -> throwError ("Could not lookup variable " <> fromString (Text.unpack varname))+        Just pvalue -> throwError (PrettyError ("Variable lookup for " <> fromString (Text.unpack varname) <> " did not return a string, but " <> pretty pvalue))+        _ -> throwError ("Could not lookup variable " <> fromString (Text.unpack varname)) -mergeWith :: MonadError PrettyError m => HieraQueryType -> PValue -> PValue -> m PValue+mergeWith :: (MonadError PrettyError m) => HieraQueryType -> PValue -> PValue -> m PValue mergeWith qt cur new =   case qt of     QFirst -> return cur     QUnique ->       let getArray x = case x of-              PArray array -> Vector.toList array-              _           -> [x]+            PArray array -> Vector.toList array+            _ -> [x]           curarray = getArray cur           newarray = getArray new-      in  case new of-              PHash _  -> throwError "Tried to merge a hash"-              _        -> return (PArray (Vector.fromList (List.nub (curarray ++ newarray))))+       in case new of+            PHash _ -> throwError "Tried to merge a hash"+            _ -> return (PArray (Vector.fromList (List.nub (curarray ++ newarray))))     QHash -> case (cur, new) of       (PHash curh, PHash newh) -> return (PHash (curh <> newh))       _ -> throwError (PrettyError ("Tried to merge things that are not hashes: " <> ppline (show cur) <+> ppline (show new)))-    QDeep{} -> throwError "deep queries not supported"+    QDeep {} -> throwError "deep queries not supported"
src/Puppet/Interpreter.hs view
@@ -1,59 +1,62 @@-{-# LANGUAGE GADTs            #-}-{-# LANGUAGE RankNTypes       #-}-module Puppet.Interpreter-       ( interpretCatalog-       , computeCatalog-       , evaluateStatement-       -- * Utils-       , initialState-       , extractScope-       , containerModName-       , askFact-       , module Puppet.Interpreter.Types-       , module Puppet.Interpreter.Resolve-       , module Puppet.Interpreter.IO-       ) where--import           XPrelude.Extra-import           XPrelude.PP+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-} -import           Control.Monad.Operational        hiding (view)-import qualified Data.Char                        as Char-import qualified Data.Graph                       as Graph-import qualified Data.HashMap.Strict              as Map-import qualified Data.HashSet                     as Set-import qualified Data.List                        as List-import qualified Data.Maybe.Strict                as S-import           Data.Semigroup                   (Max (..))-import qualified Data.Text                        as Text-import qualified Data.Tree                        as Tree-import qualified Data.Vector                      as V-import qualified System.Log.Logger                as Log+module Puppet.Interpreter+  ( interpretCatalog,+    computeCatalog,+    evaluateStatement, -import           Facter-import           Hiera.Server-import           Puppet.Interpreter.Helpers-import           Puppet.Interpreter.IO-import           Puppet.Interpreter.PrettyPrinter ()-import           Puppet.Interpreter.Resolve-import           Puppet.Interpreter.Types-import           Puppet.Parser+    -- * Utils+    initialState,+    extractScope,+    containerModName,+    askFact,+    module Puppet.Interpreter.Types,+    module Puppet.Interpreter.Resolve,+    module Puppet.Interpreter.IO,+  )+where -{-| Call the operational 'interpretMonad' function to compute the catalog.-    Returns either an error, or a tuple containing all the resources,-    dependency map, exported resources, and defined resources alongside with-    all messages that have been generated by the compilation process.+import Control.Monad.Operational hiding (view)+import qualified Data.Char as Char+import qualified Data.Graph as Graph+import qualified Data.HashMap.Strict as Map+import qualified Data.HashSet as Set+import qualified Data.List as List+import qualified Data.Maybe.Strict as S+import Data.Semigroup (Max (..))+import qualified Data.Text as Text+import qualified Data.Tree as Tree+import qualified Data.Vector as V+import Facter+import Hiera.Server+import Puppet.Interpreter.Helpers+import Puppet.Interpreter.IO+import Puppet.Interpreter.PrettyPrinter ()+import Puppet.Interpreter.Resolve+import Puppet.Interpreter.Types+import Puppet.Parser+import qualified System.Log.Logger as Log+import XPrelude.Extra+import XPrelude.PP -    The later defined resources (eg. all class declarations) are pulled out of the-    'InterpreterState' and might not be up to date.-    There are only useful for coverage testing (checking dependencies for instance).--}-interpretCatalog :: Monad m-                 => InterpreterReader m -- ^ The whole environment required for computing catalog.-                 -> NodeName-                 -> Facts-                 -> Container Text -- ^ Server settings-                 -> m (Pair (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))  [Pair Log.Priority Doc])+-- | Call the operational 'interpretMonad' function to compute the catalog.+--    Returns either an error, or a tuple containing all the resources,+--    dependency map, exported resources, and defined resources alongside with+--    all messages that have been generated by the compilation process.+--+--    The later defined resources (eg. all class declarations) are pulled out of the+--    'InterpreterState' and might not be up to date.+--    There are only useful for coverage testing (checking dependencies for instance).+interpretCatalog ::+  (Monad m) =>+  -- | The whole environment required for computing catalog.+  InterpreterReader m ->+  NodeName ->+  Facts ->+  -- | Server settings+  Container Text ->+  m (Pair (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Log.Priority Doc]) interpretCatalog r node facts settings = do   (output, _, warnings) <- interpretMonad r (initialState facts settings) (computeCatalog node)   pure (output :!: warnings)@@ -61,49 +64,56 @@ isParent :: Text -> CurContainerDesc -> InterpreterMonad Bool isParent cur (ContClass possibleparent) =   preuse (scopes . ix cur . scopeParent) >>= \case-    Nothing         -> throwPosError ("Internal error: could not find scope" <+> ppline cur <+> "possible parent" <+> ppline possibleparent)-    Just S.Nothing  -> pure False-    Just (S.Just p) -> if p == possibleparent-                           then pure True-                           else isParent p (ContClass possibleparent)+    Nothing -> throwPosError ("Internal error: could not find scope" <+> ppline cur <+> "possible parent" <+> ppline possibleparent)+    Just S.Nothing -> pure False+    Just (S.Just p) ->+      if p == possibleparent+        then pure True+        else isParent p (ContClass possibleparent) isParent _ _ = pure False  -- | Apply resource defaults, references overrides and expand defines finalize :: [Resource] -> InterpreterMonad [Resource] finalize rx = do-  scp  <- getScopeName+  scp <- getScopeName   resdefaults <- use (scopes . ix scp . scopeResDefaults)   let getOver = use (scopes . ix scp . scopeOverrides) -- retrieves current overrides       addResDefaults r = ifoldlM (addAttribute CantReplace) r resdefval-          where resdefval = resdefaults ^. ix (r ^. rid . itype) . resDefValues+        where+          resdefval = resdefaults ^. ix (r ^. rid . itype) . resDefValues       addOverrides r = getOver >>= foldlM addOverrides' r . view (at (r ^. rid))       addOverrides' r (ResRefOverride _ prms p) = do-          -- we used this override, so we discard it-          scopes . ix scp . scopeOverrides . at (r ^. rid) .= Nothing-          let forb msg  = throwPosError ("Override of parameters ("-                                        <> list (map (ppline . fst) $ itoList prms)-                                        <> ") of the following resource is forbidden in the current context:"-                                        </> pretty r-                                        <+> showPPos p-                                        </> ":"-                                        <+> msg)-          s <- getScope-          overrideType <- case r ^. rscope of-            [] -> forb "Could not find the current resource context" -- we could not get the current resource context-            (x:_) -> if x == s-                       then pure CantOverride -- we are in the same context : can't replace, but add stuff-                       else isParent (scopeName s) x >>= \i ->-                              if i || (r ^. rid . itype == "class")-                                then pure Replace -- we can override what's defined in a parent-                                else forb "Can't override something that was not defined in the parent."-          ifoldlM (addAttribute overrideType) r prms+        -- we used this override, so we discard it+        scopes . ix scp . scopeOverrides . at (r ^. rid) .= Nothing+        let forb msg =+              throwPosError+                ( "Override of parameters ("+                    <> list (map (ppline . fst) $ itoList prms)+                    <> ") of the following resource is forbidden in the current context:"+                    </> pretty r+                    <+> showPPos p+                    </> ":"+                    <+> msg+                )+        s <- getScope+        overrideType <- case r ^. rscope of+          [] -> forb "Could not find the current resource context" -- we could not get the current resource context+          (x : _) ->+            if x == s+              then pure CantOverride -- we are in the same context : can't replace, but add stuff+              else+                isParent (scopeName s) x >>= \i ->+                  if i || (r ^. rid . itype == "class")+                    then pure Replace -- we can override what's defined in a parent+                    else forb "Can't override something that was not defined in the parent."+        ifoldlM (addAttribute overrideType) r prms   -- step 1, apply resDefaults and resRefOverride   withDefaults <- mapM (addOverrides >=> addResDefaults) rx   -- There might be some overrides that could not be applied. The only   -- valid reason is that they override something in exported resources.   --   -- it probably do something unexpected on defines, but let's keep it that way for now.-  let keepforlater (ResRefOverride resid resprms ropos) = resModifiers %= (appended : )+  let keepforlater (ResRefOverride resid resprms ropos) = resModifiers %= (appended :)         where           appended = ResourceModifier (resid ^. itype) ModifierMustMatch DontRealize (REqualitySearch "title" (PString (resid ^. iname))) overrider ropos           overrider r = do@@ -127,7 +137,7 @@     expandDefine :: Resource -> InterpreterMonad [Resource]     expandDefine r =       let modulename = getModulename (r ^. rid)-      in  isIgnoredModule modulename >>= \case+       in isIgnoredModule modulename >>= \case             True -> pure mempty             False -> do               let deftype = dropInitialColons (r ^. rid . itype)@@ -146,11 +156,11 @@               (spurious, stmt) <- interpretTopLevel TopDefine deftype               DefineDecl _ defineParams stmts cp <- extractPrism "expandDefine" _DefineDecl stmt               let isImported (ContImported _) = True-                  isImported _                = False+                  isImported _ = False               isImportedDefine <- isImported <$> getScope               curPos .= r ^. rpos               curscp <- getScope-              when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp ))+              when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp))               pushScope curContType               loadVariable "title" (PString defname)               loadVariable "name" (PString defname)@@ -212,16 +222,17 @@       -- Classify sorts resources between exported and normal ones. It       -- drops virtual resources, and puts in both categories resources       -- that are at the same time exported and realized.-      classify :: Pair (HashMap RIdentifier Resource) (HashMap RIdentifier Resource)-               -> Resource-               -> Pair (HashMap RIdentifier Resource) (HashMap RIdentifier Resource)+      classify ::+        Pair (HashMap RIdentifier Resource) (HashMap RIdentifier Resource) ->+        Resource ->+        Pair (HashMap RIdentifier Resource) (HashMap RIdentifier Resource)       classify (curr :!: cure) r =         let i curm = curm & at (r ^. rid) ?~ r-        in  case r ^. rvirtuality of-              Normal           -> i curr :!: cure-              Exported         -> curr :!: i cure+         in case r ^. rvirtuality of+              Normal -> i curr :!: cure+              Exported -> curr :!: i cure               ExportedRealized -> i curr :!: i cure-              _                -> curr :!: cure+              _ -> curr :!: cure   verified <- Map.fromList . map (\r -> (r ^. rid, r)) <$> mapM validateNativeType (Map.elems real)   withResourceDependentRelations <- traverse getResourceDependentRelations verified   edgemap <- makeEdgeMap withResourceDependentRelations@@ -237,12 +248,12 @@ -- are defined. getResourceDependentRelations :: Resource -> InterpreterMonad Resource getResourceDependentRelations res =-  extract-  $ case res ^. rid . itype of+  extract $+    case res ^. rid . itype of       "file" -> [depOn "user" "owner", depOn "group" "group"]       "cron" -> [depOn "user" "user"]       "exec" -> [depOn "user" "user", depOn "group" "group"]-      _      -> []+      _ -> []   where     extract actions = do       newrelations <- fmap (foldl' (Map.unionWith (<>)) (res ^. rrelations)) (sequence actions)@@ -261,81 +272,81 @@  makeEdgeMap :: FinalCatalog -> InterpreterMonad EdgeMap makeEdgeMap ct = do-    -- merge the loaded classes and resources-    defs' <- fmap (view rpos) <$> use definedResources-    clss' <- use loadedClasses-    let defs = defs' <> classes' <> aliases' <> names'-        names' = (view rpos) <$> ct-        -- generate fake resources for all extra aliases-        aliases' = ifromList $ do-            r <- ct ^.. traversed :: [Resource]-            extraAliases <- r ^.. ralias . folded . filtered (/= r ^. rid . iname) :: [Text]-            pure (r ^. rid & iname .~ extraAliases, r ^. rpos)-        classes' = ifromList $ do-            (cn, _ :!: cp) <- itoList clss'-            pure (RIdentifier "class" cn, cp)-    -- Preparation step : all relations to a container become relations to-    -- the stuff that's contained. We build a map of resources, stored by-    -- container.-    -- step 1 - add relations that are stored in resources-    let reorderlink :: (RIdentifier, RIdentifier, LinkType) -> (RIdentifier, RIdentifier, LinkType)-        reorderlink (s, d, RRequire)   = (d, s, RBefore)-        reorderlink (s, d, RSubscribe) = (d, s, RNotify)-        reorderlink x                  = x-        addRR curmap r = iunionWith (<>) curmap newmap-            where-               -- compute the explicit resources, along with the container relationship-               newmap = ifromListWith (<>) resresources-               resid = r ^. rid-               respos = r ^. rpos-               resresources :: [(RIdentifier, [LinkInformation])]-               resresources = do-                   (rawdst, lts) <- itoList (r ^. rrelations)-                   lt <- toList lts-                   let (nsrc, ndst, nlt) = reorderlink (resid, rawdst, lt)-                   pure (nsrc, [LinkInformation nsrc ndst nlt respos])-        step1 :: HashMap RIdentifier [LinkInformation]-        step1 = foldl' addRR mempty ct-    -- step 2 - add other relations (mainly stuff made from the "->"-    -- operator)-    let realign (LinkInformation s d t p) =-            let (ns, nd, nt) = reorderlink (s, d, t)-            in  (ns, [LinkInformation ns nd nt p])-    rels <- map realign <$> use extraRelations-    let step2 = iunionWith (<>) step1 (ifromList rels)-    -- check that all resources are defined, and build graph-    let checkResDef :: (RIdentifier, [LinkInformation]) -> InterpreterMonad (RIdentifier, RIdentifier, [RIdentifier])-        checkResDef (ri, lifs) = do-            let checkExists r msg = do-                    let modulename = getModulename r-                    is_ignored <- isIgnoredModule modulename-                    unless (has (ix r) defs || is_ignored) (throwPosError msg)-                errmsg = "Unknown resource" <+> pretty ri <+> "used in the following relationships:" <+> vcat (map pretty lifs)-            checkExists ri errmsg-            let genlnk :: LinkInformation -> InterpreterMonad RIdentifier-                genlnk lif = do-                    let d = lif ^. linkdst-                    checkExists d ("Unknown resource" <+> pretty d <+> "used in a relation at" <+> showPPos (lif ^. linkPos))-                    pure d-            ds <- mapM genlnk lifs-            pure (ri, ri, ds)-    edgeList <- mapM checkResDef (itoList step2)-    let (graph, gresolver) = Graph.graphFromEdges' edgeList-    -- now check for scc-    let sccs = filter ((>1) . length . Tree.flatten) (Graph.scc graph)-    unless (null sccs) $ do-        let trees = vcat (map showtree sccs)-            showtree = indent 2 . vcat . map (mkp . gresolver) . Tree.flatten-            mkp (a,_,links) = resdesc <+> lnks-                where-                   resdesc = case ct ^. at a of-                       Just r -> pretty r-                       _      -> pretty a-                   lnks = pretty links-        throwPosError $ "Dependency error, the following resources are strongly connected!" </> trees-        -- let edgePairs = concatMap (\(_,k,ls) -> [(k,l) | l <- ls]) edgeList-        -- throwPosError (vcat (map (\(RIdentifier st sn, RIdentifier dt dn) -> "\"" <> pretty st <> ttext sn <> "\" -> \"" <> ttext dt <> ttext dn <> "\"") edgePairs))-    pure step2+  -- merge the loaded classes and resources+  defs' <- fmap (view rpos) <$> use definedResources+  clss' <- use loadedClasses+  let defs = defs' <> classes' <> aliases' <> names'+      names' = view rpos <$> ct+      -- generate fake resources for all extra aliases+      aliases' = ifromList $ do+        r <- ct ^.. traversed :: [Resource]+        extraAliases <- r ^.. ralias . folded . filtered (/= r ^. rid . iname) :: [Text]+        pure (r ^. rid & iname .~ extraAliases, r ^. rpos)+      classes' = ifromList $ do+        (cn, _ :!: cp) <- itoList clss'+        pure (RIdentifier "class" cn, cp)+  -- Preparation step : all relations to a container become relations to+  -- the stuff that's contained. We build a map of resources, stored by+  -- container.+  -- step 1 - add relations that are stored in resources+  let reorderlink :: (RIdentifier, RIdentifier, LinkType) -> (RIdentifier, RIdentifier, LinkType)+      reorderlink (s, d, RRequire) = (d, s, RBefore)+      reorderlink (s, d, RSubscribe) = (d, s, RNotify)+      reorderlink x = x+      addRR curmap r = iunionWith (<>) curmap newmap+        where+          -- compute the explicit resources, along with the container relationship+          newmap = ifromListWith (<>) resresources+          resid = r ^. rid+          respos = r ^. rpos+          resresources :: [(RIdentifier, [LinkInformation])]+          resresources = do+            (rawdst, lts) <- itoList (r ^. rrelations)+            lt <- toList lts+            let (nsrc, ndst, nlt) = reorderlink (resid, rawdst, lt)+            pure (nsrc, [LinkInformation nsrc ndst nlt respos])+      step1 :: HashMap RIdentifier [LinkInformation]+      step1 = foldl' addRR mempty ct+  -- step 2 - add other relations (mainly stuff made from the "->"+  -- operator)+  let realign (LinkInformation s d t p) =+        let (ns, nd, nt) = reorderlink (s, d, t)+         in (ns, [LinkInformation ns nd nt p])+  rels <- map realign <$> use extraRelations+  let step2 = iunionWith (<>) step1 (ifromList rels)+  -- check that all resources are defined, and build graph+  let checkResDef :: (RIdentifier, [LinkInformation]) -> InterpreterMonad (RIdentifier, RIdentifier, [RIdentifier])+      checkResDef (ri, lifs) = do+        let checkExists r msg = do+              let modulename = getModulename r+              is_ignored <- isIgnoredModule modulename+              unless (has (ix r) defs || is_ignored) (throwPosError msg)+            errmsg = "Unknown resource" <+> pretty ri <+> "used in the following relationships:" <+> vcat (map pretty lifs)+        checkExists ri errmsg+        let genlnk :: LinkInformation -> InterpreterMonad RIdentifier+            genlnk lif = do+              let d = lif ^. linkdst+              checkExists d ("Unknown resource" <+> pretty d <+> "used in a relation at" <+> showPPos (lif ^. linkPos))+              pure d+        ds <- mapM genlnk lifs+        pure (ri, ri, ds)+  edgeList <- mapM checkResDef (itoList step2)+  let (graph, gresolver) = Graph.graphFromEdges' edgeList+  -- now check for scc+  let sccs = filter ((> 1) . length . Tree.flatten) (Graph.scc graph)+  unless (null sccs) $ do+    let trees = vcat (map showtree sccs)+        showtree = indent 2 . vcat . map (mkp . gresolver) . Tree.flatten+        mkp (a, _, links) = resdesc <+> lnks+          where+            resdesc = case ct ^. at a of+              Just r -> pretty r+              _ -> pretty a+            lnks = pretty links+    throwPosError $ "Dependency error, the following resources are strongly connected!" </> trees+  -- let edgePairs = concatMap (\(_,k,ls) -> [(k,l) | l <- ls]) edgeList+  -- throwPosError (vcat (map (\(RIdentifier st sn, RIdentifier dt dn) -> "\"" <> pretty st <> ttext sn <> "\" -> \"" <> ttext dt <> ttext dn <> "\"") edgePairs))+  pure step2  -- This functions performs all the actions triggered by calls to the -- realize function or other collectors. It returns a pair of@@ -355,18 +366,19 @@         let filtrd = curmap ^.. folded . filtered fmod -- all the resources that match the selector/realize criteria             vcheck f r = f (r ^. rvirtuality)             (isGoodvirtuality, alterVirtuality) = case rmod ^. rmType of-                RealizeVirtual   -> (vcheck (/= Exported), \r -> pure (r & rvirtuality .~ Normal))-                RealizeCollected -> (vcheck (`elem` [Exported, ExportedRealized]), \r -> pure (r & rvirtuality .~ ExportedRealized))-                DontRealize      -> (vcheck (`elem` [Normal, ExportedRealized]), pure)+              RealizeVirtual -> (vcheck (/= Exported), \r -> pure (r & rvirtuality .~ Normal))+              RealizeCollected -> (vcheck (`elem` [Exported, ExportedRealized]), \r -> pure (r & rvirtuality .~ ExportedRealized))+              DontRealize -> (vcheck (`elem` [Normal, ExportedRealized]), pure)             fmod r = (r ^. rid . itype == rmod ^. rmResType) && checkSearchExpression (rmod ^. rmSearch) r && isGoodvirtuality r             mutation = alterVirtuality >=> rmod ^. rmMutation             applyModification :: Pair FinalCatalog FinalCatalog -> Resource -> InterpreterMonad (Pair FinalCatalog FinalCatalog)             applyModification (cma :!: cmo) r = do-                nr <- mutation r-                let i m = m & at (nr ^. rid) ?~ nr-                pure $ if nr /= r-                             then i cma :!: i cmo-                             else cma :!: cmo+              nr <- mutation r+              let i m = m & at (nr ^. rid) ?~ nr+              pure $+                if nr /= r+                  then i cma :!: i cmo+                  else cma :!: cmo         result <- foldM applyModification (curmap :!: modified) filtrd -- apply the modifiation to all the matching resources         when (rmod ^. rmModifierType == ModifierMustMatch && null filtrd) (throwError (PrettyError ("Could not apply this resource override :" <+> pretty rmod <> ",no matching resource was found.")))         pure result@@ -408,14 +420,15 @@ evaluateStatement :: Statement -> InterpreterMonad [Resource] evaluateStatement r@(ClassDeclaration (ClassDecl cname _ _ _ _)) =   if "::" `Text.isInfixOf` cname-   then nestedDeclarations . at (TopClass, cname) ?= r >> pure []-   else do-     scp <- getScopeName-     let rcname = if scp == "::"-                    then cname-                    else scp <> "::" <> cname-     nestedDeclarations . at (TopClass, rcname) ?= r-     pure []+    then nestedDeclarations . at (TopClass, cname) ?= r >> pure []+    else do+      scp <- getScopeName+      let rcname =+            if scp == "::"+              then cname+              else scp <> "::" <> cname+      nestedDeclarations . at (TopClass, rcname) ?= r+      pure [] evaluateStatement r@(DefineDeclaration (DefineDecl dname _ _ _)) =   if "::" `Text.isInfixOf` dname     then nestedDeclarations . at (TopDefine, dname) ?= r >> pure []@@ -426,14 +439,15 @@         else nestedDeclarations . at (TopDefine, scp <> "::" <> dname) ?= r >> pure [] evaluateStatement r@(ResourceCollectionDeclaration (ResCollDecl ct rtype searchexp mods p)) = do   curPos .= p-  unless (null mods || ct == Collector)+  unless+    (null mods || ct == Collector)     (throwPosError ("It doesn't seem possible to amend attributes with an exported resource collector:" </> pretty r))   when (rtype == "class") (throwPosError "Classes cannot be collected")   rsearch <- resolveSearchExpression searchexp   let et = case ct of-        Collector         -> RealizeVirtual+        Collector -> RealizeVirtual         ExportedCollector -> RealizeCollected-  resModifiers %= (ResourceModifier rtype ModifierCollector et rsearch (\r' -> foldM modifyCollectedAttribute r' mods) p : )+  resModifiers %= (ResourceModifier rtype ModifierCollector et rsearch (\r' -> foldM modifyCollectedAttribute r' mods) p :)   -- Now collected from the PuppetDB !   if et == RealizeCollected     then do@@ -441,10 +455,13 @@       fqdn <- getNodeName       -- we must filter the resources that originated from this host       -- here ! They are also turned into "normal" resources-      res <- toListOf (folded-                      . filtered ( hasn't (rnode . only fqdn) )-                      . to (rvirtuality .~ Normal)-                      ) <$> singleton (PDBGetResources q)+      res <-+        toListOf+          ( folded+              . filtered (hasn't (rnode . only fqdn))+              . to (rvirtuality .~ Normal)+          )+          <$> singleton (PDBGetResources q)       scpdesc <- ContImported <$> getScope       void $ enterScope SENormal scpdesc "importing" p       pushScope scpdesc@@ -456,7 +473,7 @@   curPos .= p   rn1 <- map (fixResourceName t1) <$> resolveExpressionStrings n1   rn2 <- map (fixResourceName t2) <$> resolveExpressionStrings n2-  extraRelations <>= [ LinkInformation (normalizeRIdentifier t1 an1) (normalizeRIdentifier t2 an2) lt p | an1 <- rn1, an2 <- rn2 ]+  extraRelations <>= [LinkInformation (normalizeRIdentifier t1 an1) (normalizeRIdentifier t2 an2) lt p | an1 <- rn1, an2 <- rn2]   pure [] evaluateStatement (ResourceDeclaration (ResDecl t ern eargs virt p)) = do   curPos .= p@@ -470,7 +487,7 @@   curPos .= p   varval <- resolveExpression varexpr   mapM_ (resolveDataType >=> (`checkMatch` varval)) mt-  mapM_ (flip loadVariable varval) varnames+  mapM_ (`loadVariable` varval) varnames   pure [] evaluateStatement (ConditionalDeclaration (ConditionalDecl conds p)) = do   curPos .= p@@ -483,22 +500,23 @@           else restoreCaptureVariables sv *> checkCond xs   checkCond (toList conds) evaluateStatement (ResourceDefaultDeclaration (ResDefaultDecl rtype decls p)) = do-    curPos .= p-    rdecls <- fromAttributeDecls decls-    scp <- getScopeName-    -- invariant that must be respected : the current scope must be created-    -- in "scopes", or nothing gets saved-    preuse (scopes . ix scp) >>= maybe (throwPosError ("INTERNAL ERROR in evaluateStatement ResourceDefaultDeclaration: scope wasn't created - " <> ppline scp)) (const (pure ()))-    let newDefaults = ResDefaults rtype scp rdecls p-        addDefaults x = scopes . ix scp . scopeResDefaults . at rtype ?= x-        -- default merging with parent-        mergedDefaults curdef = newDefaults & resDefValues .~ (rdecls <> (curdef ^. resDefValues))-    preuse (scopes . ix scp . scopeResDefaults . ix rtype) >>= \case-        Nothing -> addDefaults newDefaults-        Just d -> if d ^. resDefSrcScope == scp-                    then throwPosError ("Defaults for resource" <+> ppline rtype <+> "already declared at" <+> showPPos (d ^. resDefPos))-                    else addDefaults (mergedDefaults d)-    pure []+  curPos .= p+  rdecls <- fromAttributeDecls decls+  scp <- getScopeName+  -- invariant that must be respected : the current scope must be created+  -- in "scopes", or nothing gets saved+  preuse (scopes . ix scp) >>= maybe (throwPosError ("INTERNAL ERROR in evaluateStatement ResourceDefaultDeclaration: scope wasn't created - " <> ppline scp)) (const (pure ()))+  let newDefaults = ResDefaults rtype scp rdecls p+      addDefaults x = scopes . ix scp . scopeResDefaults . at rtype ?= x+      -- default merging with parent+      mergedDefaults curdef = newDefaults & resDefValues .~ (rdecls <> (curdef ^. resDefValues))+  preuse (scopes . ix scp . scopeResDefaults . ix rtype) >>= \case+    Nothing -> addDefaults newDefaults+    Just d ->+      if d ^. resDefSrcScope == scp+        then throwPosError ("Defaults for resource" <+> ppline rtype <+> "already declared at" <+> showPPos (d ^. resDefPos))+        else addDefaults (mergedDefaults d)+  pure [] evaluateStatement (ResourceOverrideDeclaration (ResOverrideDecl t urn eargs p)) = do   curPos .= p   raassignements <- fromAttributeDecls eargs@@ -510,7 +528,8 @@   withAssignements <- case curoverrides ^. at rident of     Just (ResRefOverride _ prevass prevpos) -> do       let cm = prevass `Map.intersection` raassignements-      unless (null cm)+      unless+        (null cm)         (throwPosError ("The following parameters were already overriden at" <+> showPPos prevpos <+> ":" <+> pretty cm))       pure (prevass <> raassignements)     Nothing -> pure raassignements@@ -525,9 +544,9 @@           runblock assocs = do             saved <- hfSetvars assocs             res <- evaluateStatementsFoldable (hf ^. hoLambdaStatements)-            hfRestorevars  saved+            hfRestorevars saved             pure res-      in  case hf ^. hoLambdaFunc of+       in case hf ^. hoLambdaFunc of             LambdaFunc "each" -> do               varassocs <- hfGenerateAssociations hf               concat <$> mapM runblock varassocs@@ -535,15 +554,15 @@             -- run the inner code in this scope             LambdaFunc "assert_type" ->               case (hf ^.. hoLambdaExpr . folded, hf ^.. hoLambdaParams . folded) of-                ( [utp, uval], [a, b] ) -> do-                  let typecheck_lambda (LambdaParam ltype lvar)-                        = case ltype of-                            Nothing -> pure lvar-                            Just udt -> do-                              dt <- resolveDataType udt-                              if dt == DTType-                                then pure lvar-                                else throwPosError ("The lambda value can only be a type in assert_type, not" <+> pretty dt)+                ([utp, uval], [a, b]) -> do+                  let typecheck_lambda (LambdaParam ltype lvar) =+                        case ltype of+                          Nothing -> pure lvar+                          Just udt -> do+                            dt <- resolveDataType udt+                            if dt == DTType+                              then pure lvar+                              else throwPosError ("The lambda value can only be a type in assert_type, not" <+> pretty dt)                   mtp <- resolveExpression utp                   val <- resolveExpression uval                   varexpected <- typecheck_lambda a@@ -558,7 +577,8 @@             LambdaFunc "with" -> do               let expressions = hf ^. hoLambdaExpr                   parameters = hf ^. hoLambdaParams-              unless (V.length expressions == V.length parameters)+              unless+                (V.length expressions == V.length parameters)                 (throwPosError ("Mismatched number of arguments and lambda parameters in" <> pretty hf))               assocs <- forM (V.zip expressions parameters) $ \(uval, LambdaParam mt name) -> do                 val <- resolveExpression uval@@ -575,7 +595,7 @@ -- Class evaluation ----------------------------------------------------------- -loadVariable ::  Text -> PValue -> InterpreterMonad ()+loadVariable :: Text -> PValue -> InterpreterMonad () loadVariable varname varval = do   curcont <- getCurContainer   scp <- getScopeName@@ -584,46 +604,57 @@   variableDefined <- preuse (scopes . ix scp . scopeVariables . ix varname)   case (scopeDefined, variableDefined) of     (False, _) -> throwPosError ("Internal error: trying to save a variable in unknown scope" <+> ppline scp)-    (_, Just (_ :!: pp :!: ctx)) -> isParent scp (curcont ^. cctype) >>= \case-      True -> do-          debug("The variable"-               <+> pretty (UVariableReference varname)-               <+> "had been overriden because of some arbitrary inheritance rule that was set up to emulate puppet behaviour. It was defined at"-               <+> showPPos pp-               )-          scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype)-      False -> throwPosError ("Variable" <+> pretty (UVariableReference varname) <+> "already defined at" <+> showPPos pp-                  </> "Context:" <+> pretty ctx-                  </> "Value:" <+> pretty varval-                  </> "Current scope:" <+> ppline scp-                  )-    _ -> scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype)+    (_, Just ((_ :!: pp) :!: ctx)) ->+      isParent scp (curcont ^. cctype) >>= \case+        True -> do+          debug+            ( "The variable"+                <+> pretty (UVariableReference varname)+                <+> "had been overriden because of some arbitrary inheritance rule that was set up to emulate puppet behaviour. It was defined at"+                <+> showPPos pp+            )+          scopes . ix scp . scopeVariables . at varname ?= ((varval :!: p) :!: curcont ^. cctype)+        False ->+          throwPosError+            ( "Variable"+                <+> pretty (UVariableReference varname)+                <+> "already defined at"+                <+> showPPos pp+                </> "Context:"+                <+> pretty ctx+                </> "Value:"+                <+> pretty varval+                </> "Current scope:"+                <+> ppline scp+            )+    _ -> scopes . ix scp . scopeVariables . at varname ?= ((varval :!: p) :!: curcont ^. cctype)  -- This function loads class and define parameters into scope. It checks -- that all mandatory parameters are set, that no extra parameter is declared. -- -- It is able to fill unset parameters with values from Hiera (for classes only) or default values.-loadParameters :: Container PValue -- Resource attributes (resolved)-               -> Parameters -- List of parameters as declared (unresolved)-               -> PPosition -- Current position-               -> Maybe Text --  class name-               -> InterpreterMonad ()+loadParameters ::+  Container PValue -> -- Resource attributes (resolved)+  Parameters -> -- List of parameters as declared (unresolved)+  PPosition -> -- Current position+  Maybe Text -> --  class name+  InterpreterMonad () loadParameters attrs classParams defaultPos classname = do   p <- use curPos   curPos .= defaultPos-  let class_params   = Set.fromList (classParams ^.. folded . _1 . _1)-      spurious_params  = ikeys attrs `Set.difference` class_params-      pp_classdesc   = maybe mempty (\x -> " when including class" <+> ppline x) classname+  let class_params = Set.fromList (classParams ^.. folded . _1 . _1)+      spurious_params = ikeys attrs `Set.difference` class_params+      pp_classdesc = maybe mempty (\x -> " when including class" <+> ppline x) classname        -- the following functions `throwE (Max False)` when there is no value, and `throwE (Max True)` when this value in PUndef.       check_undef :: S.Maybe UDataType -> Maybe PValue -> ExceptT (Max Bool) InterpreterMonad PValue       check_undef (S.Just (UDTOptional _)) Nothing = throwE (Max True)       check_undef _ Nothing = throwE (Max False)       check_undef _ (Just PUndef) = throwE (Max True)-      check_undef _ (Just v)      = pure v+      check_undef _ (Just v) = pure v        check_hiera :: Text -> S.Maybe UDataType -> ExceptT (Max Bool) InterpreterMonad PValue-      check_hiera k dt  = case classname of+      check_hiera k dt = case classname of         Nothing -> throwE (Max False)         Just n -> lift (runHiera (n <> "::" <> k) QFirst) >>= check_undef dt @@ -631,27 +662,27 @@       check_def k = check_undef S.Nothing (attrs ^. at k)        check_default :: S.Maybe Expression -> ExceptT (Max Bool) InterpreterMonad PValue-      check_default S.Nothing     = throwE (Max False)+      check_default S.Nothing = throwE (Max False)       check_default (S.Just expr) = lift (resolveExpression expr) -  unless (null spurious_params)-    $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ppline) $ toList spurious_params) <> pp_classdesc)+  unless (null spurious_params) $+    throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ppline) $ toList spurious_params) <> pp_classdesc)    -- try to set a value to all parameters   -- The order of evaluation is defined / hiera / default-  unset_params <- fmap concat $ for classParams $ \(varname :!: vartype :!: valexpr) ->-      runExceptT (check_def varname <|> check_hiera varname vartype <|> check_default valexpr) >>= \case-        Right val       -> do-          forM_ vartype $ \utype -> do-            dt <- resolveDataType utype-            unless (datatypeMatch dt val)-              $ throwPosError ("Expected type" <+> pretty dt <+> "for parameter" <+> ppline varname <+> "but its value was:" <+> pretty val)-          loadVariable varname val >> pure []-        Left (Max True)  -> loadVariable varname PUndef >> pure []-        Left (Max False) -> pure [varname]+  unset_params <- fmap concat $ for classParams $ \((varname :!: vartype) :!: valexpr) ->+    runExceptT (check_def varname <|> check_hiera varname vartype <|> check_default valexpr) >>= \case+      Right val -> do+        forM_ vartype $ \utype -> do+          dt <- resolveDataType utype+          unless (datatypeMatch dt val) $+            throwPosError ("Expected type" <+> pretty dt <+> "for parameter" <+> ppline varname <+> "but its value was:" <+> pretty val)+        loadVariable varname val >> pure []+      Left (Max True) -> loadVariable varname PUndef >> pure []+      Left (Max False) -> pure [varname]   curPos .= p-  unless (null unset_params)-    $ throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ppline $ toList unset_params) <> pp_classdesc)+  unless (null unset_params) $+    throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ppline $ toList unset_params) <> pp_classdesc)  -- Enters a new scope, checks it is not already defined, and inherits the -- defaults from the current scope@@ -659,49 +690,52 @@ -- Inheriting the defaults is necessary for non native types, because they -- will be expanded in 'finalize', so if this was not done, we would be -- expanding the defines without the defaults applied-enterScope :: ScopeEnteringContext-           -> CurContainerDesc-           -> Text-           -> PPosition-           -> InterpreterMonad Text+enterScope ::+  ScopeEnteringContext ->+  CurContainerDesc ->+  Text ->+  PPosition ->+  InterpreterMonad Text enterScope secontext cont modulename p = do   let scopename = scopeName cont   -- This is a special hack for inheritance, because at this time we   -- have not properly stacked the scopes.   curcaller <- case secontext of-                   SEParent l -> pure (PString $ Text.takeWhile (/=':') l)-                   _          -> resolveVariable "module_name"+    SEParent l -> pure (PString $ Text.takeWhile (/= ':') l)+    _ -> resolveVariable "module_name"   scopeAlreadyDefined <- has (ix scopename) <$> use scopes   let isImported = case cont of-                       ContImported _ -> True-                       _              -> False+        ContImported _ -> True+        _ -> False   -- it is OK to reuse a scope related to imported stuff   unless (scopeAlreadyDefined && isImported) $ do-      when scopeAlreadyDefined (throwPosError ("Internal error: scope" <+> brackets (ppline scopename) <+> "already defined when loading scope for" <+> pretty cont))-      scp <- getScopeName-      -- TODO fill tags-      basescope <- case secontext of-        SEChild prt -> do-            parentscope <- use (scopes . at prt)-            when (isNothing parentscope) (throwPosError ("Internal error: could not find parent scope" <+> ppline prt))-            let Just psc = parentscope-            pure (psc & scopeParent .~ S.Just prt)-        _ -> do-            curdefs <- use (scopes . ix scp . scopeResDefaults)-            pure $ ScopeInformation mempty curdefs mempty (CurContainer cont mempty) mempty S.Nothing-      scopes . at scopename ?= basescope-  scopes . ix scopename . scopeVariables . at "caller_module_name" ?= (curcaller          :!: p :!: cont)-  scopes . ix "::"      . scopeVariables . at "calling_module"     ?= (curcaller          :!: p :!: cont)-  scopes . ix scopename . scopeVariables . at "module_name"        ?= (PString modulename :!: p :!: cont)+    when scopeAlreadyDefined (throwPosError ("Internal error: scope" <+> brackets (ppline scopename) <+> "already defined when loading scope for" <+> pretty cont))+    scp <- getScopeName+    -- TODO fill tags+    basescope <- case secontext of+      SEChild prt -> do+        parentscope <- use (scopes . at prt)+        psc <- case parentscope of+          Just x -> pure x+          Nothing -> throwPosError ("Internal error: could not find parent scope" <+> ppline prt)+        pure (psc & scopeParent .~ S.Just prt)+      _ -> do+        curdefs <- use (scopes . ix scp . scopeResDefaults)+        pure $ ScopeInformation mempty curdefs mempty (CurContainer cont mempty) mempty S.Nothing+    scopes . at scopename ?= basescope+  scopes . ix scopename . scopeVariables . at "caller_module_name" ?= ((curcaller :!: p) :!: cont)+  scopes . ix "::" . scopeVariables . at "calling_module" ?= ((curcaller :!: p) :!: cont)+  scopes . ix scopename . scopeVariables . at "module_name" ?= ((PString modulename :!: p) :!: cont)   debug ("enterScope, scopename=" <> ppline scopename <+> "caller_module_name=" <> pretty curcaller <+> "module_name=" <> ppline modulename)   pure scopename  -- Instantiate/declare a class-loadClass :: Text-          -> S.Maybe Text -- Set if this is an inheritance load, so that we can set calling module properly-          -> Container PValue -- Resource attributes-          -> ClassIncludeType-          -> InterpreterMonad [Resource]+loadClass ::+  Text ->+  S.Maybe Text -> -- Set if this is an inheritance load, so that we can set calling module properly+  Container PValue -> -- Resource attributes+  ClassIncludeType ->+  InterpreterMonad [Resource] loadClass name loadedfrom attrs incltype = do   let name' = dropInitialColons name   nodename <- getNodeName@@ -712,45 +746,49 @@   preuse (loadedClasses . ix name' . _2) >>= \case     Just pp -> case incltype of       ClassIncludeLike -> pure []-      _ -> throwPosError-           $ "Can't include class" <+> ppline name' <+> "twice when using the resource-like syntax (first occurence at"-             <+> showPPos pp <> ")"+      _ ->+        throwPosError $+          "Can't include class"+            <+> ppline name'+            <+> "twice when using the resource-like syntax (first occurence at"+            <+> showPPos pp <> ")"     Nothing -> do-        loadedClasses . at name' ?= (incltype :!: pos) -- set the position of the loaded class-        let modulename = getModulename (RIdentifier "class" name')-        is_ignored <- isIgnoredModule modulename-        if is_ignored-          then pure mempty-          else do-            -- load the actual class, note we are not changing the current position right now-            (spurious, stmt) <- interpretTopLevel TopClass name'-            ClassDecl _ params inh stmts curpos <- extractPrism "loadClass" _ClassDecl stmt-            -- check if we need to define a resource representing the class-            -- This will be the case for the first standard include-            inhstmts <- case inh of-              S.Nothing     -> pure []-              S.Just ihname -> loadClass ihname (S.Just name') mempty ClassIncludeLike-            let !scopedesc = ContClass name'-                secontext = case (inh, loadedfrom) of-                  (S.Just x,_) -> SEChild (dropInitialColons x)-                  (_,S.Just x) -> SEParent (dropInitialColons x)-                  _            -> SENormal-            void $ enterScope secontext scopedesc modulename pos-            classresource <- if incltype == ClassIncludeLike-                               then do-                                 scp <- use curScope-                                 fqdn <- getNodeName-                                 pure [Resource (RIdentifier "class" name') (Set.singleton name') mempty mempty scp Normal mempty pos fqdn]-                               else pure []-            pushScope scopedesc-            loadVariable "title" (PString name')-            loadVariable "name" (PString name')-            loadParameters attrs params curpos (Just name')-            curPos .= curpos-            res <- evaluateStatementsFoldable stmts-            out <- finalize (classresource <> spurious <> inhstmts <> res)-            popScope-            pure out+      loadedClasses . at name' ?= (incltype :!: pos) -- set the position of the loaded class+      let modulename = getModulename (RIdentifier "class" name')+      is_ignored <- isIgnoredModule modulename+      if is_ignored+        then pure mempty+        else do+          -- load the actual class, note we are not changing the current position right now+          (spurious, stmt) <- interpretTopLevel TopClass name'+          ClassDecl _ params inh stmts curpos <- extractPrism "loadClass" _ClassDecl stmt+          -- check if we need to define a resource representing the class+          -- This will be the case for the first standard include+          inhstmts <- case inh of+            S.Nothing -> pure []+            S.Just ihname -> loadClass ihname (S.Just name') mempty ClassIncludeLike+          let !scopedesc = ContClass name'+              secontext = case (inh, loadedfrom) of+                (S.Just x, _) -> SEChild (dropInitialColons x)+                (_, S.Just x) -> SEParent (dropInitialColons x)+                _ -> SENormal+          void $ enterScope secontext scopedesc modulename pos+          classresource <-+            if incltype == ClassIncludeLike+              then do+                scp <- use curScope+                fqdn <- getNodeName+                pure [Resource (RIdentifier "class" name') (Set.singleton name') mempty mempty scp Normal mempty pos fqdn]+              else pure []+          pushScope scopedesc+          loadVariable "title" (PString name')+          loadVariable "name" (PString name')+          loadParameters attrs params curpos (Just name')+          curPos .= curpos+          res <- evaluateStatementsFoldable stmts+          out <- finalize (classresource <> spurious <> inhstmts <> res)+          popScope+          pure out  ----------------------------------------------------------- -- Resource stuff@@ -768,23 +806,23 @@ addTagResource r rv = r & rtags . contains rv .~ True  addAttribute :: OverrideType -> Text -> Resource -> PValue -> InterpreterMonad Resource-addAttribute _ "alias"     r v = (\rv -> r & ralias . contains rv .~ True) <$> resolvePValueString v-addAttribute _ "audit"     r _ = use curPos >>= \p -> warn ("Metaparameter audit ignored at" <+> showPPos p) >> pure r-addAttribute _ "loglevel"  r _ = use curPos >>= \p -> warn ("Metaparameter loglevel ignored at" <+> showPPos p) >> pure r-addAttribute _ "schedule"  r _ = use curPos >>= \p -> warn ("Metaparameter schedule ignored at" <+> showPPos p) >> pure r-addAttribute _ "stage"     r _ = use curPos >>= \p -> warn ("Metaparameter stage ignored at" <+> showPPos p) >> pure r-addAttribute _ "tag"       r (PArray v) = foldM (\cr cv -> addTagResource cr <$> resolvePValueString cv) r (toList v)-addAttribute _ "tag"       r v = addTagResource r <$> resolvePValueString v-addAttribute _ "before"    r d = addRelationship RBefore d r-addAttribute _ "notify"    r d = addRelationship RNotify d r-addAttribute _ "require"   r d = addRelationship RRequire d r+addAttribute _ "alias" r v = (\rv -> r & ralias . contains rv .~ True) <$> resolvePValueString v+addAttribute _ "audit" r _ = use curPos >>= \p -> warn ("Metaparameter audit ignored at" <+> showPPos p) >> pure r+addAttribute _ "loglevel" r _ = use curPos >>= \p -> warn ("Metaparameter loglevel ignored at" <+> showPPos p) >> pure r+addAttribute _ "schedule" r _ = use curPos >>= \p -> warn ("Metaparameter schedule ignored at" <+> showPPos p) >> pure r+addAttribute _ "stage" r _ = use curPos >>= \p -> warn ("Metaparameter stage ignored at" <+> showPPos p) >> pure r+addAttribute _ "tag" r (PArray v) = foldM (\cr cv -> addTagResource cr <$> resolvePValueString cv) r (toList v)+addAttribute _ "tag" r v = addTagResource r <$> resolvePValueString v+addAttribute _ "before" r d = addRelationship RBefore d r+addAttribute _ "notify" r d = addRelationship RNotify d r+addAttribute _ "require" r d = addRelationship RRequire d r addAttribute _ "subscribe" r d = addRelationship RSubscribe d r addAttribute b t r v = go t r v   where     go = case b of-      CantOverride    -> setAttribute-      Replace         -> overrideAttribute-      CantReplace     -> defaultAttribute+      CantOverride -> setAttribute+      Replace -> overrideAttribute+      CantReplace -> defaultAttribute       AppendAttribute -> appendAttribute  setAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource@@ -812,18 +850,18 @@ appendAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource appendAttribute attributename res value = do   nvalue <- case (res ^. rattributes . at attributename, value) of-    (Nothing, _)                -> pure value+    (Nothing, _) -> pure value     (Just (PArray a), PArray b) -> pure (PArray (a <> b))-    (Just (PArray a), b)        -> pure (PArray (V.snoc a b))-    (Just a, PArray b)          -> pure (PArray (V.cons a b))-    (Just a, b)                 -> pure (PArray (V.fromList [a,b]))+    (Just (PArray a), b) -> pure (PArray (V.snoc a b))+    (Just a, PArray b) -> pure (PArray (V.cons a b))+    (Just a, b) -> pure (PArray (V.fromList [a, b]))   pure (res & rattributes . at attributename ?~ nvalue)  defaultAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource defaultAttribute attributename res value =   pure $ case res ^. rattributes . at attributename of     Nothing -> res & rattributes . at attributename ?~ value-    Just _  -> res+    Just _ -> res  modifyCollectedAttribute :: Resource -> AttributeDecl -> InterpreterMonad Resource modifyCollectedAttribute res attrdecl =@@ -842,7 +880,7 @@         _ -> throwPosError ("A hash was expected, not" <+> pretty resolved)  registerResource :: Text -> Text -> Container PValue -> Virtuality -> PPosition -> InterpreterMonad [Resource]-registerResource "class" _ _ Virtual p  = curPos .= p >> throwPosError "Cannot declare a virtual class (or perhaps you can, but I do not know what this means)"+registerResource "class" _ _ Virtual p = curPos .= p >> throwPosError "Cannot declare a virtual class (or perhaps you can, but I do not know what this means)" registerResource "class" _ _ Exported p = curPos .= p >> throwPosError "Cannot declare an exported class (or perhaps you can, but I do not know what this means)" registerResource t rn arg vrt p = do   curPos .= p@@ -853,11 +891,11 @@   let !defaulttags = {-# SCC "rrGetTags" #-} Set.fromList (t : classtags) <> tgs       allsegs x = x : Text.splitOn "::" x       (!classtags, !defaultLink) = getClassTags cnt-      getClassTags (ContClass cn      ) = (allsegs cn,RIdentifier "class" cn)-      getClassTags (ContDefine dt dn _) = (allsegs dt,normalizeRIdentifier dt dn)-      getClassTags  ContRoot            = ([],RIdentifier "class" "::")-      getClassTags (ContImported _    ) = ([],RIdentifier "class" "::")-      getClassTags (ContImport _ _    ) = ([],RIdentifier "class" "::")+      getClassTags (ContClass cn) = (allsegs cn, RIdentifier "class" cn)+      getClassTags (ContDefine dt dn _) = (allsegs dt, normalizeRIdentifier dt dn)+      getClassTags ContRoot = ([], RIdentifier "class" "::")+      getClassTags (ContImported _) = ([], RIdentifier "class" "::")+      getClassTags (ContImport _ _) = ([], RIdentifier "class" "::")       defaultRelation = Map.singleton defaultLink (Set.singleton RRequire)   allScope <- use curScope   fqdn <- getNodeName@@ -865,32 +903,38 @@   r <- ifoldlM (addAttribute CantOverride) baseresource arg   let resid = normalizeRIdentifier t rn   case t of-    "class" -> {-# SCC "rrClass" #-} do-      definedResources . at resid ?= r-      (r:) <$> loadClass rn S.Nothing (r^.rattributes) ClassResourceLike-    _       -> {-# SCC "rrGeneralCase" #-}+    "class" ->+      {-# SCC "rrClass" #-}+      do+        definedResources . at resid ?= r+        (r :) <$> loadClass rn S.Nothing (r ^. rattributes) ClassResourceLike+    _ ->+      {-# SCC "rrGeneralCase" #-}       use (definedResources . at resid) >>= \case-        Just otheres -> throwPosError-                        $ "Resource" <+> pretty resid <+> "already defined:"-                          </> pretty r </> pretty otheres+        Just otheres ->+          throwPosError $+            "Resource"+              <+> pretty resid+              <+> "already defined:"+              </> pretty r+              </> pretty otheres         Nothing -> do           definedResources . at resid ?= r           pure [r] - -- functions : this can't really be exported as it uses a lot of stuff from -- this module ... mainFunctionCall :: Text -> [PValue] -> InterpreterMonad [Resource] mainFunctionCall "showscope" _ = use curScope >>= warn . pretty >> pure [] -- The logging functions-mainFunctionCall "alert"   a = logWithModifier Log.ALERT        red         a-mainFunctionCall "crit"    a = logWithModifier Log.CRITICAL     red         a-mainFunctionCall "debug"   a = logWithModifier Log.DEBUG        dullwhite   a-mainFunctionCall "emerg"   a = logWithModifier Log.EMERGENCY    red         a-mainFunctionCall "err"     a = logWithModifier Log.ERROR        dullred     a-mainFunctionCall "info"    a = logWithModifier Log.INFO         dullgreen   a-mainFunctionCall "notice"  a = logWithModifier Log.NOTICE       white       a-mainFunctionCall "warning" a = logWithModifier Log.WARNING      dullyellow  a+mainFunctionCall "alert" a = logWithModifier Log.ALERT red a+mainFunctionCall "crit" a = logWithModifier Log.CRITICAL red a+mainFunctionCall "debug" a = logWithModifier Log.DEBUG dullwhite a+mainFunctionCall "emerg" a = logWithModifier Log.EMERGENCY red a+mainFunctionCall "err" a = logWithModifier Log.ERROR dullred a+mainFunctionCall "info" a = logWithModifier Log.INFO dullgreen a+mainFunctionCall "notice" a = logWithModifier Log.NOTICE white a+mainFunctionCall "warning" a = logWithModifier Log.WARNING dullyellow a mainFunctionCall "contain" includes =   concat <$> mapM doContain includes   where@@ -928,7 +972,7 @@ mainFunctionCall "realize" args = do   pos <- use curPos   let updateMod (PResourceReference t rn) =-        resModifiers %= (ResourceModifier t ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) pure pos : )+        resModifiers %= (ResourceModifier t ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) pure pos :)       updateMod x = throwPosError ("realize(): all arguments must be resource references, not" <+> pretty x)   mapM_ updateMod args   pure []@@ -937,7 +981,7 @@   let addTag x = scopes . ix scp . scopeExtraTags . contains x .= True   mapM_ (resolvePValueString >=> addTag) args   pure []-mainFunctionCall "fail" [x] = ("fail:" <+>) . dullred . ppline <$> resolvePValueString x >>= throwPosError+mainFunctionCall "fail" [x] = resolvePValueString x >>= throwPosError . ("fail:" <+>) . dullred . ppline mainFunctionCall "fail" _ = throwPosError "fail(): This function takes a single argument" -- hiera_include does a unique merge lookup for the requested key, then calls the include function on the resulting array. mainFunctionCall "hiera_include" [x] = do@@ -959,7 +1003,7 @@   prntline "Variables in local scope :"   scp <- getScopeName   vars <- use (scopes . ix scp . scopeVariables)-  forM_ (sortOn fst (itoList vars)) $ \(idx, pv :!: _ :!: _) -> prntline $ indentln $ ppline idx <> " -> " <> pretty pv+  forM_ (sortOn fst (itoList vars)) $ \(idx, (pv :!: _) :!: _) -> prntline $ indentln $ ppline idx <> " -> " <> pretty pv   pure [] mainFunctionCall "assert_type" [PType dt, v] =   if datatypeMatch dt v@@ -975,14 +1019,14 @@  ensurePackages :: [PValue] -> InterpreterMonad [Resource] ensurePackages [packages] = ensurePackages [packages, PHash mempty]-ensurePackages [PString p, x] = ensurePackages [ PArray (V.singleton (PString p)), x ]+ensurePackages [PString p, x] = ensurePackages [PArray (V.singleton (PString p)), x] ensurePackages [PArray packages, PHash defparams] = do   checkStrict     "The use of the 'ensure_packages' function is a code smell."     "The 'ensure_packages' function is not allowed in strict mode."   concat <$> for packages (resolvePValueString >=> ensureResource' "package" (Map.singleton "ensure" "present" <> defparams))-ensurePackages [PArray _,_] = throwPosError "ensure_packages(): the second argument must be a hash."-ensurePackages [_,_] = throwPosError "ensure_packages(): the first argument must be a string or an array of strings."+ensurePackages [PArray _, _] = throwPosError "ensure_packages(): the second argument must be a hash."+ensurePackages [_, _] = throwPosError "ensure_packages(): the first argument must be a string or an array of strings." ensurePackages _ = throwPosError "ensure_packages(): requires one or two arguments."  -- Takes a resource type, title, and a hash of attributes that describe the resource.@@ -995,7 +1039,7 @@     "The 'ensure_resource' function is not allowed in strict mode."   ensureResource' t params title ensureResource [t, PArray arr, params] = concat <$> mapM (\r -> ensureResource [t, r, params]) (V.toList arr)-ensureResource [t,title] = ensureResource [t,title,PHash mempty]+ensureResource [t, title] = ensureResource [t, title, PHash mempty] ensureResource [_, PString _, PHash _] = throwPosError "ensureResource(): The first argument must be a string." ensureResource [PString _, _, PHash _] = throwPosError "ensureResource(): The second argument must be a string." ensureResource [PString _, PString _, _] = throwPosError "ensureResource(): The thrid argument must be a hash."@@ -1008,12 +1052,11 @@     then pure []     else use curPos >>= registerResource t title params Normal - ----------------------------------------------------------- -- Specific utils functions that depends on this modules ----------------------------------------------------------- -evaluateStatementsFoldable :: Foldable f => f Statement -> InterpreterMonad [Resource]+evaluateStatementsFoldable :: (Foldable f) => f Statement -> InterpreterMonad [Resource] evaluateStatementsFoldable = fmap concat . mapM evaluateStatement . toList  -- A helper function for the various loggers
src/Puppet/Interpreter/Helpers.hs view
@@ -1,56 +1,58 @@+{-# LANGUAGE RankNTypes #-} {-# OPTIONS_HADDOCK hide, prune, ignore-exports #-}-{-# LANGUAGE RankNTypes            #-}  -- | Internal helpers module. module Puppet.Interpreter.Helpers where -import           XPrelude--import           Control.Monad.Operational-import           Control.Monad.Writer.Class-import qualified Data.HashMap.Strict        as Map-import qualified Data.Vector                as Vector-import qualified Data.List                  as List-import qualified Data.Maybe.Strict          as S-import qualified Data.Text                  as Text-import qualified Data.Text.Encoding         as Text-import qualified System.Log.Logger          as Log--import           Facter-import           Puppet.Interpreter.Types-+import Control.Monad.Operational+import Control.Monad.Writer.Class+import qualified Data.HashMap.Strict as Map+import qualified Data.List as List+import qualified Data.Maybe.Strict as S+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Vector as Vector+import Facter+import GHC.Err as Err+import Puppet.Interpreter.Types+import qualified System.Log.Logger as Log+import XPrelude hiding (key) -initialState :: Facts-             -> Container Text -- ^ Server settings-             -> InterpreterState+initialState ::+  Facts ->+  -- | Server settings+  Container Text ->+  InterpreterState initialState facts settings =   InterpreterState baseVars initialclass mempty [ContRoot] (initialPPos mempty) mempty [] []   where-    callervars = Map.fromList [("caller_module_name", PString "::" :!: (initialPPos mempty) :!: ContRoot), ("module_name", PString "::" :!: (initialPPos mempty) :!: ContRoot)]+    callervars = Map.fromList [("caller_module_name", (PString "::" :!: initialPPos mempty) :!: ContRoot), ("module_name", (PString "::" :!: initialPPos mempty) :!: ContRoot)]     factvars =       -- add the `facts` key: https://docs.puppet.com/puppet/4.10/lang_facts_and_builtin_vars.html#accessing-facts-from-puppet-code       let facts' = Map.insert "facts" (PHash facts) facts-      in fmap (\x -> x :!: initialPPos "facts" :!: ContRoot) facts'-    settingvars = fmap (\x -> PString x :!: initialPPos "settings" :!: ContClass "settings") settings-    baseVars = Map.fromList [ ("::", ScopeInformation (factvars `mappend` callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing)-                           , ("settings", ScopeInformation settingvars mempty mempty (CurContainer (ContClass "settings") mempty) mempty S.Nothing)-                           ]-    initialclass = mempty & at "::" ?~ (ClassIncludeLike :!: (initialPPos mempty))+       in fmap (\x -> (x :!: initialPPos "facts") :!: ContRoot) facts'+    settingvars = fmap (\x -> (PString x :!: initialPPos "settings") :!: ContClass "settings") settings+    baseVars =+      Map.fromList+        [ ("::", ScopeInformation (factvars `mappend` callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing),+          ("settings", ScopeInformation settingvars mempty mempty (CurContainer (ContClass "settings") mempty) mempty S.Nothing)+        ]+    initialclass = mempty & at "::" ?~ (ClassIncludeLike :!: initialPPos mempty)  getModulename :: RIdentifier -> Text getModulename (RIdentifier t n) =   let gm x =         case Text.splitOn "::" x of-          []    -> x-          (y:_) -> y-  in case t of-    "class" -> gm n-    _       -> gm t+          [] -> x+          (y : _) -> y+   in case t of+        "class" -> gm n+        _ -> gm t  extractPrism :: Doc -> Prism' a b -> a -> InterpreterMonad b extractPrism msg p a =   case preview p a of-    Just b  -> return b+    Just b -> return b     Nothing -> throwPosError ("Could not extract prism in" <+> msg)  -- Scope@@ -64,21 +66,21 @@ getScopeName = scopeName <$> getScope  scopeName :: CurContainerDesc -> Text-scopeName (ContRoot        ) = "::"-scopeName (ContImported x  ) = "::imported::" `Text.append` scopeName x-scopeName (ContClass x     ) = x+scopeName ContRoot = "::"+scopeName (ContImported x) = "::imported::" `Text.append` scopeName x+scopeName (ContClass x) = x scopeName (ContDefine dt dn _) = "#define/" `Text.append` dt `Text.append` "/" `Text.append` dn-scopeName (ContImport _ x  ) = "::import::" `Text.append` scopeName x+scopeName (ContImport _ x) = "::import::" `Text.append` scopeName x  containerModName :: CurContainerDesc -> Text-containerModName (ContRoot        )  = "::"-containerModName (ContImported x  )  = containerModName x-containerModName (ContClass x     )  = x+containerModName ContRoot = "::"+containerModName (ContImported x) = containerModName x+containerModName (ContClass x) = x containerModName (ContDefine dt _ _) = dt-containerModName (ContImport _ x  )  = containerModName x+containerModName (ContImport _ x) = containerModName x  getScope :: InterpreterMonad CurContainerDesc-{-# INLINABLE getScope #-}+{-# INLINEABLE getScope #-} getScope =   use curScope >>= \s ->     if null s@@ -86,7 +88,7 @@       else pure (List.head s)  getCurContainer :: InterpreterMonad CurContainer-{-# INLINABLE getCurContainer #-}+{-# INLINEABLE getCurContainer #-} getCurContainer = do   scp <- getScopeName   preuse (scopes . ix scp . scopeContainer) >>= \case@@ -100,19 +102,20 @@ getPuppetPaths :: InterpreterMonad PuppetDirPaths getPuppetPaths = singleton PuppetPaths -getNodeName:: InterpreterMonad NodeName+getNodeName :: InterpreterMonad NodeName getNodeName = singleton GetNodeName  -- | Give key such as "os.family" -- look an hash of facts to retrieve deepest PValue lookupFacts :: Text -> HashMap Text PValue -> Maybe PValue lookupFacts key facts =-  let (k0:ks) = Text.splitOn "." key+  let (k0, ks) = case Text.splitOn "." key of+        a : b -> (a, b)+        _ -> Err.error "should not happen"       f k = \case         Just (PHash h) -> Map.lookup k h         x -> x-  in-  List.foldr f (Map.lookup k0 facts) ks+   in List.foldr f (Map.lookup k0 facts) ks  -- | Ask the value of a fact given a specified key -- The fact set comes from the reader used by the interpreter monad.@@ -126,9 +129,12 @@  -- | Throws an error if we are in strict mode -- A warning in permissive mode-checkStrict :: Doc -- ^ The warning message.-            -> Doc -- ^ The error message.-            -> InterpreterMonad ()+checkStrict ::+  -- | The warning message.+  Doc ->+  -- | The error message.+  Doc ->+  InterpreterMonad () checkStrict wrn err = do   extMod <- isExternalModule   let priority =@@ -152,23 +158,23 @@     isExternal = singleton . IsExternalModule . List.head . Text.splitOn "::"  -- Logging ---error :: MonadWriter InterpreterWriter m => Doc -> m ()+error :: (MonadWriter InterpreterWriter m) => Doc -> m () error d = tell [Log.ERROR :!: d] -critical :: MonadWriter InterpreterWriter m => Doc -> m ()+critical :: (MonadWriter InterpreterWriter m) => Doc -> m () critical d = tell [Log.CRITICAL :!: d] -warn :: MonadWriter InterpreterWriter m => Doc -> m ()+warn :: (MonadWriter InterpreterWriter m) => Doc -> m () warn d = tell [Log.WARNING :!: d] -debug :: MonadWriter InterpreterWriter m => Doc -> m ()+debug :: (MonadWriter InterpreterWriter m) => Doc -> m () debug d = tell [Log.DEBUG :!: d] -logWriter :: MonadWriter InterpreterWriter m => Log.Priority -> Doc -> m ()+logWriter :: (MonadWriter InterpreterWriter m) => Log.Priority -> Doc -> m () logWriter prio d = tell [prio :!: d]  safeDecodeUtf8 :: ByteString -> InterpreterMonad Text-{-# INLINABLE safeDecodeUtf8 #-}+{-# INLINEABLE safeDecodeUtf8 #-} safeDecodeUtf8 i = pure (Text.decodeUtf8 i)  normalizeRIdentifier :: Text -> Text -> RIdentifier@@ -176,12 +182,13 @@  extractScope :: InterpreterState -> Maybe (Text, Container ScopeInformation) extractScope s =-  let cscope = s ^. curScope in-  if null cscope-     then Nothing-     else let scope_name = scopeName (List.head cscope)+  let cscope = s ^. curScope+   in if null cscope+        then Nothing+        else+          let scope_name = scopeName (List.head cscope)               classes = (PArray . Vector.fromList . map PString . Map.keys) (s ^. loadedClasses)               scps = s ^. scopes               container_desc = fromMaybe ContRoot (scps ^? ix scope_name . scopeContainer . cctype) -- get the current containder description-              cscps = scps & ix scope_name . scopeVariables . at "classes" ?~ ( classes :!: (initialPPos mempty) :!: container_desc )-          in  Just (scope_name, cscps)+              cscps = scps & ix scope_name . scopeVariables . at "classes" ?~ ((classes :!: initialPPos mempty) :!: container_desc)+           in Just (scope_name, cscps)
src/Puppet/Interpreter/IO.hs view
@@ -1,115 +1,118 @@ {-# LANGUAGE GADTs #-}  -- | This is an internal module.-module Puppet.Interpreter.IO (-    interpretMonad-  ) where--import           XPrelude--import           Control.Monad.Operational-import           Control.Monad.State.Strict-import qualified Data.Either.Strict               as S-import qualified Data.Text                        as Text--import           Hiera.Server-import           Puppet.Interpreter.PrettyPrinter ()-import           Puppet.Interpreter.Types-import           PuppetDB+module Puppet.Interpreter.IO+  ( interpretMonad,+  )+where +import Control.Monad.Operational+import Control.Monad.State.Strict+import qualified Data.Either.Strict as S+import qualified Data.Text as Text+import Hiera.Server+import Puppet.Interpreter.PrettyPrinter ()+import Puppet.Interpreter.Types+import PuppetDB+import XPrelude  -- | The operational interpreter function-interpretMonad :: Monad m-               => InterpreterReader m-               -> InterpreterState-               -> InterpreterMonad a-               -> m (Either PrettyError a, InterpreterState, InterpreterWriter)-interpretMonad r s0 instr = let (!p, !s1) = runState (viewT instr) s0-                            in eval r s1 p+interpretMonad ::+  (Monad m) =>+  InterpreterReader m ->+  InterpreterState ->+  InterpreterMonad a ->+  m (Either PrettyError a, InterpreterState, InterpreterWriter)+interpretMonad r s0 instr =+  let (!p, !s1) = runState (viewT instr) s0+   in eval r s1 p  -- The internal (not exposed) eval function-eval :: Monad m-     => InterpreterReader m-     -> InterpreterState-     -> ProgramViewT InterpreterInstr (State InterpreterState) a-     -> m (Either PrettyError a, InterpreterState, InterpreterWriter)+eval ::+  (Monad m) =>+  InterpreterReader m ->+  InterpreterState ->+  ProgramViewT InterpreterInstr (State InterpreterState) a ->+  m (Either PrettyError a, InterpreterState, InterpreterWriter) eval _ s (Return x) = return (Right x, s, mempty) eval r s (a :>>= k) =-    let runInstr = interpretMonad r s . k -- run one instruction-        thpe = interpretMonad r s . throwPosError . getError-        pdb = r^.readerPdbApi-        strFail iof errf = iof >>= \case-            Left rr -> thpe (errf (ppstring rr))-            Right x -> runInstr x-        canFail iof = iof >>= \case-            S.Left err -> thpe err-            S.Right x -> runInstr x-        canFailX iof = runExceptT iof >>= \case-            Left err -> thpe err-            Right x -> runInstr x-        logStuff x c = (_3 %~ (x <>)) <$> c-    in-    case a of-      IsStrict                     -> runInstr (r ^. readerIsStrict)-      ExternalFunction name args  ->-        -- #271: namespace is currently ignored when looking up puppetlabs functions-        let (nsp, name') = Text.breakOnEnd "::" name-        in-        case r ^. readerExternalFunc . at name' of-          Just fn -> interpretMonad r s ( fn args >>= k)-          Nothing -> thpe (PrettyError ("Unknown function: (" <> ppline nsp <> ")" <> ppline name'))-      GetStatement toptype topname -> canFail ((r ^. readerGetStatement) toptype topname)-      ComputeTemplate src st       -> canFail ((r ^. readerGetTemplate) src st r)-      WriterTell t                 -> logStuff t (runInstr ())-      WriterPass _                 -> thpe "WriterPass"-      WriterListen _               -> thpe "WriterListen"-      PuppetPaths                  -> runInstr (r ^. readerPuppetPaths)-      Facts                        -> runInstr (r ^. readerFacts)-      RebaseFile                   -> runInstr (r ^. readerRebaseFile)-      GetNativeTypes               -> runInstr (r ^. readerNativeTypes)-      ErrorThrow d                 -> return (Left d, s, mempty)-      GetNodeName                  -> runInstr (r ^. readerNodename)-      HieraQuery scps q t          ->-        runExceptT (queryHiera (r ^. readerHieraQuery) scps q t) >>= either thpe runInstr-      PDBInformation               -> pdbInformation pdb >>= runInstr-      PDBReplaceCatalog w          -> canFailX (replaceCatalog pdb w)-      PDBReplaceFacts fcts         -> canFailX (replaceFacts pdb fcts)-      PDBDeactivateNode nn         -> canFailX (deactivateNode pdb nn)-      PDBGetFacts q                -> canFailX (getPDBFacts pdb q)-      PDBGetResources q            -> canFailX (getResources pdb q)-      PDBGetNodes q                -> canFailX (getNodes pdb q)-      PDBCommitDB                  -> canFailX (commitDB pdb)-      PDBGetResourcesOfNode nn q   -> canFailX (getResourcesOfNode pdb nn q)-      GetCurrentCallStack          -> (r ^. readerIoMethods . ioGetCurrentCallStack) >>= runInstr-      ReadFile fls                 -> strFail ((r ^. readerIoMethods . ioReadFile) fls) (const $ PrettyError ("No file found in " <> list (map ppline fls)))-      TraceEvent e                 -> (r ^. readerIoMethods . ioTraceEvent) e >>= runInstr-      IsIgnoredModule m            -> runInstr (r ^. readerIgnoredModules . contains m)-      IsExternalModule m           -> runInstr (r ^. readerExternalModules . contains m)-      -- on error, the program state is RESET and the logged messages are dropped-      ErrorCatch atry ahandle      -> do-        (eres, s', w) <- interpretMonad r s atry-        case eres of-          Left rr -> interpretMonad r s (ahandle rr >>= k)-          Right x -> logStuff w (interpretMonad r s' (k x))+  let runInstr = interpretMonad r s . k -- run one instruction+      thpe = interpretMonad r s . throwPosError . getError+      pdb = r ^. readerPdbApi+      strFail iof errf =+        iof >>= \case+          Left rr -> thpe (errf (ppstring rr))+          Right x -> runInstr x+      canFail iof =+        iof >>= \case+          S.Left err -> thpe err+          S.Right x -> runInstr x+      canFailX iof =+        runExceptT iof >>= \case+          Left err -> thpe err+          Right x -> runInstr x+      logStuff x c = (_3 %~ (x <>)) <$> c+   in case a of+        IsStrict -> runInstr (r ^. readerIsStrict)+        ExternalFunction "Sensitive" [arg] -> interpretMonad r s (k (PSensitive arg))+        ExternalFunction name args ->+          -- #271: namespace is currently ignored when looking up puppetlabs functions+          let (nsp, name') = Text.breakOnEnd "::" name+           in case r ^. readerExternalFunc . at name' of+                Just fn -> interpretMonad r s (fn args >>= k)+                Nothing -> thpe (PrettyError ("Unknown function: (" <> ppline nsp <> ")" <> ppline name'))+        GetStatement toptype topname -> canFail ((r ^. readerGetStatement) toptype topname)+        ComputeTemplate src st -> canFail ((r ^. readerGetTemplate) src st r)+        WriterTell t -> logStuff t (runInstr ())+        WriterPass _ -> thpe "WriterPass"+        WriterListen _ -> thpe "WriterListen"+        PuppetPaths -> runInstr (r ^. readerPuppetPaths)+        Facts -> runInstr (r ^. readerFacts)+        RebaseFile -> runInstr (r ^. readerRebaseFile)+        GetNativeTypes -> runInstr (r ^. readerNativeTypes)+        ErrorThrow d -> return (Left d, s, mempty)+        GetNodeName -> runInstr (r ^. readerNodename)+        HieraQuery scps q t ->+          runExceptT (queryHiera (r ^. readerHieraQuery) scps q t) >>= either thpe runInstr+        PDBInformation -> pdbInformation pdb >>= runInstr+        PDBReplaceCatalog w -> canFailX (replaceCatalog pdb w)+        PDBReplaceFacts fcts -> canFailX (replaceFacts pdb fcts)+        PDBDeactivateNode nn -> canFailX (deactivateNode pdb nn)+        PDBGetFacts q -> canFailX (getPDBFacts pdb q)+        PDBGetResources q -> canFailX (getResources pdb q)+        PDBGetNodes q -> canFailX (getNodes pdb q)+        PDBCommitDB -> canFailX (commitDB pdb)+        PDBGetResourcesOfNode nn q -> canFailX (getResourcesOfNode pdb nn q)+        GetCurrentCallStack -> (r ^. readerIoMethods . ioGetCurrentCallStack) >>= runInstr+        ReadFile fls -> strFail ((r ^. readerIoMethods . ioReadFile) fls) (const $ PrettyError ("No file found in " <> list (map ppline fls)))+        TraceEvent e -> (r ^. readerIoMethods . ioTraceEvent) e >>= runInstr+        IsIgnoredModule m -> runInstr (r ^. readerIgnoredModules . contains m)+        IsExternalModule m -> runInstr (r ^. readerExternalModules . contains m)+        -- on error, the program state is RESET and the logged messages are dropped+        ErrorCatch atry ahandle -> do+          (eres, s', w) <- interpretMonad r s atry+          case eres of+            Left rr -> interpretMonad r s (ahandle rr >>= k)+            Right x -> logStuff w (interpretMonad r s' (k x))  -- query all hiera layers-queryHiera :: Monad m-           => HieraQueryLayers m-           -> Container PValue-           -> Text-           -> HieraQueryType-           -> ExceptT PrettyError m (Maybe PValue)+queryHiera ::+  (Monad m) =>+  HieraQueryLayers m ->+  Container PValue ->+  Text ->+  HieraQueryType ->+  ExceptT PrettyError m (Maybe PValue) queryHiera layers scps q t = do-  eglobal <- (layers^.globalLayer) scps q t-  eenvironment <- (layers ^.environmentLayer) scps q t+  eglobal <- (layers ^. globalLayer) scps q t+  eenvironment <- (layers ^. environmentLayer) scps q t   let modname =-        case Text.splitOn "::" (Text.dropWhile (==':') q) of-          []    -> Nothing-          [_]   -> Nothing-          (m:_) -> Just m-      layer = modname >>= (\n -> layers ^.moduleLayer.at n)+        case Text.splitOn "::" (Text.dropWhile (== ':') q) of+          [] -> Nothing+          [_] -> Nothing+          (m : _) -> Just m+      layer = modname >>= (\n -> layers ^. moduleLayer . at n)   emodle <- maybe (pure Nothing) (\hq -> hq scps q t) layer   case catMaybes [eglobal, eenvironment, emodle] of     [] -> pure Nothing-    x:xs -> Just <$> foldM (mergeWith t) x xs-+    x : xs -> Just <$> foldM (mergeWith t) x xs
src/Puppet/Interpreter/PrettyPrinter.hs view
@@ -1,30 +1,29 @@+{-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE GADTs             #-}-module Puppet.Interpreter.PrettyPrinter () where -import           XPrelude+module Puppet.Interpreter.PrettyPrinter () where -import qualified Data.Aeson                 as Aeson+import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy.Char8 as BSL--import           Puppet.Interpreter.Types-import           PuppetDB+import Puppet.Interpreter.Types+import PuppetDB+import XPrelude  instance Pretty TemplateSource where   pretty (Inline s) = pretty (PString s)   pretty (Filename s) = pptext s  instance Pretty TopLevelType where-    pretty TopNode   = dullyellow "node"-    pretty TopDefine = dullyellow "define"-    pretty TopClass  = dullyellow "class"+  pretty TopNode = dullyellow "node"+  pretty TopDefine = dullyellow "define"+  pretty TopClass = dullyellow "class"  instance Pretty ResDefaults where-    pretty (ResDefaults t _ v p) = capitalizeR t <+> showPPos p <> line <> containerComma v+  pretty (ResDefaults t _ v p) = capitalizeR t <+> showPPos p <> line <> containerComma v  instance Pretty ResourceModifier where-    pretty (ResourceModifier rt ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString x)) _ p) = "realize" <> parens (pretty (PResourceReference rt x)) <+> showPPos p-    pretty _ = "TODO pretty ResourceModifier"+  pretty (ResourceModifier rt ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString x)) _ p) = "realize" <> parens (pretty (PResourceReference rt x)) <+> showPPos p+  pretty _ = "TODO pretty ResourceModifier"  instance Pretty RSearchExpression where   pretty (REqualitySearch a v) = ppline a <+> "==" <+> pretty v@@ -36,7 +35,7 @@ pf :: Doc -> [Doc] -> Doc pf fn args = bold (red fn) <> tupled (map pretty args) -showQuery :: ToJSON a => Query a -> Doc+showQuery :: (ToJSON a) => Query a -> Doc showQuery = ppstring . BSL.unpack . Aeson.encode  instance Pretty (InterpreterInstr a) where@@ -44,31 +43,31 @@   pretty RebaseFile = pf "RebaseFile" []   pretty IsStrict = pf "IsStrict" []   pretty GetNativeTypes = pf "GetNativeTypes" []-  pretty (GetStatement tlt nm) = pf "GetStatement" [pretty tlt,ppline nm]+  pretty (GetStatement tlt nm) = pf "GetStatement" [pretty tlt, ppline nm]   pretty (ComputeTemplate src _) = pf "ComputeTemplate" [pretty src]-  pretty (ExternalFunction fn args)  = pf (ppline fn) (map pretty args)-  pretty GetNodeName                 = pf "GetNodeName" []-  pretty (HieraQuery _ q _)          = pf "HieraQuery" [ppline q]-  pretty GetCurrentCallStack         = pf "GetCurrentCallStack" []-  pretty (ErrorThrow rr)             = pf "ErrorThrow" [getError rr]-  pretty (ErrorCatch _ _)            = pf "ErrorCatch" []-  pretty (WriterTell t)              = pf "WriterTell" (map (pretty . view _2) t)-  pretty (WriterPass _)              = pf "WriterPass" []-  pretty (WriterListen _)            = pf "WriterListen" []-  pretty PDBInformation              = pf "PDBInformation" []-  pretty (PDBReplaceCatalog _)       = pf "PDBReplaceCatalog" ["..."]-  pretty (PDBReplaceFacts _)         = pf "PDBReplaceFacts" ["..."]-  pretty (PDBDeactivateNode n)       = pf "PDBDeactivateNode" [ppline n]-  pretty (PDBGetFacts q)             = pf "PDBGetFacts" [showQuery q]-  pretty (PDBGetResources q)         = pf "PDBGetResources" [showQuery q]-  pretty (PDBGetNodes q)             = pf "PDBGetNodes" [showQuery q]-  pretty PDBCommitDB                 = pf "PDBCommitDB" []+  pretty (ExternalFunction fn args) = pf (ppline fn) (map pretty args)+  pretty GetNodeName = pf "GetNodeName" []+  pretty (HieraQuery _ q _) = pf "HieraQuery" [ppline q]+  pretty GetCurrentCallStack = pf "GetCurrentCallStack" []+  pretty (ErrorThrow rr) = pf "ErrorThrow" [getError rr]+  pretty (ErrorCatch _ _) = pf "ErrorCatch" []+  pretty (WriterTell t) = pf "WriterTell" (map (pretty . view _2) t)+  pretty (WriterPass _) = pf "WriterPass" []+  pretty (WriterListen _) = pf "WriterListen" []+  pretty PDBInformation = pf "PDBInformation" []+  pretty (PDBReplaceCatalog _) = pf "PDBReplaceCatalog" ["..."]+  pretty (PDBReplaceFacts _) = pf "PDBReplaceFacts" ["..."]+  pretty (PDBDeactivateNode n) = pf "PDBDeactivateNode" [ppline n]+  pretty (PDBGetFacts q) = pf "PDBGetFacts" [showQuery q]+  pretty (PDBGetResources q) = pf "PDBGetResources" [showQuery q]+  pretty (PDBGetNodes q) = pf "PDBGetNodes" [showQuery q]+  pretty PDBCommitDB = pf "PDBCommitDB" []   pretty (PDBGetResourcesOfNode n q) = pf "PDBGetResourcesOfNode" [ppline n, showQuery q]-  pretty (ReadFile f)                = pf "ReadFile" (map ppline f)-  pretty (TraceEvent e)              = pf "TraceEvent" [ppstring e]-  pretty (IsIgnoredModule m)         = pf "IsIgnoredModule" [ppline m]-  pretty (IsExternalModule m)        = pf "IsExternalModule" [ppline m]-  pretty Facts                       = pf "Facts" []+  pretty (ReadFile f) = pf "ReadFile" (map ppline f)+  pretty (TraceEvent e) = pf "TraceEvent" [ppstring e]+  pretty (IsIgnoredModule m) = pf "IsIgnoredModule" [ppline m]+  pretty (IsExternalModule m) = pf "IsExternalModule" [ppline m]+  pretty Facts = pf "Facts" []  instance Pretty LinkInformation where-    pretty (LinkInformation lsrc ldst ltype lpos) = pretty lsrc <+> pretty ltype <+> pretty ldst <+> showPPos lpos+  pretty (LinkInformation lsrc ldst ltype lpos) = pretty lsrc <+> pretty ltype <+> pretty ldst <+> showPPos lpos
src/Puppet/Interpreter/Resolve.hs view
@@ -1,75 +1,76 @@-{-# LANGUAGE PackageImports   #-}-{-# LANGUAGE RankNTypes       #-}-{-# LANGUAGE TupleSections    #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE RankNTypes #-}  -- | This module is all about converting and resolving foreign data into -- the fully exploitable corresponding data type. -- -- The main use case is the conversion of 'Expression' to 'PValue'. module Puppet.Interpreter.Resolve-    ( -- * Pure resolution functions-      getVariable,-      pValue2Bool,-      -- * Monadic resolution functions-      resolveVariable,-      resolveExpression,-      resolveValue,-      resolvePValueString,-      resolvePValueNumber,-      resolveExpressionString,-      resolveExpressionStrings,-      resolveFunction',-      resolveDataType,-      runHiera,-      isNativeType,-      -- * Search expression management-      resolveSearchExpression,-      checkSearchExpression,-      searchExpressionToPuppetDB,-      -- * Higher order puppet functions handling-      hfGenerateAssociations,-      hfSetvars,-      hfRestorevars,-      fixResourceName,-      datatypeMatch,-      checkMatch,-      typeOf-    ) where+  ( -- * Pure resolution functions+    getVariable,+    pValue2Bool, -import           XPrelude.Extra-import           XPrelude.PP+    -- * Monadic resolution functions+    resolveVariable,+    resolveExpression,+    resolveValue,+    resolvePValueString,+    resolvePValueNumber,+    resolveExpressionString,+    resolveExpressionStrings,+    resolveFunction',+    resolveDataType,+    runHiera,+    isNativeType, -import qualified Control.Monad.Operational          as Operational-import           "cryptonite" Crypto.Hash-import qualified Data.Aeson                         as Aeson-import qualified Data.ByteArray                     as ByteArray-import qualified Data.ByteString                    as BS-import qualified Data.ByteString.Base16             as B16-import qualified Data.CaseInsensitive               as CaseInsensitive-import qualified Data.Char                          as Char-import qualified Data.HashMap.Strict                as HM-import qualified Data.HashSet                       as HS-import qualified Data.List                          as List-import qualified Data.List.NonEmpty                 as NE-import qualified Data.Maybe.Strict                  as S-import qualified Data.Scientific                    as Scientific-import qualified Data.Text                          as Text-import qualified Data.Text.Encoding                 as Text-import qualified Data.Tuple.Strict                  as Tuple-import qualified Data.Vector                        as V-import           Data.Version                       (Version (..), parseVersion)-import           Text.ParserCombinators.ReadP       (readP_to_S)-import qualified Text.Regex.PCRE.ByteString.Utils   as Regex+    -- * Search expression management+    resolveSearchExpression,+    checkSearchExpression,+    searchExpressionToPuppetDB, -import           Hiera.Server-import           Puppet.Interpreter.Helpers-import           Puppet.Interpreter.PrettyPrinter   ()-import           Puppet.Interpreter.Resolve.Sprintf (sprintf)-import           Puppet.Interpreter.RubyRandom-import           Puppet.Interpreter.Types-import           Puppet.Parser-import           PuppetDB+    -- * Higher order puppet functions handling+    hfGenerateAssociations,+    hfSetvars,+    hfRestorevars,+    fixResourceName,+    datatypeMatch,+    checkMatch,+    typeOf,+  )+where +import qualified Control.Monad.Operational as Operational+import qualified Data.Aeson as Aeson+import qualified Data.ByteArray as ByteArray+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import qualified Data.CaseInsensitive as CaseInsensitive+import qualified Data.Char as Char+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.List as List+import qualified Data.List.NonEmpty as NE+import qualified Data.Maybe.Strict as S+import qualified Data.Scientific as Scientific+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Tuple.Strict as Tuple+import qualified Data.Vector as V+import Data.Version (Version (..), parseVersion)+import Hiera.Server+import Puppet.Interpreter.Helpers+import Puppet.Interpreter.PrettyPrinter ()+import Puppet.Interpreter.Resolve.Sprintf (sprintf)+import Puppet.Interpreter.RubyRandom+import Puppet.Interpreter.Types+import Puppet.Parser+import PuppetDB+import Text.ParserCombinators.ReadP (readP_to_S)+import qualified Text.Regex.PCRE.ByteString.Utils as Regex+import XPrelude.Extra+import XPrelude.PP+import "cryptonite" Crypto.Hash+ sha1 :: ByteString -> ByteString sha1 = ByteArray.convert . (hash :: ByteString -> Digest SHA1) @@ -80,11 +81,14 @@ type NumberPair = Pair Scientific Scientific  -- | Converts class resource names to lowercase (fix for the jenkins plugin).-fixResourceName :: Text -- ^ Resource type-                -> Text -- ^ Resource name-                -> Text+fixResourceName ::+  -- | Resource type+  Text ->+  -- | Resource name+  Text ->+  Text fixResourceName "class" x = Text.toLower $ fromMaybe x $ Text.stripPrefix "::" x-fixResourceName _       x = x+fixResourceName _ x = x  -- | A hiera helper function, that will throw all Hiera errors and log -- messages to the main monad.@@ -111,11 +115,11 @@ hieraCall qt q df dt _ = do   qs <- resolvePValueString q   runHiera qs qt >>= \case-    Just p  -> case dt of+    Just p -> case dt of       Just dt' | not (datatypeMatch dt' p) -> throwPosError ("Datatype mismatched :" <+> pretty dt' <+> "/" <+> pretty p)-      _        -> pure p+      _ -> pure p     Nothing -> case df of-      Just d  -> pure d+      Just d -> pure d       Nothing -> throwPosError ("Lookup for " <> ppline qs <> " failed")  -- | Tries to convert a pair of 'PValue's into a 'NumberPair', as defined in@@ -133,10 +137,14 @@ -- | This tries to run a numerical binary operation on two puppet -- expressions. It will try to resolve them, then convert them to numbers -- (using 'toNumbers'), and will finally apply the correct operation.-binaryOperation :: Expression -- ^ left operand-                -> Expression -- ^ right operand-                -> (Scientific -> Scientific -> Scientific) -- ^ operation-                -> InterpreterMonad PValue+binaryOperation ::+  -- | left operand+  Expression ->+  -- | right operand+  Expression ->+  -- | operation+  (Scientific -> Scientific -> Scientific) ->+  InterpreterMonad PValue binaryOperation a b opr = ((PNumber .) . opr) `fmap` resolveExpressionNumber a <*> resolveExpressionNumber b  -- Just like 'binaryOperation', but for operations that only work on integers.@@ -162,19 +170,24 @@ isNativeType t = has (ix t) `fmap` Operational.singleton GetNativeTypes  -- | A pure function for resolving variables.-getVariable :: Container ScopeInformation -- ^ The whole scope data.-            -> Text -- ^ Current scope name.-            -> Text -- ^ Full variable name.-            -> Either Doc PValue+getVariable ::+  -- | The whole scope data.+  Container ScopeInformation ->+  -- | Current scope name.+  Text ->+  -- | Full variable name.+  Text ->+  Either Doc PValue getVariable scps scp fullvar = do   (varscope, varname) <- case Text.splitOn "::" fullvar of     [] -> Left "This doesn't make any sense in resolveVariable"     [vn] -> pure (scp, vn) -- Non qualified variables     rst -> pure (Text.intercalate "::" (filter (not . Text.null) (List.init rst)), List.last rst) -- qualified variables-  let extractVariable (varval :!: _ :!: _) = pure varval+  let extractVariable ((varval :!: _) :!: _) = pure varval   case scps ^? ix varscope . scopeVariables . ix varname of     Just pp -> extractVariable pp-    Nothing -> -- check top level scope+    Nothing ->+      -- check top level scope       case scps ^? ix "::" . scopeVariables . ix varname of         Just pp -> extractVariable pp         Nothing -> Left ("Could not resolve variable" <+> pretty (UVariableReference fullvar) <+> "in context" <+> ppline varscope <+> "or root")@@ -189,15 +202,15 @@   case toNumbers ra rb of     (S.Just (na :!: nb)) -> na == nb     _ -> case (ra, rb) of-      (PUndef , PBoolean x)         -> not x-      (PString "true", PBoolean x)  -> x+      (PUndef, PBoolean x) -> not x+      (PString "true", PBoolean x) -> x       (PString "false", PBoolean x) -> not x-      (PBoolean x, PString "true")  -> x+      (PBoolean x, PString "true") -> x       (PBoolean x, PString "false") -> not x-      (PString sa, PString sb)      -> CaseInsensitive.mk sa == CaseInsensitive.mk sb+      (PString sa, PString sb) -> CaseInsensitive.mk sa == CaseInsensitive.mk sb       -- TODO, check if array / hash equality should be recursed       -- for case insensitive matching-      _                             -> ra == rb+      _ -> ra == rb  -- Match a left expression with a regex -- Return a contextual True/False or Error after executing against the regex@@ -205,16 +218,16 @@ matchExpression a (rv, rexpr) = do   ra <- Text.encodeUtf8 <$> resolveExpressionString a   case Regex.execute' rv ra of-    Left (_,rr)    -> throwPosError ("Error when executing regex" <+> pretty rexpr <+> ":" <+> pretty rr)-    Right Nothing  -> pure $ PBoolean False+    Left (_, rr) -> throwPosError ("Error when executing regex" <+> pretty rexpr <+> ":" <+> pretty rr)+    Right Nothing -> pure $ PBoolean False     Right (Just matches) -> do       -- A bit of logic to save the capture variables.       -- Note that this will pollute the namespace, as it should only       -- happen in conditional expressions ...       p <- use curPos       ctype <- view cctype <$> getCurContainer-      let captures = zip (map (Text.pack . show) [(0 :: Int)..]) (map mkMatch (toList matches))-          mkMatch (offset, len) = PString (Text.decodeUtf8 (BS.take len (BS.drop offset ra))) :!: p :!: ctype+      let captures = zip (map (Text.pack . show) [(0 :: Int) ..]) (map mkMatch (toList matches))+          mkMatch (offset, len) = (PString (Text.decodeUtf8 (BS.take len (BS.drop offset ra))) :!: p) :!: ctype       scp <- getScopeName       scopes . ix scp . scopeVariables %= HM.union (HM.fromList captures)       pure $ PBoolean True@@ -259,8 +272,8 @@     PHash h -> do       ridx <- resolveExpressionString idx       case h ^. at ridx of-          Just _  -> pure (PBoolean True)-          Nothing -> pure (PBoolean False)+        Just _ -> pure (PBoolean True)+        Nothing -> pure (PBoolean False)     PArray ar -> do       ridx <- resolveExpression idx       pure (PBoolean (ridx `V.elem` ar))@@ -296,9 +309,9 @@       checkCond ((SelectorValue v@(URegexp (CompRegex _ rg)) :!: ce) : xs) = do         rs <- fmap Text.encodeUtf8 (resolvePValueString rese)         case Regex.execute' rg rs of-            Left (_,rr)    -> throwPosError ("Could not match" <+> pretty v <+> ":" <+> ppstring rr)-            Right Nothing  -> checkCond xs-            Right (Just _) -> resolveExpression ce+          Left (_, rr) -> throwPosError ("Could not match" <+> pretty v <+> ":" <+> ppstring rr)+          Right Nothing -> checkCond xs+          Right (Just _) -> resolveExpression ce       checkCond ((SelectorType udt :!: ce) : xs) = do         dt <- resolveDataType udt         if datatypeMatch dt rese@@ -314,29 +327,29 @@   ra <- resolveExpression a   rb <- resolveExpression b   case (ra, rb) of-    (PHash ha, PHash hb)   -> pure (PHash (ha <> hb))+    (PHash ha, PHash hb) -> pure (PHash (ha <> hb))     (PArray ha, PArray hb) -> pure (PArray (ha <> hb))-    _                      -> binaryOperation a b (+)-resolveExpression (Substraction a b)   = binaryOperation a b (-)-resolveExpression (Division a b)       = do+    _ -> binaryOperation a b (+)+resolveExpression (Substraction a b) = binaryOperation a b (-)+resolveExpression (Division a b) = do   ra <- resolveExpressionNumber a   rb <- resolveExpressionNumber b   case rb of-      0 -> throwPosError "Division by 0"-      _ -> case (,) `fmap` preview _ScientificInteger ra <*> preview _ScientificInteger rb of-             Just (ia, ib) -> pure $ PNumber $ fromIntegral (ia `div` ib)-             _             -> pure $ PNumber $ ra / rb+    0 -> throwPosError "Division by 0"+    _ -> case (,) `fmap` preview _ScientificInteger ra <*> preview _ScientificInteger rb of+      Just (ia, ib) -> pure $ PNumber $ fromIntegral (ia `div` ib)+      _ -> pure $ PNumber $ ra / rb resolveExpression (Multiplication a b) = binaryOperation a b (*)-resolveExpression (Modulo a b)         = integerOperation a b mod-resolveExpression (RightShift a b)     = integerOperation a b (\x -> shiftR x . fromIntegral)+resolveExpression (Modulo a b) = integerOperation a b mod+resolveExpression (RightShift a b) = integerOperation a b (\x -> shiftR x . fromIntegral) resolveExpression (LeftShift a b) = do   ra <- resolveExpression a   rb <- resolveExpression b   case (ra, rb) of-      (PArray ha, v) -> pure (PArray (V.snoc ha v))-      _              -> integerOperation a b (\x -> shiftL x . fromIntegral)+    (PArray ha, v) -> pure (PArray (V.snoc ha v))+    _ -> integerOperation a b (\x -> shiftL x . fromIntegral) resolveExpression (FunctionApplication e (Terminal (UHOLambdaCall hol))) =-    resolveValue (UHOLambdaCall (hol & hoLambdaExpr <>~ V.singleton e))+  resolveValue (UHOLambdaCall (hol & hoLambdaExpr <>~ V.singleton e)) resolveExpression (FunctionApplication _ x) = throwPosError ("Expected function application here, not" <+> pretty x) resolveExpression (Negate x) = PNumber . negate <$> resolveExpressionNumber x @@ -353,7 +366,7 @@   r <- resolveExpressionStrings e   case r of     [s] -> pure (PResourceReference t (fixResourceName t s))-    _   -> pure (PArray (V.fromList (map (PResourceReference t . fixResourceName t) r)))+    _ -> pure (PArray (V.fromList (map (PResourceReference t . fixResourceName t) r))) resolveValue (UArray a) = fmap PArray (V.mapM resolveExpression a) resolveValue (UHash a) =   fmap (PHash . HM.fromList) (mapM resPair (V.toList a))@@ -370,18 +383,19 @@ resolvePValueString (PBoolean True) = pure "true" resolvePValueString (PBoolean False) = pure "false" resolvePValueString (PNumber x) = pure (scientific2text x)+resolvePValueString (PRegexp (CompRegex e _)) = pure e resolvePValueString PUndef = do   checkStrict     "Resolving the keyword `undef` to the string \"undef\""     "Strict mode won't convert the keyword `undef` to the string \"undef\""   pure "undef"-resolvePValueString x = throwPosError ("Don't know how to convert this to a string:" <> line <>  pretty x)+resolvePValueString x = throwPosError ("Don't know how to convert this to a string:" <> line <> pretty x)  -- | Turns everything it can into a number, or throws an error resolvePValueNumber :: PValue -> InterpreterMonad Scientific resolvePValueNumber x =   case x ^? _PValueNumber of-    Just n  -> pure n+    Just n -> pure n     Nothing -> throwPosError ("Don't know how to convert this to a number:" <> line <> pretty x)  -- | > resolveExpressionString = resolveExpression >=> resolvePValueString@@ -401,10 +415,10 @@  -- | Turns a 'PValue' into a 'Bool' as explained in the reference documentation. pValue2Bool :: PValue -> Bool-pValue2Bool PUndef       = False+pValue2Bool PUndef = False pValue2Bool (PString "") = True pValue2Bool (PBoolean x) = x-pValue2Bool _            = True+pValue2Bool _ = True  -- | This resolve function calls at the expression level. resolveFunction :: Text -> V.Vector Expression -> InterpreterMonad PValue@@ -412,62 +426,66 @@   let nbargs = V.length args   when (nbargs < 1 || nbargs > 2) (throwPosError "fqdn_rand(): Expects one or two arguments")   fqdn <- resolveVariable "::fqdn" >>= resolvePValueString-  (mx:targs) <- mapM resolveExpressionString (V.toList args)+  (mx : targs) <- mapM resolveExpressionString (V.toList args)   curmax <- case PString mx ^? _PValueInteger of     Just x -> pure x     _ -> throwPosError ("fqdn_rand(): the first argument must be an integer, not" <+> ppline mx)-  let rargs = if null targs-                then [fqdn, ""]-                else fqdn : targs+  let rargs =+        if null targs+          then [fqdn, ""]+          else fqdn : targs       val = fromIntegral (fst (limitedRand (randInit myhash) (fromIntegral curmax)))       myhash = toint (md5 (Text.encodeUtf8 fullstring)) :: Integer-      toint = BS.foldl' (\c nx -> c*256 + fromIntegral nx) 0+      toint = BS.foldl' (\c nx -> c * 256 + fromIntegral nx) 0       fullstring = Text.intercalate ":" rargs   pure (_PValueInteger # val) resolveFunction fname args =   mapM resolveExpression (V.toList args) >>= resolveFunction' fname . map undefEmptyString   where     undefEmptyString PUndef = PString ""-    undefEmptyString x      = x+    undefEmptyString x = x  resolveFunction' :: Text -> [PValue] -> InterpreterMonad PValue resolveFunction' "defined" [PResourceReference "class" cn] = do-  checkStrict "The use of the 'defined' function is a code smell"-              "The 'defined' function is not allowed in strict mode."+  checkStrict+    "The use of the 'defined' function is a code smell"+    "The 'defined' function is not allowed in strict mode."   fmap (PBoolean . has (ix cn)) (use loadedClasses) resolveFunction' "defined" [PResourceReference rt rn] = do-  checkStrict "The use of the 'defined' function is a code smell"-              "The 'defined' function is not allowed in strict mode."+  checkStrict+    "The use of the 'defined' function is a code smell"+    "The 'defined' function is not allowed in strict mode."   fmap (PBoolean . has (ix (RIdentifier rt rn))) (use definedResources) resolveFunction' "defined" [ut] = do-  checkStrict "The use of the 'defined' function is a code smell."-              "The 'defined' function is not allowed in strict mode."+  checkStrict+    "The use of the 'defined' function is a code smell."+    "The 'defined' function is not allowed in strict mode."   t <- resolvePValueString ut   if not (Text.null t) && Text.head t == '$' -- variable test     then do       scps <- use scopes       scp <- getScopeName       pure $ PBoolean $ case getVariable scps scp (Text.tail t) of-        Left _  -> False+        Left _ -> False         Right _ -> True-    else do -- resource test+    else do+      -- resource test       -- case 1, nested thingie       nestedStuff <- use nestedDeclarations       if has (ix (TopDefine, t)) nestedStuff || has (ix (TopClass, t)) nestedStuff         then pure (PBoolean True)-        else do -- case 2, loaded class+        else do+          -- case 2, loaded class           lc <- use loadedClasses           if has (ix t) lc             then pure (PBoolean True)             else fmap PBoolean (isNativeType t)- resolveFunction' "defined" x = throwPosError ("defined(): expects a single resource reference, type or class name, and not" <+> pretty x) resolveFunction' "fail" x = throwPosError ("fail:" <+> pretty x) resolveFunction' "inline_template" [] = throwPosError "inline_template(): Expects at least one argument" resolveFunction' "inline_template" templates =   let compute = fmap Inline . resolvePValueString >=> calcTemplate-  in-  PString . mconcat <$> traverse compute templates+   in PString . mconcat <$> traverse compute templates resolveFunction' "md5" [pstr] = fmap (PString . Text.decodeUtf8 . B16.encode . md5 . Text.encodeUtf8) (resolvePValueString pstr) resolveFunction' "md5" _ = throwPosError "md5(): Expects a single argument" resolveFunction' "regsubst" [ptarget, pregexp, preplacement] = resolveFunction' "regsubst" [ptarget, pregexp, preplacement, PString "G"]@@ -475,7 +493,7 @@   -- TODO handle all the flags   -- http://docs.puppetlabs.com/references/latest/function.html#regsubst   when (pflags /= "G") (use curPos >>= \p -> warn ("regsubst(): Currently only supports a single flag (G) " <> showPos (Tuple.fst p)))-  regexp      <- fmap Text.encodeUtf8 (resolvePValueString pregexp)+  regexp <- fmap Text.encodeUtf8 (resolvePValueString pregexp)   replacement <- fmap Text.encodeUtf8 (resolvePValueString preplacement)   let sub t = do         t' <- fmap Text.encodeUtf8 (resolvePValueString t)@@ -484,45 +502,46 @@           Right x -> fmap PString (safeDecodeUtf8 x)   case ptarget of     PArray a -> fmap PArray (traverse sub a)-    s        -> sub s+    s -> sub s resolveFunction' "regsubst" _ = throwPosError "regsubst(): Expects 3 or 4 arguments" resolveFunction' "split" [psrc, psplt] = do-  src  <- fmap Text.encodeUtf8 (resolvePValueString psrc)+  src <- fmap Text.encodeUtf8 (resolvePValueString psrc)   splt <- fmap Text.encodeUtf8 (resolvePValueString psplt)   case Regex.splitCompile' splt src of     Left err -> throwPosError ("splitCompile():" <+> ppstring err)-    Right x  -> fmap (PArray . V.fromList) (mapM (fmap PString . safeDecodeUtf8) x)+    Right x -> fmap (PArray . V.fromList) (mapM (fmap PString . safeDecodeUtf8) x) resolveFunction' "sha1" [pstr] = fmap (PString . Text.decodeUtf8 . B16.encode . sha1 . Text.encodeUtf8) (resolvePValueString pstr) resolveFunction' "sha1" _ = throwPosError "sha1(): Expects a single argument" resolveFunction' "shellquote" args = do   sargs <- for args $ \arg ->     case arg of       PArray vals -> mapM resolvePValueString vals-      _           -> V.singleton <$> resolvePValueString arg-  let escape str | Text.all isSafe str            = str-                 | not (Text.any isDangerous str) = between "\"" str-                 | Text.any (== '\'') str          = between "\"" (Text.concatMap escapeDangerous str)-                 | otherwise                   = between "'" str+      _ -> V.singleton <$> resolvePValueString arg+  let escape str+        | Text.all isSafe str = str+        | not (Text.any isDangerous str) = between "\"" str+        | Text.any (== '\'') str = between "\"" (Text.concatMap escapeDangerous str)+        | otherwise = between "'" str       isSafe x = Char.isAlphaNum x || x `elem` ("@%_+=:,./-" :: String)       isDangerous x = x `elem` ("!\"`$\\" :: String)-      escapeDangerous x | isDangerous x = Text.snoc "\\" x-                        | otherwise = Text.singleton x+      escapeDangerous x+        | isDangerous x = Text.snoc "\\" x+        | otherwise = Text.singleton x       between c s = c <> s <> c   pure $ PString $ Text.unwords $ V.toList (escape <$> mconcat sargs)- resolveFunction' "mysql_password" [pstr] = fmap (PString . Text.decodeUtf8 . B16.encode . sha1 . sha1 . Text.encodeUtf8) (resolvePValueString pstr) resolveFunction' "mysql_password" _ = throwPosError "mysql_password(): Expects a single argument" resolveFunction' "file" args = do   rebasefile <- fmap Text.pack <$> Operational.singleton RebaseFile-  let fixFilePath s | Text.null s = let rr = "Empty file path passed to the 'file' function" in checkStrict rr rr >> pure s-                    | Text.head s == '/' = pure (maybe s (<> s) rebasefile)-                    | otherwise = case Text.splitOn "/" s of-                                      (md:x:rst) -> do-                                          moduledir <- view modulesPath <$> getPuppetPaths-                                          pure (Text.intercalate "/" (Text.pack moduledir : md : "files" : x : rst))-                                      _ -> throwPosError ("file() argument invalid: " <> ppline s)+  let fixFilePath s+        | Text.null s = let rr = "Empty file path passed to the 'file' function" in checkStrict rr rr >> pure s+        | Text.head s == '/' = pure (maybe s (<> s) rebasefile)+        | otherwise = case Text.splitOn "/" s of+            (md : x : rst) -> do+              moduledir <- view modulesPath <$> getPuppetPaths+              pure (Text.intercalate "/" (Text.pack moduledir : md : "files" : x : rst))+            _ -> throwPosError ("file() argument invalid: " <> ppline s)   mapM (resolvePValueString >=> fixFilePath) args >>= fmap PString . Operational.singleton . ReadFile- resolveFunction' "tagged" ptags = do   tags <- fmap HS.fromList (mapM resolvePValueString ptags)   scp <- getScopeName@@ -534,15 +553,14 @@ resolveFunction' "template" [] = throwPosError "template(): Expects at least one argument" resolveFunction' "template" templates =   let compute = fmap (Filename . Text.unpack) . resolvePValueString >=> calcTemplate-  in-  PString . mconcat <$> traverse compute templates-resolveFunction' "versioncmp" [pa,pb] = do+   in PString . mconcat <$> traverse compute templates+resolveFunction' "versioncmp" [pa, pb] = do   a <- resolvePValueString pa   b <- resolvePValueString pb   let parser x =         case filter (null . snd) (readP_to_S parseVersion (Text.unpack x)) of-          ( (v, _) : _ ) -> v-          _              -> Version [] [] -- fallback :(+          ((v, _) : _) -> v+          _ -> Version [] [] -- fallback :(       va = parser a       vb = parser b   pure $ PString $ case compare va vb of@@ -550,30 +568,29 @@     LT -> "-1"     GT -> "1" resolveFunction' "versioncmp" _ = throwPosError "versioncmp(): Expects two arguments"--- | Simplified implementation of sprintf-resolveFunction' "sprintf" (PString str:args) = sprintf str args+-- \| Simplified implementation of sprintf+resolveFunction' "sprintf" (PString str : args) = sprintf str args resolveFunction' "sprintf" _ = throwPosError "sprintf(): Expects a string as its first argument" -- some custom functions-resolveFunction' "pdbresourcequery" [q]   = pdbresourcequery q Nothing-resolveFunction' "pdbresourcequery" [q,k] = fmap Just (resolvePValueString k) >>= pdbresourcequery q-resolveFunction' "pdbresourcequery" _     = throwPosError "pdbresourcequery(): Expects one or two arguments"-resolveFunction' "hiera"       [q]     = hieraCall QFirst   q Nothing Nothing Nothing-resolveFunction' "hiera"       [q,d]   = hieraCall QFirst   q (Just d) Nothing Nothing-resolveFunction' "hiera"       [q,d,o] = hieraCall QFirst   q (Just d) Nothing (Just o)-resolveFunction' "hiera_array" [q]     = hieraCall QUnique q Nothing  Nothing Nothing-resolveFunction' "hiera_array" [q,d]   = hieraCall QUnique q (Just d) Nothing Nothing-resolveFunction' "hiera_array" [q,d,o] = hieraCall QUnique q (Just d) Nothing (Just o)-resolveFunction' "hiera_hash"  [q]     = hieraCall QHash  q Nothing  Nothing Nothing-resolveFunction' "hiera_hash"  [q,d]   = hieraCall QHash  q (Just d) Nothing Nothing-resolveFunction' "hiera_hash"  [q,d,o] = hieraCall QHash  q (Just d) Nothing (Just o)-resolveFunction' "lookup"      [q]                        = hieraCall QFirst   q Nothing  Nothing Nothing-resolveFunction' "lookup"      [q, PType dt]              = hieraCall QFirst   q Nothing (Just dt) Nothing-resolveFunction' "lookup"      [q, PType dt, PString qt, def] =+resolveFunction' "pdbresourcequery" [q] = pdbresourcequery q Nothing+resolveFunction' "pdbresourcequery" [q, k] = resolvePValueString k >>= pdbresourcequery q . Just+resolveFunction' "pdbresourcequery" _ = throwPosError "pdbresourcequery(): Expects one or two arguments"+resolveFunction' "hiera" [q] = hieraCall QFirst q Nothing Nothing Nothing+resolveFunction' "hiera" [q, d] = hieraCall QFirst q (Just d) Nothing Nothing+resolveFunction' "hiera" [q, d, o] = hieraCall QFirst q (Just d) Nothing (Just o)+resolveFunction' "hiera_array" [q] = hieraCall QUnique q Nothing Nothing Nothing+resolveFunction' "hiera_array" [q, d] = hieraCall QUnique q (Just d) Nothing Nothing+resolveFunction' "hiera_array" [q, d, o] = hieraCall QUnique q (Just d) Nothing (Just o)+resolveFunction' "hiera_hash" [q] = hieraCall QHash q Nothing Nothing Nothing+resolveFunction' "hiera_hash" [q, d] = hieraCall QHash q (Just d) Nothing Nothing+resolveFunction' "hiera_hash" [q, d, o] = hieraCall QHash q (Just d) Nothing (Just o)+resolveFunction' "lookup" [q] = hieraCall QFirst q Nothing Nothing Nothing+resolveFunction' "lookup" [q, PType dt] = hieraCall QFirst q Nothing (Just dt) Nothing+resolveFunction' "lookup" [q, PType dt, PString qt, def] =   case readQueryType qt of     Nothing -> throwPosError ("Unknown merge strategy " <> ppline qt)     Just qt' -> hieraCall qt' q (Just def) (Just dt) Nothing-resolveFunction' "lookup" _                               =  throwPosError "lookup(): Wrong set of arguments"-+resolveFunction' "lookup" _ = throwPosError "lookup(): Wrong set of arguments" -- user functions resolveFunction' fname args = Operational.singleton (ExternalFunction fname args) @@ -581,7 +598,7 @@ pdbresourcequery q mkey = do   rrv <- case fromJSON (toJSON q) of     Aeson.Success rq -> Operational.singleton (PDBGetResources rq)-    Aeson.Error rr   -> throwPosError ("Invalid resource query:" <+> ppstring rr)+    Aeson.Error rr -> throwPosError ("Invalid resource query:" <+> ppstring rr)   rv <- case fromJSON (toJSON rrv) of     Aeson.Success x -> pure x     Aeson.Error rr -> throwPosError ("For some reason we could not convert a resource list to Puppet internal values!!" <+> ppstring rr <+> pretty rrv)@@ -592,10 +609,9 @@           Nothing -> throwPosError ("pdbresourcequery strange error, could not find key" <+> ppline k <+> "in" <+> pretty (PHash h))       extractSubHash _ x = throwPosError ("pdbresourcequery strange error, expected a hash, had" <+> pretty x)   case mkey of-    Nothing  -> pure (PArray rv)+    Nothing -> pure (PArray rv)     (Just k) -> fmap PArray (V.mapM (extractSubHash k) rv) - calcTemplate :: TemplateSource -> InterpreterMonad Text calcTemplate tplsrc = do   interp_state <- use identity@@ -612,8 +628,8 @@ -- resolved 'RSearchExpression'. resolveSearchExpression :: SearchExpression -> InterpreterMonad RSearchExpression resolveSearchExpression AlwaysTrue = pure RAlwaysTrue-resolveSearchExpression (EqualitySearch a e) = REqualitySearch `fmap` pure a <*> resolveExpressionSE e-resolveSearchExpression (NonEqualitySearch a e) = RNonEqualitySearch `fmap` pure a <*> resolveExpressionSE e+resolveSearchExpression (EqualitySearch a e) = REqualitySearch a <$> resolveExpressionSE e+resolveSearchExpression (NonEqualitySearch a e) = RNonEqualitySearch a <$> resolveExpressionSE e resolveSearchExpression (AndSearch e1 e2) = RAndSearch `fmap` resolveSearchExpression e1 <*> resolveSearchExpression e2 resolveSearchExpression (OrSearch e1 e2) = ROrSearch `fmap` resolveSearchExpression e1 <*> resolveSearchExpression e2 @@ -621,16 +637,16 @@ -- be used in a PuppetDB query. searchExpressionToPuppetDB :: Text -> RSearchExpression -> Query ResourceField searchExpressionToPuppetDB rtype res =-  QAnd ( QEqual RType (capitalizeRT rtype) : mkSE res )+  QAnd (QEqual RType (capitalizeRT rtype) : mkSE res)   where-    mkSE (RAndSearch a b)                = [QAnd (mkSE a ++ mkSE b)]-    mkSE (ROrSearch a b)                 = [QOr (mkSE a ++ mkSE b)]-    mkSE (RNonEqualitySearch a b)        = fmap QNot (mkSE (REqualitySearch a b))+    mkSE (RAndSearch a b) = [QAnd (mkSE a ++ mkSE b)]+    mkSE (ROrSearch a b) = [QOr (mkSE a ++ mkSE b)]+    mkSE (RNonEqualitySearch a b) = fmap QNot (mkSE (REqualitySearch a b))     mkSE (REqualitySearch a (PString b)) = [QEqual (mkFld a) b]-    mkSE _                               = []-    mkFld "tag"   = RTag+    mkSE _ = []+    mkFld "tag" = RTag     mkFld "title" = RTitle-    mkFld z       = RParameter z+    mkFld z = RParameter z  -- | Checks whether a given 'Resource' matches a 'RSearchExpression'. -- Note that the expression doesn't check for type, so you must filter the@@ -645,52 +661,54 @@   let nameequal = puppetEquality v (PString (r ^. rid . iname))       aliasequal =         case r ^. rattributes . at "alias" of-          Just a  -> puppetEquality v a+          Just a -> puppetEquality v a           Nothing -> False-  in nameequal || aliasequal+   in nameequal || aliasequal checkSearchExpression (REqualitySearch attributename v) r =   case r ^. rattributes . at attributename of-    Nothing         -> False+    Nothing -> False     Just (PArray x) -> any (`puppetEquality` v) x-    Just x          -> puppetEquality x v+    Just x -> puppetEquality x v checkSearchExpression (RNonEqualitySearch attributename v) r-  | attributename  == "tag" = True-  | attributename  == "title" = not (checkSearchExpression (REqualitySearch attributename v) r)+  | attributename == "tag" = True+  | attributename == "title" = not (checkSearchExpression (REqualitySearch attributename v) r)   | otherwise =       case r ^. rattributes . at attributename of-        Nothing         -> True+        Nothing -> True         Just (PArray x) -> not (all (`puppetEquality` v) x)-        Just x          -> not (puppetEquality x v)+        Just x -> not (puppetEquality x v)  resolveDataType :: UDataType -> InterpreterMonad DataType-resolveDataType ud-  = case ud of-      UDTType             -> pure DTType-      UDTString a b       -> pure (DTString a b)-      UDTInteger a b      -> pure (DTInteger a b)-      UDTFloat a b        -> pure (DTFloat a b)-      UDTBoolean          -> pure DTBoolean-      UDTArray dt a b     -> DTArray <$> resolveDataType dt <*> pure a <*> pure b-      UDTHash dt1 dt2 a b -> DTHash <$> resolveDataType dt1 <*> resolveDataType dt2 <*> pure a <*> pure b-      UDTUndef            -> pure DTUndef-      UDTScalar           -> pure DTScalar-      UDTData             -> pure DTData-      UDTOptional dt      -> DTOptional <$> resolveDataType dt-      UNotUndef           -> pure NotUndef-      UDTVariant vrs      -> DTVariant <$> traverse resolveDataType vrs-      UDTPattern a        -> pure (DTPattern a)-      -- will not crash as ens is nonempty-      UDTEnum ens         -> DTEnum . NE.fromList . sconcat <$> traverse resolveExpressionStrings ens-      UDTAny              -> pure DTAny-      UDTCollection       -> pure DTCollection-      UDTRegexp mr        -> pure (DTRegexp mr)+resolveDataType ud =+  case ud of+    UDTType -> pure DTType+    UDTString a b -> pure (DTString a b)+    UDTInteger a b -> pure (DTInteger a b)+    UDTFloat a b -> pure (DTFloat a b)+    UDTBoolean -> pure DTBoolean+    UDTArray dt a b -> DTArray <$> resolveDataType dt <*> pure a <*> pure b+    UDTHash dt1 dt2 a b -> DTHash <$> resolveDataType dt1 <*> resolveDataType dt2 <*> pure a <*> pure b+    UDTUndef -> pure DTUndef+    UDTScalar -> pure DTScalar+    UDTData -> pure DTData+    UDTOptional dt -> DTOptional <$> resolveDataType dt+    UNotUndef -> pure NotUndef+    UDTVariant vrs -> DTVariant <$> traverse resolveDataType vrs+    UDTPattern a -> pure (DTPattern a)+    -- will not crash as ens is nonempty+    UDTEnum ens -> DTEnum . NE.fromList . sconcat <$> traverse resolveExpressionStrings ens+    UDTAny -> pure DTAny+    UDTCollection -> pure DTCollection+    UDTRegexp mr -> pure (DTRegexp mr)+    UDTDeferred -> pure DTDeferred+    UDTSensitive dt -> DTOptional <$> resolveDataType dt  -- | Generates variable associations for evaluation of blocks. -- Each item corresponds to an iteration in the calling block. hfGenerateAssociations :: HOLambdaCall -> InterpreterMonad [[(Text, PValue)]] hfGenerateAssociations hol = do   sourceexpression <- case hol ^.. hoLambdaExpr . folded of-    [x]  -> pure x+    [x] -> pure x     [] -> throwPosError ("No expression to run the function on" <+> pretty hol)     _ -> throwPosError ("Too many expressions to run the function on" <+> pretty hol)   sourcevalue <- resolveExpression sourceexpression@@ -699,20 +717,20 @@         dtype <- resolveDataType udtype         mapM_ (\v -> unless (datatypeMatch dtype v) (throwPosError (pretty v <+> "isn't of type" <+> pretty dtype))) tocheck   case (sourcevalue, V.toList (hol ^. hoLambdaParams)) of-     (PArray pr, [LambdaParam mvtype varname]) -> do-       check mvtype pr-       pure (map (\x -> [(varname, x)]) (V.toList pr))-     (PArray pr, [LambdaParam _ idx, LambdaParam mvtype var] ) -> do-       check mvtype pr-       pure [ [(idx,PString (Text.pack (show i))),(var,v)]  |  (i,v) <- zip ([0..] :: [Int]) (V.toList pr) ]-     (PHash hh, [LambdaParam mvtype varname]) -> do-       check mvtype hh-       pure [ [(varname, PArray (V.fromList [PString k,v]))]  |  (k,v) <- HM.toList hh]-     (PHash hh, [LambdaParam midxtype idx, LambdaParam mvtype var]) -> do-       check mvtype hh-       check midxtype (PString <$> HM.keys hh)-       pure [ [(idx,PString k),(var,v)]  |  (k,v) <- HM.toList hh]-     (invalid, _) -> throwPosError ("Can't iterate on this data type:" <+> pretty invalid)+    (PArray pr, [LambdaParam mvtype varname]) -> do+      check mvtype pr+      pure (map (\x -> [(varname, x)]) (V.toList pr))+    (PArray pr, [LambdaParam _ idx, LambdaParam mvtype var]) -> do+      check mvtype pr+      pure [[(idx, PString (Text.pack (show i))), (var, v)] | (i, v) <- zip ([0 ..] :: [Int]) (V.toList pr)]+    (PHash hh, [LambdaParam mvtype varname]) -> do+      check mvtype hh+      pure [[(varname, PArray (V.fromList [PString k, v]))] | (k, v) <- HM.toList hh]+    (PHash hh, [LambdaParam midxtype idx, LambdaParam mvtype var]) -> do+      check mvtype hh+      check midxtype (PString <$> HM.keys hh)+      pure [[(idx, PString k), (var, v)] | (k, v) <- HM.toList hh]+    (invalid, _) -> throwPosError ("Can't iterate on this data type:" <+> pretty invalid)  -- | Sets the proper variables, and returns the scope variables the way -- they were before being modified. This is a hack that ensures that@@ -726,7 +744,7 @@   p <- use curPos   container <- getCurContainer   save <- use (scopes . ix scp . scopeVariables)-  let hfSetvar (varname, varval) = scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: (container ^. cctype))+  let hfSetvar (varname, varval) = scopes . ix scp . scopeVariables . at varname ?= ((varval :!: p) :!: (container ^. cctype))   mapM_ hfSetvar vals   pure save @@ -753,10 +771,13 @@         then throwPosError ("The statement block must not be empty" <+> pretty hol)         else case V.last statements of           (MainFunctionDeclaration (MainFuncDecl fn args _)) ->-             let expr = Terminal (UFunctionCall fn args)-             in  pure (hol & hoLambdaStatements %~ V.init-                           & hoLambdaLastExpr .~ S.Just expr-                      , expr)+            let expr = Terminal (UFunctionCall fn args)+             in pure+                  ( hol+                      & hoLambdaStatements %~ V.init+                      & hoLambdaLastExpr .~ S.Just expr,+                    expr+                  )           _ -> throwPosError ("The statement block must end with an expression" <+> pretty hol)  -- | All the "higher order function" stuff, for "value" mode. In this case@@ -766,11 +787,11 @@   (hol, finalexpression) <- transformPureHf hol'   let runblock :: [(Text, PValue)] -> InterpreterMonad PValue       runblock assocs = do-          saved <- hfSetvars assocs-          V.mapM_ evalPureStatement (hol ^. hoLambdaStatements)-          r <- resolveExpression finalexpression-          hfRestorevars  saved-          pure r+        saved <- hfSetvars assocs+        V.mapM_ evalPureStatement (hol ^. hoLambdaStatements)+        r <- resolveExpression finalexpression+        hfRestorevars saved+        pure r   case hol ^. hoLambdaFunc of     LambdaFunc "each" -> throwPosError "The 'each' function can't be used at the value level in language-puppet. Please use map."     LambdaFunc "map" -> do@@ -779,7 +800,8 @@     LambdaFunc "with" -> do       let expressions = hol ^. hoLambdaExpr           parameters = hol ^. hoLambdaParams-      unless (V.length expressions == V.length parameters)+      unless+        (V.length expressions == V.length parameters)         (throwPosError ("Mismatched number of arguments and lambda parameters in" <> pretty hol))       assocs <- forM (V.zip expressions parameters) $ \(uval, LambdaParam mt name) -> do         val <- resolveExpression uval@@ -794,19 +816,19 @@       res <- mapM (fmap pValue2Bool . runblock) varassocs       sourcevalue <- case hol ^.. hoLambdaExpr . folded of         [x] -> resolveExpression x-        _   -> throwPosError "Internal error evaluateHFCPure 1"+        _ -> throwPosError "Internal error evaluateHFCPure 1"       case sourcevalue of         PArray ar -> pure $ PArray $ V.map fst $ V.filter snd $ V.zip ar (V.fromList res)-        PHash  hh -> pure $ PHash  $ HM.fromList $ map fst $ filter snd $ zip (HM.toList hh) res-        x         -> throwPosError ("Can't iterate on this data type:" <+> pretty x)+        PHash hh -> pure $ PHash $ HM.fromList $ map fst $ filter snd $ zip (HM.toList hh) res+        x -> throwPosError ("Can't iterate on this data type:" <+> pretty x)     LambdaFunc "reduce" ->       case hol ^.. hoLambdaExpr . folded of         [zero', foldable'] -> do           zero'' <- resolveExpression zero'           foldable'' <- resolveExpression foldable'           (accname, curname) <- case hol ^.. hoLambdaParams . folded of-                                  [an, cn] -> pure (an, cn)-                                  _ -> throwPosError ("Reduce requires two parameters in its block expression, in" <+> pretty hol)+            [an, cn] -> pure (an, cn)+            _ -> throwPosError ("Reduce requires two parameters in its block expression, in" <+> pretty hol)           let runStep acc cur = do                 accName <- mCheckType acc accname                 curName <- mCheckType cur curname@@ -819,7 +841,7 @@           case foldable'' of             PArray ar -> foldM runStep zero'' ar             PHash hs -> foldM runStep zero'' $ do-              (k,v) <- HM.toList hs+              (k, v) <- HM.toList hs               return (PArray (V.fromList [PString k, v]))             x -> throwPosError ("Can't iterate on this data type:" <+> pretty x)         _ -> throwPosError ("Reduce requires two arguments and a lambda block, in" <+> pretty hol)@@ -829,37 +851,39 @@ datatypeMatch :: DataType -> PValue -> Bool datatypeMatch dt v =   case dt of-    DTType               -> has _PType v-    DTUndef              -> v == PUndef-    NotUndef             -> v /= PUndef-    DTString mmin mmax   -> boundedBy _PString Text.length mmin mmax-    DTInteger mmin mmax  -> boundedBy (_PNumber . to Scientific.toBoundedInteger . _Just) identity mmin mmax-    DTFloat mmin mmax    -> boundedBy _PNumber Scientific.toRealFloat mmin mmax-    DTBoolean            -> has _PBoolean v-    DTArray sdt mi mmx   -> container (_PArray . to V.toList) (datatypeMatch sdt) mi mmx-    DTHash kt sdt mi mmx -> container (_PHash . to itoList) (\(k,a) -> datatypeMatch kt (PString k) && datatypeMatch sdt a) mi mmx-    DTScalar             -> datatypeMatch (DTVariant (DTInteger Nothing Nothing :| [DTString Nothing Nothing, DTBoolean])) v-    DTData               -> datatypeMatch (DTVariant (DTScalar :| [DTArray DTData 0 Nothing, DTHash DTScalar DTData 0 Nothing])) v-    DTOptional sdt       -> datatypeMatch (DTVariant (DTUndef :| [sdt])) v-    DTVariant sdts       -> any (`datatypeMatch` v) sdts-    DTEnum lst           -> maybe False (`elem` lst) (v ^? _PString)-    DTAny                -> True-    DTCollection         -> datatypeMatch (DTVariant (DTArray DTData 0 Nothing :| [DTHash DTScalar DTData 0 Nothing])) v-    DTPattern patterns   -> maybe False (\str -> any (checkPattern (Text.encodeUtf8 str)) patterns) (v ^? _PString)-    DTRegexp mr          -> case v ^? _PRegexp of-                              Nothing -> False-                              Just cr -> maybe True (== cr) mr+    DTType -> has _PType v+    DTUndef -> v == PUndef+    NotUndef -> v /= PUndef+    DTString mmin mmax -> boundedBy _PString Text.length mmin mmax+    DTInteger mmin mmax -> boundedBy (_PNumber . to Scientific.toBoundedInteger . _Just) identity mmin mmax+    DTFloat mmin mmax -> boundedBy _PNumber Scientific.toRealFloat mmin mmax+    DTBoolean -> has _PBoolean v+    DTArray sdt mi mmx -> container (_PArray . to V.toList) (datatypeMatch sdt) mi mmx+    DTHash kt sdt mi mmx -> container (_PHash . to itoList) (\(k, a) -> datatypeMatch kt (PString k) && datatypeMatch sdt a) mi mmx+    DTScalar -> datatypeMatch (DTVariant (DTInteger Nothing Nothing :| [DTString Nothing Nothing, DTBoolean])) v+    DTData -> datatypeMatch (DTVariant (DTScalar :| [DTArray DTData 0 Nothing, DTHash DTScalar DTData 0 Nothing])) v+    DTOptional sdt -> datatypeMatch (DTVariant (DTUndef :| [sdt])) v+    DTVariant sdts -> any (`datatypeMatch` v) sdts+    DTEnum lst -> maybe False (`elem` lst) (v ^? _PString)+    DTAny -> True+    DTCollection -> datatypeMatch (DTVariant (DTArray DTData 0 Nothing :| [DTHash DTScalar DTData 0 Nothing])) v+    DTPattern patterns -> maybe False (\str -> any (checkPattern (Text.encodeUtf8 str)) patterns) (v ^? _PString)+    DTRegexp mr -> case v ^? _PRegexp of+      Nothing -> False+      Just cr -> maybe True (== cr) mr+    DTDeferred -> True+    DTSensitive sdt -> datatypeMatch (DTVariant (DTUndef :| [sdt])) v   where     checkPattern str (CompRegex _ ptrn) =       case Regex.execute' ptrn str of         Right (Just _) -> True-        _              -> False+        _ -> False     container :: Fold PValue [a] -> (a -> Bool) -> Int -> Maybe Int -> Bool     container f c mi mmx =       let lst = v ^. f           ln = length lst-      in  ln >= mi && (fmap (ln <=) mmx /= Just False) && all c lst-    boundedBy :: Ord b => Fold PValue a -> (a -> b) -> Maybe b -> Maybe b -> Bool+       in ln >= mi && (fmap (ln <=) mmx /= Just False) && all c lst+    boundedBy :: (Ord b) => Fold PValue a -> (a -> b) -> Maybe b -> Maybe b -> Bool     boundedBy prm f mmin mmax =       fromMaybe False $ do         vr <- f <$> v ^? prm@@ -870,15 +894,17 @@  typeOf :: PValue -> DataType typeOf pv =-    case pv of-      PBoolean _             -> DTBoolean-      PUndef                 -> DTUndef-      PString _              -> DTString Nothing Nothing-      PResourceReference _ _ -> DTType -- ???-      PArray _               -> DTArray DTAny 0 Nothing-      PHash _                -> DTHash DTAny DTAny 0 Nothing-      PType _                -> DTType-      PRegexp _              -> DTRegexp Nothing-      PNumber n              -> if Scientific.isInteger n-                                  then DTInteger Nothing Nothing-                                  else DTFloat Nothing Nothing+  case pv of+    PSensitive x -> typeOf x+    PBoolean _ -> DTBoolean+    PUndef -> DTUndef+    PString _ -> DTString Nothing Nothing+    PResourceReference _ _ -> DTType -- ???+    PArray _ -> DTArray DTAny 0 Nothing+    PHash _ -> DTHash DTAny DTAny 0 Nothing+    PType _ -> DTType+    PRegexp _ -> DTRegexp Nothing+    PNumber n ->+      if Scientific.isInteger n+        then DTInteger Nothing Nothing+        else DTFloat Nothing Nothing
src/Puppet/Interpreter/Resolve/Sprintf.hs view
@@ -1,37 +1,39 @@-module Puppet.Interpreter.Resolve.Sprintf (-  sprintf-) where-+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -import           XPrelude+{-# HLINT ignore "Use <$>" #-}+module Puppet.Interpreter.Resolve.Sprintf+  ( sprintf,+  )+where -import           Data.Attoparsec.Text-import qualified Data.Text                         as Text-import qualified Data.Text.Lazy                    as TL-import qualified Data.Text.Lazy.Builder            as TB-import qualified Data.Text.Lazy.Builder.Int        as TB+import Data.Attoparsec.Text+import qualified Data.Text as Text+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TB+import qualified Data.Text.Lazy.Builder.Int as TB import qualified Data.Text.Lazy.Builder.Scientific as TB--import           Puppet.Interpreter.Helpers-import           Puppet.Interpreter.PrettyPrinter  ()-import           Puppet.Interpreter.Types+import Puppet.Interpreter.Helpers+import Puppet.Interpreter.PrettyPrinter ()+import Puppet.Interpreter.Types+import XPrelude  data Flag = Minus | Plus | Space | Zero | Hash-          deriving (Show, Eq)+  deriving (Show, Eq)  data FLen = Lhh | Lh | Ll | Lll | LL | Lz | Lj | Lt-           deriving (Show, Eq)+  deriving (Show, Eq)  data FType = TPct | Td | Tu | Tf | TF | Te | TE | Tg | TG | Tx | TX | To | Ts | Tc | Tp | Ta | TA-           deriving (Show, Eq)+  deriving (Show, Eq)  data PrintfFormat = PrintfFormat-  { _pfFlags :: [Flag]-  , _pfWidth :: Maybe Int-  , _pfPrec  :: Maybe Int-  , _pfLen   :: Maybe FLen-  , _pfType  :: FType-  } deriving (Show, Eq)+  { _pfFlags :: [Flag],+    _pfWidth :: Maybe Int,+    _pfPrec :: Maybe Int,+    _pfLen :: Maybe FLen,+    _pfType :: FType+  }+  deriving (Show, Eq)  data FormatStringPart   = Raw Text@@ -39,67 +41,71 @@   deriving (Show, Eq)  parseFormat :: Text -> [FormatStringPart]-parseFormat t | Text.null t = []-              | Text.null nxt = [Raw raw]-              | otherwise = Raw raw : rformat+parseFormat t+  | Text.null t = []+  | Text.null nxt = [Raw raw]+  | otherwise = Raw raw : rformat   where     (raw, nxt) = Text.break (== '%') t     tryNext = case parseFormat (Text.tail nxt) of-                  (Raw nt : nxt') -> Raw (Text.cons '%' nt) : nxt'-                  nxt'            -> Raw (Text.singleton '%') : nxt'+      (Raw nt : nxt') -> Raw (Text.cons '%' nt) : nxt'+      nxt' -> Raw (Text.singleton '%') : nxt'     rformat = case parse format nxt of-                  Fail _ _ _       -> tryNext-                  Partial _        -> tryNext-                  Done remaining f -> Format f : parseFormat remaining+      Fail {} -> tryNext+      Partial _ -> tryNext+      Done remaining f -> Format f : parseFormat remaining  flag :: Parser Flag-flag =   (Minus <$ char '-')-     <|> (Plus  <$ char '+')-     <|> (Space <$ char ' ')-     <|> (Zero  <$ char '0')-     <|> (Hash  <$ char '#')+flag =+  (Minus <$ char '-')+    <|> (Plus <$ char '+')+    <|> (Space <$ char ' ')+    <|> (Zero <$ char '0')+    <|> (Hash <$ char '#')  lenModifier :: Parser FLen-lenModifier =   (Lhh <$ string "hh")-            <|> (Lh  <$ char 'h')-            <|> (Lll <$ string "ll")-            <|> (Ll  <$ char 'l')-            <|> (LL  <$ char 'L')-            <|> (Lz  <$ char 'z')-            <|> (Lj  <$ char 'j')-            <|> (Lt  <$ char 't')+lenModifier =+  (Lhh <$ string "hh")+    <|> (Lh <$ char 'h')+    <|> (Lll <$ string "ll")+    <|> (Ll <$ char 'l')+    <|> (LL <$ char 'L')+    <|> (Lz <$ char 'z')+    <|> (Lj <$ char 'j')+    <|> (Lt <$ char 't')  ftype :: Parser FType-ftype =   (TPct <$ char '%')-      <|> (Td <$ char 'd')-      <|> (Td <$ char 'i')-      <|> (Tu <$ char 'u')-      <|> (Tf <$ char 'f')-      <|> (TF <$ char 'F')-      <|> (Te <$ char 'e')-      <|> (TE <$ char 'E')-      <|> (Tg <$ char 'g')-      <|> (TG <$ char 'G')-      <|> (Tx <$ char 'x')-      <|> (TX <$ char 'X')-      <|> (To <$ char 'o')-      <|> (Ts <$ char 's')-      <|> (Tc <$ char 'c')-      <|> (Ta <$ char 'a')-      <|> (Tp <$ char 'p')-      <|> (TA <$ char 'A')+ftype =+  (TPct <$ char '%')+    <|> (Td <$ char 'd')+    <|> (Td <$ char 'i')+    <|> (Tu <$ char 'u')+    <|> (Tf <$ char 'f')+    <|> (TF <$ char 'F')+    <|> (Te <$ char 'e')+    <|> (TE <$ char 'E')+    <|> (Tg <$ char 'g')+    <|> (TG <$ char 'G')+    <|> (Tx <$ char 'x')+    <|> (TX <$ char 'X')+    <|> (To <$ char 'o')+    <|> (Ts <$ char 's')+    <|> (Tc <$ char 'c')+    <|> (Ta <$ char 'a')+    <|> (Tp <$ char 'p')+    <|> (TA <$ char 'A')  format :: Parser PrintfFormat format = do-    void $ char '%'-    flags <- many flag-    width <- optional decimal-    prec <- optional $ do-        void $ char '.'-        decimal-    len <- optional lenModifier-    ft <- ftype-    return (PrintfFormat flags width prec len ft)+  void $ char '%'+  flags <- many flag+  width <- optional decimal+  prec <- optional $ do+    void $ char '.'+    decimal+  len <- optional lenModifier+  ft <- ftype+  return (PrintfFormat flags width prec len ft)  sprintf :: Text -> [PValue] -> InterpreterMonad PValue sprintf str oargs = PString . TL.toStrict . TB.toLazyText . mconcat <$> go (parseFormat str) oargs@@ -107,38 +113,40 @@     go (Raw x : xs) args = (TB.fromText x :) <$> go xs args     go (Format f : _) _ | Hash `elem` _pfFlags f = throwPosError "sprintf: the # modifier is not supported"     go (Format f : xs) (arg : args) = do-        let numeric = case arg of-                          PNumber n -> pure n-                          PString s -> maybe (throwError "sprintf: Don't know how to convert this to a number") return (text2Scientific s)-                          _         -> throwError "sprintf: Don't know how to convert this to a number"-            flags = _pfFlags f-            sh mkBuilder n | has_ Minus            = TL.justifyLeft padlen ' ' (sprefix <> content)-                           | has_ Plus && has_ Zero = sprefix <> TL.justifyRight mpadlen '0' content-                           | has_ Plus             = TL.justifyRight padlen ' ' (sprefix <> content)-                           | has_ Zero             = TL.justifyRight padlen '0' content-                           | otherwise            = TL.justifyRight padlen ' ' content-                 where-                   (mpadlen, sprefix) | Plus  `elem` flags && n >= 0 = (padlen - 1, "+")-                                      | Space `elem` flags && n >= 0 = (padlen - 1, " ")-                                      | otherwise = (padlen, mempty)-                   padlen = maybe 0 fromIntegral (_pfWidth f)-                   has_ flg = flg `elem` flags-                   content = TB.toLazyText (mkBuilder n)-        baseString <- case _pfType f of-                          Td -> sh (TB.formatScientificBuilder TB.Fixed    (Just 0))      <$> numeric-                          Tf -> sh (TB.formatScientificBuilder TB.Fixed    (_pfPrec f))   <$> numeric-                          TF -> sh (TB.formatScientificBuilder TB.Fixed    (_pfPrec f))   <$> numeric-                          Tg -> sh (TB.formatScientificBuilder TB.Generic  (_pfPrec f))   <$> numeric-                          TG -> sh (TB.formatScientificBuilder TB.Generic  (_pfPrec f))   <$> numeric-                          Te -> sh (TB.formatScientificBuilder TB.Exponent (_pfPrec f))   <$> numeric-                          TE -> sh (TB.formatScientificBuilder TB.Exponent (_pfPrec f))   <$> numeric-                          Tx -> sh (TB.hexadecimal . (truncate :: Scientific -> Integer)) <$> numeric-                          TX -> sh (TB.hexadecimal . (truncate :: Scientific -> Integer)) <$> numeric-                          Ts -> return $ case arg of-                                             PString s -> TL.fromStrict s-                                             _ -> TL.pack (show (pretty arg))-                          _ -> throwPosError "sprintf: not yet supported"-        (TB.fromLazyText baseString :) <$> go xs args+      let numeric = case arg of+            PNumber n -> pure n+            PString s -> maybe (throwError "sprintf: Don't know how to convert this to a number") return (text2Scientific s)+            _ -> throwError "sprintf: Don't know how to convert this to a number"+          flags = _pfFlags f+          sh mkBuilder n+            | has_ Minus = TL.justifyLeft padlen ' ' (sprefix <> content)+            | has_ Plus && has_ Zero = sprefix <> TL.justifyRight mpadlen '0' content+            | has_ Plus = TL.justifyRight padlen ' ' (sprefix <> content)+            | has_ Zero = TL.justifyRight padlen '0' content+            | otherwise = TL.justifyRight padlen ' ' content+            where+              (mpadlen, sprefix)+                | Plus `elem` flags && n >= 0 = (padlen - 1, "+")+                | Space `elem` flags && n >= 0 = (padlen - 1, " ")+                | otherwise = (padlen, mempty)+              padlen = maybe 0 fromIntegral (_pfWidth f)+              has_ flg = flg `elem` flags+              content = TB.toLazyText (mkBuilder n)+      baseString <- case _pfType f of+        Td -> sh (TB.formatScientificBuilder TB.Fixed (Just 0)) <$> numeric+        Tf -> sh (TB.formatScientificBuilder TB.Fixed (_pfPrec f)) <$> numeric+        TF -> sh (TB.formatScientificBuilder TB.Fixed (_pfPrec f)) <$> numeric+        Tg -> sh (TB.formatScientificBuilder TB.Generic (_pfPrec f)) <$> numeric+        TG -> sh (TB.formatScientificBuilder TB.Generic (_pfPrec f)) <$> numeric+        Te -> sh (TB.formatScientificBuilder TB.Exponent (_pfPrec f)) <$> numeric+        TE -> sh (TB.formatScientificBuilder TB.Exponent (_pfPrec f)) <$> numeric+        Tx -> sh (TB.hexadecimal . (truncate :: Scientific -> Integer)) <$> numeric+        TX -> sh (TB.hexadecimal . (truncate :: Scientific -> Integer)) <$> numeric+        Ts -> return $ case arg of+          PString s -> TL.fromStrict s+          _ -> TL.pack (show (pretty arg))+        _ -> throwPosError "sprintf: not yet supported"+      (TB.fromLazyText baseString :) <$> go xs args     go [] [] = return []     go _ [] = throwPosError "sprintf: not enough arguments"     go [] _ = [] <$ let msg = "sprintf: too many arguments" in checkStrict msg msg
src/Puppet/Interpreter/RubyRandom.hs view
@@ -1,20 +1,21 @@ module Puppet.Interpreter.RubyRandom-  ( randInit-  , limitedRand-  ) where--import           XPrelude+  ( randInit,+    limitedRand,+  )+where -import qualified Data.List                   as List-import qualified Data.Vector.Unboxed         as V+import qualified Data.List as List+import qualified Data.Vector.Unboxed as V import qualified Data.Vector.Unboxed.Mutable as VM+import XPrelude  data RandState = RandState-  { _array :: V.Vector Int-  , _left :: Int-  , _initf :: Int-  , _next :: Int-  } deriving (Show)+  { _array :: V.Vector Int,+    _left :: Int,+    _initf :: Int,+    _next :: Int+  }+  deriving (Show)  mixbits :: Int -> Int -> Int mixbits u v = (u .&. 0x80000000) .|. (v .&. 0x7fffffff)@@ -29,6 +30,7 @@  valN :: Int valN = 624+ valM :: Int valM = 397 @@ -41,84 +43,88 @@  nextState :: RandState -> RandState nextState (RandState array _ initf _) = RandState narray valN 1 0-    where-        rarray = if initf == 0-                     then _array (initGenrand 5489)-                     else array-        narray = V.modify (\v -> twist1 v >> twist2 v >> final v) rarray-        twist1 v = mapM_ (twist' valM v) [0..(valN - valM - 1)]-        twist2 v = mapM_ (twist' (valM - valN) v) [(valN - valM) .. (valN - 2)]-        final v = do-            a <- VM.read v (valN - 1)-            b <- VM.read v 0-            pm <- VM.read v (valM - 1)-            let res = pm `xor` twist a b-            VM.write v (valN - 1) res-        twist' idx v n = do-            a <- VM.read v n-            b <- VM.read v (n+1)-            pm <- VM.read v (idx + n)-            let res = pm `xor` twist a b-            VM.write v n res+  where+    rarray =+      if initf == 0+        then _array (initGenrand 5489)+        else array+    narray = V.modify (\v -> twist1 v >> twist2 v >> final v) rarray+    twist1 v = mapM_ (twist' valM v) [0 .. (valN - valM - 1)]+    twist2 v = mapM_ (twist' (valM - valN) v) [(valN - valM) .. (valN - 2)]+    final v = do+      a <- VM.read v (valN - 1)+      b <- VM.read v 0+      pm <- VM.read v (valM - 1)+      let res = pm `xor` twist a b+      VM.write v (valN - 1) res+    twist' idx v n = do+      a <- VM.read v n+      b <- VM.read v (n + 1)+      pm <- VM.read v (idx + n)+      let res = pm `xor` twist a b+      VM.write v n res  -- needs refactoring, too tedious for me initGenrandBigint :: Integer -> RandState initGenrandBigint seed =-    let intarray = unfoldr reduceint seed-        reduceint :: Integer -> Maybe (Integer, Integer)-        reduceint 0 = Nothing-        reduceint x = Just (x .&. 0xffffffff, x `shiftR` 32)-        initstate = _array (initGenrand 19650218)-        keylist = concat (repeat intarray)-        jlist = concat (repeat [0..(length intarray - 1)])-        kmax = max (length intarray) valN-        state1 = foldl' apply1 initstate (List.zip3 keylist jlist [1..kmax])-        apply1 :: V.Vector Int -> (Integer, Int, Int) -> V.Vector Int-        apply1 ra (initKey, j, ri) =-            let (a, i, sti, stim) = rollover ra ri-                nsti = ((sti `xor` ((stim `xor` (stim `shiftR` 30)) * 1664525)) + fromIntegral initKey + j) .&. 0xffffffff-            in  a V.// [(i,nsti)]-        state2 = foldl' apply2 state1 [2..valN]-        rollover :: V.Vector Int -> Int -> (V.Vector Int, Int, Int, Int)-        rollover ra ri =-            let (a,i) = if ri >= valN-                            then (ra V.// [(0, ra V.! (valN-1))],1)-                            else (ra,ri)-            in  (a,i,a V.! i, a V.! (i-1))-        apply2 :: V.Vector Int -> Int -> V.Vector Int-        apply2 ra ri =-            let (a, i, sti, stim) = rollover ra ri-                nsti = ((sti `xor` ((stim `xor` (stim `shiftR` 30)) * 1566083941)) - i) .&. 0xffffffff-            in  a V.// [(i,nsti)]-    in  RandState (state2 V.// [(0,0x80000000)]) 1 1 0-+  let intarray = unfoldr reduceint seed+      reduceint :: Integer -> Maybe (Integer, Integer)+      reduceint 0 = Nothing+      reduceint x = Just (x .&. 0xffffffff, x `shiftR` 32)+      initstate = _array (initGenrand 19650218)+      keylist = concat (repeat intarray)+      jlist = concat (repeat [0 .. (length intarray - 1)])+      kmax = max (length intarray) valN+      state1 = foldl' apply1 initstate (List.zip3 keylist jlist [1 .. kmax])+      apply1 :: V.Vector Int -> (Integer, Int, Int) -> V.Vector Int+      apply1 ra (initKey, j, ri) =+        let (a, i, sti, stim) = rollover ra ri+            nsti = ((sti `xor` ((stim `xor` (stim `shiftR` 30)) * 1664525)) + fromIntegral initKey + j) .&. 0xffffffff+         in a V.// [(i, nsti)]+      state2 = foldl' apply2 state1 [2 .. valN]+      rollover :: V.Vector Int -> Int -> (V.Vector Int, Int, Int, Int)+      rollover ra ri =+        let (a, i) =+              if ri >= valN+                then (ra V.// [(0, ra V.! (valN - 1))], 1)+                else (ra, ri)+         in (a, i, a V.! i, a V.! (i - 1))+      apply2 :: V.Vector Int -> Int -> V.Vector Int+      apply2 ra ri =+        let (a, i, sti, stim) = rollover ra ri+            nsti = ((sti `xor` ((stim `xor` (stim `shiftR` 30)) * 1566083941)) - i) .&. 0xffffffff+         in a V.// [(i, nsti)]+   in RandState (state2 V.// [(0, 0x80000000)]) 1 1 0  randInit :: Integer -> RandState-randInit x = if x <= 0xffffffff-                 then initGenrand x-                 else initGenrandBigint x+randInit x =+  if x <= 0xffffffff+    then initGenrand x+    else initGenrandBigint x  limitedRand :: RandState -> Int -> (Int, RandState)-limitedRand s n | n <= 0 = (0, s)-                | otherwise = limitedRand' s-    where-        masked = foldl' (\x pow -> x .|. (x `shiftR` pow)) (n - 1) [1,2,4,8,16,32]-        limitedRand' s' =-            let (rval, ns) = rbGenrandInt32 s'-                val = rval .&. masked-            in  if n <= val-                    then limitedRand' ns-                    else (val, ns)-        rbGenrandInt32 :: RandState -> (Int, RandState)-        rbGenrandInt32 st =-            let rst = if _left st == 1-                          then nextState st-                          else st { _left = _left st - 1 }-                next = _next rst-                cv = _array rst V.! next-                nst = rst { _next = next + 1 }-                y1 = cv `xor` (cv `shiftR` 11)-                y2 = y1 `xor` ((y1 `shiftL` 7) .&. 0x9d2c5680)-                y3 = y2 `xor` ((y2 `shiftL` 15) .&. 0xefc60000)-                y4 = y3 `xor` (y3 `shiftR` 18)-            in (y4,nst)+limitedRand s n+  | n <= 0 = (0, s)+  | otherwise = limitedRand' s+  where+    masked = foldl' (\x pow -> x .|. (x `shiftR` pow)) (n - 1) [1, 2, 4, 8, 16, 32]+    limitedRand' s' =+      let (rval, ns) = rbGenrandInt32 s'+          val = rval .&. masked+       in if n <= val+            then limitedRand' ns+            else (val, ns)+    rbGenrandInt32 :: RandState -> (Int, RandState)+    rbGenrandInt32 st =+      let rst =+            if _left st == 1+              then nextState st+              else st {_left = _left st - 1}+          next = _next rst+          cv = _array rst V.! next+          nst = rst {_next = next + 1}+          y1 = cv `xor` (cv `shiftR` 11)+          y2 = y1 `xor` ((y1 `shiftL` 7) .&. 0x9d2c5680)+          y3 = y2 `xor` ((y2 `shiftL` 15) .&. 0xefc60000)+          y4 = y3 `xor` (y3 `shiftR` 18)+       in (y4, nst)
src/Puppet/Interpreter/Types.hs view
@@ -1,115 +1,120 @@-{-# LANGUAGE AutoDeriveTypeable     #-}-{-# LANGUAGE DeriveGeneric          #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs                  #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TemplateHaskell        #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} -module Puppet.Interpreter.Types (-  -- * Operational state-   InterpreterState(InterpreterState)- , scopes- , definedResources- , nestedDeclarations- , resModifiers- , extraRelations- , curScope- , curPos- , loadedClasses- -- * Operational reader- , InterpreterReader(InterpreterReader)- , readerNativeTypes- , readerGetStatement- , readerGetTemplate- , readerPdbApi- , readerExternalFunc- , readerNodename- , readerHieraQuery- , readerIoMethods- , readerIgnoredModules- , readerExternalModules- , readerIsStrict- , readerPuppetPaths- , readerFacts- , readerRebaseFile- -- * Interpreter monad- , InterpreterMonad- , InterpreterWriter- , InterpreterInstr(..)- , Strictness(..)- -- * Io methods- , IoMethods(IoMethods)- , ioGetCurrentCallStack- , ioReadFile- , ioTraceEvent- , MonadThrowPos(..)- -- * Resource modifier- , ResourceModifier(ResourceModifier)- , rmResType- , rmDeclaration- , rmSearch- , rmType- , rmMutation- , rmModifierType- , ModifierType(..)- , OverrideType(..)- , ResourceCollectorType(..)- , ClassIncludeType(..)- , RSearchExpression(..)- -- * Scope information- , ScopeInformation(ScopeInformation)- , scopeResDefaults- , scopeVariables- , scopeParent- , scopeOverrides- , scopeContainer- , scopeExtraTags- , CurContainer(CurContainer)- , cctype- , cctags- -- * Resource default- , ResDefaults(ResDefaults)- , resDefValues- , resDefSrcScope- , resDefPos- , resDefType- , ResRefOverride(..)- , ScopeEnteringContext(..)- , TopLevelType(..)- -- * Hiera- , HieraQueryLayers(..)- , globalLayer- , environmentLayer- , moduleLayer- -- * Template- , TemplateSource(..)- -- * Re-export- , module Puppet.Language-) where+module Puppet.Interpreter.Types+  ( -- * Operational state+    InterpreterState (InterpreterState),+    scopes,+    definedResources,+    nestedDeclarations,+    resModifiers,+    extraRelations,+    curScope,+    curPos,+    loadedClasses, -import           XPrelude.Extra-import           XPrelude.PP+    -- * Operational reader+    InterpreterReader (InterpreterReader),+    readerNativeTypes,+    readerGetStatement,+    readerGetTemplate,+    readerPdbApi,+    readerExternalFunc,+    readerNodename,+    readerHieraQuery,+    readerIoMethods,+    readerIgnoredModules,+    readerExternalModules,+    readerIsStrict,+    readerPuppetPaths,+    readerFacts,+    readerRebaseFile, +    -- * Interpreter monad+    InterpreterMonad,+    InterpreterWriter,+    InterpreterInstr (..),+    Strictness (..),++    -- * Io methods+    IoMethods (IoMethods),+    ioGetCurrentCallStack,+    ioReadFile,+    ioTraceEvent,+    MonadThrowPos (..),++    -- * Resource modifier+    ResourceModifier (ResourceModifier),+    rmResType,+    rmDeclaration,+    rmSearch,+    rmType,+    rmMutation,+    rmModifierType,+    ModifierType (..),+    OverrideType (..),+    ResourceCollectorType (..),+    ClassIncludeType (..),+    RSearchExpression (..),++    -- * Scope information+    ScopeInformation (ScopeInformation),+    scopeResDefaults,+    scopeVariables,+    scopeParent,+    scopeOverrides,+    scopeContainer,+    scopeExtraTags,+    CurContainer (CurContainer),+    cctype,+    cctags,++    -- * Resource default+    ResDefaults (ResDefaults),+    resDefValues,+    resDefSrcScope,+    resDefPos,+    resDefType,+    ResRefOverride (..),+    ScopeEnteringContext (..),+    TopLevelType (..),++    -- * Hiera+    HieraQueryLayers (..),+    globalLayer,+    environmentLayer,+    moduleLayer,++    -- * Template+    TemplateSource (..),++    -- * Re-export+    module Puppet.Language,+  )+where+ import qualified Control.Monad.Fail as Fail-import           Control.Monad.Operational-import           Control.Monad.State.Strict-import           Control.Monad.Writer.Class-import           Data.Aeson                 as A-import qualified Data.Either.Strict         as S-import qualified Data.HashMap.Strict        as HM-import qualified Data.List                  as List-import qualified Data.Maybe.Strict          as S+import Control.Monad.Operational+import Control.Monad.State.Strict+import Control.Monad.Writer.Class+import Data.Aeson as A+import qualified Data.Either.Strict as S+import qualified Data.HashMap.Strict as HM+import qualified Data.List as List+import qualified Data.Maybe.Strict as S+import Facter import qualified GHC.Show import qualified GHC.Stack-import qualified System.Log.Logger          as Log--import           Facter-import           Hiera.Server-import           Puppet.Language-import           Puppet.Parser.Types-import           PuppetDB-+import Hiera.Server+import Puppet.Language+import Puppet.Parser.Types+import PuppetDB+import qualified System.Log.Logger as Log+import XPrelude.Extra+import XPrelude.PP  -- | The intepreter can run in two modes : a strict mode (recommended), and -- a permissive mode.@@ -119,9 +124,9 @@   deriving (Show, Eq)  instance FromJSON Strictness where-  parseJSON (Bool True)  = pure Strict+  parseJSON (Bool True) = pure Strict   parseJSON (Bool False) = pure Permissive-  parseJSON _            = mzero+  parseJSON _ = mzero  data RSearchExpression   = REqualitySearch !Text !PValue@@ -135,69 +140,78 @@ -- -- See <https://docs.puppetlabs.com/puppet/latest/reference/lang_classes.html#include-like-vs-resource-like puppet reference>. data ClassIncludeType-  = ClassIncludeLike -- ^ Using the include or contain function-  | ClassResourceLike -- ^ Resource like declaration+  = -- | Using the include or contain function+    ClassIncludeLike+  | -- | Resource like declaration+    ClassResourceLike   deriving (Eq)  -- | Differentiate the distinct top level types such as node, define or class. data TopLevelType-  = TopNode -- ^ For node entries-  | TopDefine -- ^ For defines-  | TopClass -- ^ For classes+  = -- | For node entries+    TopNode+  | -- | For defines+    TopDefine+  | -- | For classes+    TopClass   deriving (Generic, Eq)  instance Hashable TopLevelType  -- | From the evaluation of Resource Default Declaration. data ResDefaults = ResDefaults-  { _resDefType     :: !Text-  , _resDefSrcScope :: !Text-  , _resDefValues   :: !(Container PValue)-  , _resDefPos      :: !PPosition+  { _resDefType :: !Text,+    _resDefSrcScope :: !Text,+    _resDefValues :: !(Container PValue),+    _resDefPos :: !PPosition   }  -- | From the evaluation of Resource Override Declaration. data ResRefOverride = ResRefOverride-  { _rrid     :: !RIdentifier-  , _rrparams :: !(Container PValue)-  , _rrpos    :: !PPosition-  } deriving (Eq)+  { _rrid :: !RIdentifier,+    _rrparams :: !(Container PValue),+    _rrpos :: !PPosition+  }+  deriving (Eq)  data ScopeEnteringContext   = SENormal-  | SEChild !Text -- ^ We enter the scope as the child of another class-  | SEParent !Text -- ^ We enter the scope as the parent of another class+  | -- | We enter the scope as the child of another class+    SEChild !Text+  | -- | We enter the scope as the parent of another class+    SEParent !Text  -- | The type of the container together with its tags. data CurContainer = CurContainer-  { _cctype :: !CurContainerDesc-  , _cctags :: !(HashSet Text)-  } deriving (Eq)+  { _cctype :: !CurContainerDesc,+    _cctags :: !(HashSet Text)+  }+  deriving (Eq)  data ScopeInformation = ScopeInformation-  { _scopeVariables   :: !(Container (Pair (Pair PValue PPosition) CurContainerDesc))-  , _scopeResDefaults :: !(Container ResDefaults)-  , _scopeExtraTags   :: !(HashSet Text)-  , _scopeContainer   :: !CurContainer-  , _scopeOverrides   :: !(HashMap RIdentifier ResRefOverride)-  , _scopeParent      :: !(S.Maybe Text)+  { _scopeVariables :: !(Container (Pair (Pair PValue PPosition) CurContainerDesc)),+    _scopeResDefaults :: !(Container ResDefaults),+    _scopeExtraTags :: !(HashSet Text),+    _scopeContainer :: !CurContainer,+    _scopeOverrides :: !(HashMap RIdentifier ResRefOverride),+    _scopeParent :: !(S.Maybe Text)   }  data InterpreterState = InterpreterState-  { _scopes             :: !(Container ScopeInformation)-  , _loadedClasses      :: !(Container (Pair ClassIncludeType PPosition))-  , _definedResources   :: !(HM.HashMap RIdentifier Resource)-  , _curScope           :: ![CurContainerDesc]-  , _curPos             :: !PPosition-  , _nestedDeclarations :: !(HashMap (TopLevelType, Text) Statement)-  , _extraRelations     :: ![LinkInformation]-  , _resModifiers       :: ![ResourceModifier]+  { _scopes :: !(Container ScopeInformation),+    _loadedClasses :: !(Container (Pair ClassIncludeType PPosition)),+    _definedResources :: !(HM.HashMap RIdentifier Resource),+    _curScope :: ![CurContainerDesc],+    _curPos :: !PPosition,+    _nestedDeclarations :: !(HashMap (TopLevelType, Text) Statement),+    _extraRelations :: ![LinkInformation],+    _resModifiers :: ![ResourceModifier]   }  data IoMethods m = IoMethods-  { _ioGetCurrentCallStack :: m [String]-  , _ioReadFile            :: [Text] -> m (Either String Text)-  , _ioTraceEvent          :: String -> m ()+  { _ioGetCurrentCallStack :: m [String],+    _ioReadFile :: [Text] -> m (Either String Text),+    _ioTraceEvent :: String -> m ()   }  -- | All available queries including the global and module layer@@ -205,73 +219,76 @@ -- -- The datatype belongs to the "Puppet.Interpreter" module because it serves to implement how Hiera is used within Puppet. data HieraQueryLayers m = HieraQueryLayers-  { _globalLayer :: HieraQueryFunc m-  , _environmentLayer :: HieraQueryFunc m-  , _moduleLayer :: Container (HieraQueryFunc m)+  { _globalLayer :: HieraQueryFunc m,+    _environmentLayer :: HieraQueryFunc m,+    _moduleLayer :: Container (HieraQueryFunc m)   }  -- | Whether the template source is specified 'inline' or loaded from a file.-data  TemplateSource= Inline Text | Filename FilePath+data TemplateSource = Inline Text | Filename FilePath  data InterpreterReader m = InterpreterReader-  { _readerNativeTypes     :: !(Container NativeTypeMethods)-  , _readerGetStatement    :: TopLevelType -> Text -> m (S.Either PrettyError Statement) -- ^ Access to parsed statements-  , _readerGetTemplate     :: TemplateSource -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError Text)-  , _readerPdbApi          :: PuppetDBAPI m-  , _readerExternalFunc    :: Container ([PValue] -> InterpreterMonad PValue) -- ^ External func such as stdlib or puppetlabs-  , _readerNodename        :: Text-  , _readerHieraQuery      :: HieraQueryLayers m-  , _readerIoMethods       :: IoMethods m-  , _readerIgnoredModules  :: HashSet Text-  , _readerExternalModules :: HashSet Text-  , _readerIsStrict        :: Bool-  , _readerPuppetPaths     :: PuppetDirPaths-  , _readerRebaseFile      :: Maybe FilePath-  , _readerFacts           :: Container PValue -- ^ Access to the list of facts that were given to the 'Preferences' module+  { _readerNativeTypes :: !(Container NativeTypeMethods),+    -- | Access to parsed statements+    _readerGetStatement :: TopLevelType -> Text -> m (S.Either PrettyError Statement),+    _readerGetTemplate :: TemplateSource -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError Text),+    _readerPdbApi :: PuppetDBAPI m,+    -- | External func such as stdlib or puppetlabs+    _readerExternalFunc :: Container ([PValue] -> InterpreterMonad PValue),+    _readerNodename :: Text,+    _readerHieraQuery :: HieraQueryLayers m,+    _readerIoMethods :: IoMethods m,+    _readerIgnoredModules :: HashSet Text,+    _readerExternalModules :: HashSet Text,+    _readerIsStrict :: Bool,+    _readerPuppetPaths :: PuppetDirPaths,+    _readerRebaseFile :: Maybe FilePath,+    -- | Access to the list of facts that were given to the 'Preferences' module+    _readerFacts :: Container PValue   }  data InterpreterInstr a where   -- Utility for using what's in 'InterpreterReader'-  GetNativeTypes        :: InterpreterInstr (Container NativeTypeMethods)-  GetStatement          :: TopLevelType -> Text -> InterpreterInstr Statement-  ComputeTemplate       :: TemplateSource-> InterpreterState -> InterpreterInstr Text-  ExternalFunction      :: Text -> [PValue] -> InterpreterInstr PValue-  Facts                 :: InterpreterInstr (Container PValue)-  GetNodeName           :: InterpreterInstr Text-  HieraQuery            :: Container PValue -> Text -> HieraQueryType -> InterpreterInstr (Maybe PValue)-  GetCurrentCallStack   :: InterpreterInstr [String]-  IsIgnoredModule       :: Text -> InterpreterInstr Bool-  IsExternalModule      :: Text -> InterpreterInstr Bool-  IsStrict              :: InterpreterInstr Bool-  PuppetPaths           :: InterpreterInstr PuppetDirPaths-  RebaseFile            :: InterpreterInstr (Maybe FilePath)+  GetNativeTypes :: InterpreterInstr (Container NativeTypeMethods)+  GetStatement :: TopLevelType -> Text -> InterpreterInstr Statement+  ComputeTemplate :: TemplateSource -> InterpreterState -> InterpreterInstr Text+  ExternalFunction :: Text -> [PValue] -> InterpreterInstr PValue+  Facts :: InterpreterInstr (Container PValue)+  GetNodeName :: InterpreterInstr Text+  HieraQuery :: Container PValue -> Text -> HieraQueryType -> InterpreterInstr (Maybe PValue)+  GetCurrentCallStack :: InterpreterInstr [String]+  IsIgnoredModule :: Text -> InterpreterInstr Bool+  IsExternalModule :: Text -> InterpreterInstr Bool+  IsStrict :: InterpreterInstr Bool+  PuppetPaths :: InterpreterInstr PuppetDirPaths+  RebaseFile :: InterpreterInstr (Maybe FilePath)   -- error-  ErrorThrow            :: PrettyError -> InterpreterInstr a-  ErrorCatch            :: InterpreterMonad a -> (PrettyError -> InterpreterMonad a) -> InterpreterInstr a+  ErrorThrow :: PrettyError -> InterpreterInstr a+  ErrorCatch :: InterpreterMonad a -> (PrettyError -> InterpreterMonad a) -> InterpreterInstr a   -- writer-  WriterTell            :: InterpreterWriter -> InterpreterInstr ()-  WriterPass            :: InterpreterMonad (a, InterpreterWriter -> InterpreterWriter) -> InterpreterInstr a-  WriterListen          :: InterpreterMonad a -> InterpreterInstr (a, InterpreterWriter)+  WriterTell :: InterpreterWriter -> InterpreterInstr ()+  WriterPass :: InterpreterMonad (a, InterpreterWriter -> InterpreterWriter) -> InterpreterInstr a+  WriterListen :: InterpreterMonad a -> InterpreterInstr (a, InterpreterWriter)   -- puppetdb wrappers  , see 'PuppetDBAPI' for details-  PDBInformation        :: InterpreterInstr Doc-  PDBReplaceCatalog     :: WireCatalog -> InterpreterInstr ()-  PDBReplaceFacts       :: [(NodeName, Facts)] -> InterpreterInstr ()-  PDBDeactivateNode     :: NodeName -> InterpreterInstr ()-  PDBGetFacts           :: Query FactField -> InterpreterInstr [FactInfo]-  PDBGetResources       :: Query ResourceField -> InterpreterInstr [Resource]-  PDBGetNodes           :: Query NodeField -> InterpreterInstr [NodeInfo]-  PDBCommitDB           :: InterpreterInstr ()+  PDBInformation :: InterpreterInstr Doc+  PDBReplaceCatalog :: WireCatalog -> InterpreterInstr ()+  PDBReplaceFacts :: [(NodeName, Facts)] -> InterpreterInstr ()+  PDBDeactivateNode :: NodeName -> InterpreterInstr ()+  PDBGetFacts :: Query FactField -> InterpreterInstr [FactInfo]+  PDBGetResources :: Query ResourceField -> InterpreterInstr [Resource]+  PDBGetNodes :: Query NodeField -> InterpreterInstr [NodeInfo]+  PDBCommitDB :: InterpreterInstr ()   PDBGetResourcesOfNode :: NodeName -> Query ResourceField -> InterpreterInstr [Resource]   -- Reading the first file that can be read in a list-  ReadFile              :: [Text] -> InterpreterInstr Text+  ReadFile :: [Text] -> InterpreterInstr Text   -- Tracing events-  TraceEvent            :: String -> InterpreterInstr ()+  TraceEvent :: String -> InterpreterInstr ()  -- | The main monad type InterpreterMonad = ProgramT InterpreterInstr (State InterpreterState)  instance Fail.MonadFail InterpreterMonad where-    fail = throwError . PrettyError . ppstring+  fail = throwError . PrettyError . ppstring  instance MonadError PrettyError InterpreterMonad where   throwError = singleton . ErrorThrow@@ -279,33 +296,40 @@  -- | Log type InterpreterWriter = [Pair Log.Priority Doc]+ instance MonadWriter InterpreterWriter InterpreterMonad where   tell = singleton . WriterTell   pass = singleton . WriterPass   listen = singleton . WriterListen  data ResourceModifier = ResourceModifier-  { _rmResType      :: !Text-  , _rmModifierType :: !ModifierType-  , _rmType         :: !ResourceCollectorType-  , _rmSearch       :: !RSearchExpression-  , _rmMutation     :: !(Resource -> InterpreterMonad Resource)-  , _rmDeclaration  :: !PPosition+  { _rmResType :: !Text,+    _rmModifierType :: !ModifierType,+    _rmType :: !ResourceCollectorType,+    _rmSearch :: !RSearchExpression,+    _rmMutation :: !(Resource -> InterpreterMonad Resource),+    _rmDeclaration :: !PPosition   }  instance Show ResourceModifier where   show (ResourceModifier rt mt ct se _ p) = List.unwords ["ResourceModifier", show rt, show mt, show ct, "(" ++ show se ++ ")", "???", show p]  data ModifierType-  = ModifierCollector -- ^ For collectors, optional resources-  | ModifierMustMatch -- ^ For stuff like realize+  = -- | For collectors, optional resources+    ModifierCollector+  | -- | For stuff like realize+    ModifierMustMatch   deriving (Show, Eq)  data OverrideType-  = CantOverride -- ^ Overriding forbidden, will throw an error-  | Replace -- ^ Can silently replace-  | CantReplace -- ^ Silently ignore errors-  | AppendAttribute -- ^ Can append values+  = -- | Overriding forbidden, will throw an error+    CantOverride+  | -- | Can silently replace+    Replace+  | -- | Silently ignore errors+    CantReplace+  | -- | Can append values+    AppendAttribute   deriving (Show, Eq)  data ResourceCollectorType@@ -323,8 +347,7 @@ makeLenses ''ScopeInformation makeLenses ''InterpreterState --class Monad m => MonadThrowPos m where+class (Monad m) => MonadThrowPos m where   throwPosError :: Doc -> m a  -- Useful for mocking for instance in a REPL@@ -341,7 +364,8 @@   throwPosError s = do     p <- use (curPos . _1)     stack <- getCurrentCallStack-    let dstack = if null stack-                   then line-                   else mempty </> ppstring (GHC.Stack.renderStack stack)+    let dstack =+          if null stack+            then line+            else mempty </> ppstring (GHC.Stack.renderStack stack)     throwError (PrettyError (s <+> "at" <+> showPos p <> dstack))
src/Puppet/Language.hs view
@@ -3,19 +3,19 @@ -- This module doesn't depend on any other project modules (except for "XPrelude"). -- It serves as a common bridge that can be used in "PuppetDB" or "Facter" as well as in -- "Puppet.Interpreter" or "Puppet.Parser".-module Puppet.Language(-    module Puppet.Language.Core-  , module Puppet.Language.NativeTypes-  , module Puppet.Language.Paths-  , module Puppet.Language.Resource-  , module Puppet.Language.Value-  , module Puppet.Language.WireCatalog-)+module Puppet.Language+  ( module Puppet.Language.Core,+    module Puppet.Language.NativeTypes,+    module Puppet.Language.Paths,+    module Puppet.Language.Resource,+    module Puppet.Language.Value,+    module Puppet.Language.WireCatalog,+  ) where  import Puppet.Language.Core+import Puppet.Language.NativeTypes+import Puppet.Language.Paths import Puppet.Language.Resource import Puppet.Language.Value import Puppet.Language.WireCatalog-import Puppet.Language.NativeTypes-import Puppet.Language.Paths
src/Puppet/Language/Core.hs view
@@ -1,16 +1,13 @@-module Puppet.Language.Core--where--import           XPrelude+module Puppet.Language.Core where -import           Data.Aeson-import qualified Data.Char           as Char+import Data.Aeson+import qualified Data.Char as Char import qualified Data.HashMap.Strict as Map-import qualified Data.Text           as Text-import qualified Data.Tuple.Strict   as Tuple-import qualified GHC.Show            as Show (Show (..))-import           Text.Megaparsec.Pos+import qualified Data.Text as Text+import qualified Data.Tuple.Strict as Tuple+import qualified GHC.Show as Show (Show (..))+import Text.Megaparsec.Pos+import XPrelude  showPos :: Position -> Doc showPos = blue . pptext . sourcePosPretty@@ -26,8 +23,8 @@ -- | Generates an initial position interval based on a filename. initialPPos :: FilePath -> PPosition initialPPos x =-    let i = initialPos x-    in (i :!: i)+  let i = initialPos x+   in (i :!: i)  -- | A pair containing the start and end of a given token. type PPosition = Pair Position Position@@ -36,6 +33,7 @@ type Position = SourcePos  type NodeName = Text+ type Scope = Text  data CompRegex = CompRegex !Text !Regex@@ -44,7 +42,7 @@   show (CompRegex t _) = show t  instance Eq CompRegex where-    (CompRegex a _) == (CompRegex b _) = a == b+  (CompRegex a _) == (CompRegex b _) = a == b  instance FromJSON CompRegex where   parseJSON = panic "Can't deserialize a regular expression"@@ -75,37 +73,37 @@ capitalizeRT = Text.intercalate "::" . map capitalize' . Text.splitOn "::"   where     capitalize' :: Text -> Text-    capitalize' t | Text.null t = Text.empty-                  | otherwise = Text.cons (Char.toUpper (Text.head t)) (Text.tail t)+    capitalize' t+      | Text.null t = Text.empty+      | otherwise = Text.cons (Char.toUpper (Text.head t)) (Text.tail t) -containerComma'' :: Pretty a => [(Doc, a)] -> Doc+containerComma'' :: (Pretty a) => [(Doc, a)] -> Doc containerComma'' x = indent 4 ins   where-    ins = mconcat $ intersperse (comma <> line <> mempty) (fmap showC x)-    showC (a,b) = a <+> "=>" <+> pretty b+    ins = mconcat $ intersperse (comma <> line) (fmap showC x)+    showC (a, b) = a <+> "=>" <+> pretty b -containerComma' :: Pretty a => [(Doc, a)] -> Doc+containerComma' :: (Pretty a) => [(Doc, a)] -> Doc containerComma' = braces . containerComma'' -containerComma :: Pretty a => Container a -> Doc-containerComma hm = containerComma' (fmap (\(a,b) -> (fill maxalign (ppline a), b)) hml)+containerComma :: (Pretty a) => Container a -> Doc+containerComma hm = containerComma' (fmap (\(a, b) -> (fill maxalign (ppline a), b)) hml)   where-      hml = Map.toList hm-      maxalign = maximum (fmap (Text.length . fst) hml)-+    hml = Map.toList hm+    maxalign = maximum (fmap (Text.length . fst) hml)  -- Lens _sourceName :: Lens' Position String-_sourceName = lens sourceName (\s n -> s { sourceName = n })+_sourceName = lens sourceName (\s n -> s {sourceName = n})  _sourceLine :: Lens' Position Pos-_sourceLine = lens sourceLine (\s l -> s { sourceLine = l })+_sourceLine = lens sourceLine (\s l -> s {sourceLine = l})  _sourceColumn :: Lens' Position Pos-_sourceColumn = lens sourceColumn (\s c -> s { sourceColumn = c })+_sourceColumn = lens sourceColumn (\s c -> s {sourceColumn = c})  -- | Generates a 'PPosition' based on a filename and line number. toPPos :: Text -> Int -> PPosition toPPos fl ln =-  let p = (initialPos (toS fl)) { sourceLine = mkPos $ fromIntegral (max 1 ln) }-  in  (p :!: p)+  let p = (initialPos (toS fl)) {sourceLine = mkPos $ fromIntegral (max 1 ln)}+   in (p :!: p)
src/Puppet/Language/NativeTypes.hs view
@@ -1,48 +1,60 @@ -- | This exposed module holds the /native/ Puppet resource types.-module Puppet.Language.NativeTypes (-    baseNativeTypes-  , defaulttype-  , NativeTypeMethods-  , NativeTypeName-  , HasNativeTypeMethods(..)-) where--import qualified Data.HashMap.Strict                       as HM+module Puppet.Language.NativeTypes+  ( baseNativeTypes,+    defaulttype,+    NativeTypeMethods,+    NativeTypeName,+    HasNativeTypeMethods (..),+  )+where -import           Puppet.Language.NativeTypes.Concat-import           Puppet.Language.NativeTypes.Cron-import           Puppet.Language.NativeTypes.Exec-import           Puppet.Language.NativeTypes.File-import           Puppet.Language.NativeTypes.Group-import           Puppet.Language.NativeTypes.Helpers-import           Puppet.Language.NativeTypes.Host-import           Puppet.Language.NativeTypes.Mount-import           Puppet.Language.NativeTypes.Notify-import           Puppet.Language.NativeTypes.Package-import           Puppet.Language.NativeTypes.SshSecure-import           Puppet.Language.NativeTypes.User-import           Puppet.Language.NativeTypes.ZoneRecord+import qualified Data.HashMap.Strict as HM+import Puppet.Language.NativeTypes.Concat (nativeConcat, nativeConcatFragment)+import Puppet.Language.NativeTypes.Cron (nativeCron)+import Puppet.Language.NativeTypes.Exec (nativeExec)+import Puppet.Language.NativeTypes.File (nativeFile)+import Puppet.Language.NativeTypes.Group (nativeGroup)+import Puppet.Language.NativeTypes.Helpers+  ( Container,+    HasNativeTypeMethods (..),+    NativeTypeMethods,+    NativeTypeName,+    defaulttype,+    faketype,+    map,+    (++),+  )+import Puppet.Language.NativeTypes.Host (nativeHost)+import Puppet.Language.NativeTypes.Mount (nativeMount)+import Puppet.Language.NativeTypes.Notify (nativeNotify)+import Puppet.Language.NativeTypes.Package (nativePackage)+import Puppet.Language.NativeTypes.SshSecure (nativeSshSecure)+import Puppet.Language.NativeTypes.User (nativeUser)+import Puppet.Language.NativeTypes.ZoneRecord (nativeZoneRecord)  fakeTypes :: [(NativeTypeName, NativeTypeMethods)]-fakeTypes = map faketype ["class"]+fakeTypes = [faketype "class"]  defaultTypes :: [(NativeTypeName, NativeTypeMethods)]-defaultTypes = map defaulttype ["augeas","computer","filebucket","interface","k5login","macauthorization","mailalias","maillist","mcx","nagios_command","nagios_contact","nagios_contactgroup","nagios_host","nagios_hostdependency","nagios_hostescalation","nagios_hostextinfo","nagios_hostgroup","nagios_service","nagios_servicedependency","nagios_serviceescalation","nagios_serviceextinfo","nagios_servicegroup","nagios_timeperiod","resources","router","schedule","scheduledtask","selboolean","selmodule","service","ssh_authorized_key","sshkey","stage","tidy","vlan","yumrepo","zfs","zone","zpool"]+defaultTypes = map defaulttype ["augeas", "computer", "filebucket", "interface", "k5login", "macauthorization", "mailalias", "maillist", "mcx", "nagios_command", "nagios_contact", "nagios_contactgroup", "nagios_host", "nagios_hostdependency", "nagios_hostescalation", "nagios_hostextinfo", "nagios_hostgroup", "nagios_service", "nagios_servicedependency", "nagios_serviceescalation", "nagios_serviceextinfo", "nagios_servicegroup", "nagios_timeperiod", "resources", "router", "schedule", "scheduledtask", "selboolean", "selmodule", "service", "ssh_authorized_key", "sshkey", "stage", "tidy", "vlan", "yumrepo", "zfs", "zone", "zpool"]  -- | The map of native types. baseNativeTypes :: Container NativeTypeMethods-baseNativeTypes = HM.fromList+baseNativeTypes =+  HM.fromList     ( nativeConcat-    : nativeConcatFragment-    : nativeCron-    : nativeExec-    : nativeFile-    : nativeGroup-    : nativeHost-    : nativeMount-    : nativeNotify-    : nativePackage-    : nativeSshSecure-    : nativeUser-    : nativeZoneRecord-    : fakeTypes ++ defaultTypes)+        : nativeConcatFragment+        : nativeCron+        : nativeExec+        : nativeFile+        : nativeGroup+        : nativeHost+        : nativeMount+        : nativeNotify+        : nativePackage+        : nativeSshSecure+        : nativeUser+        : nativeZoneRecord+        : fakeTypes+        ++ defaultTypes+    )
src/Puppet/Language/NativeTypes/Concat.hs view
@@ -1,7 +1,8 @@-module Puppet.Language.NativeTypes.Concat (-    nativeConcat-  , nativeConcatFragment-) where+module Puppet.Language.NativeTypes.Concat+  ( nativeConcat,+    nativeConcatFragment,+  )+where  import Puppet.Language.NativeTypes.Helpers @@ -13,29 +14,29 @@  concatparamfunctions :: [(Text, [Text -> NativeTypeValidate])] concatparamfunctions =-    [("name"                , [nameval])-    ,("ensure"              , [defaultvalue "present", string, values ["present","absent"]])-    ,("path"                , [string])-    ,("owner"               , [string])-    ,("group"               , [string])-    ,("validate_cmd"        , [string])-    ,("mode"                , [defaultvalue "0644", string])-    ,("warn"                , [defaultvalue "false", string, values ["false", "true"]])-    ,("force"               , [defaultvalue "false", string, values ["false", "true"]])-    ,("backup"              , [defaultvalue "puppet", string])-    ,("replace"             , [defaultvalue "true", string, values ["false", "true"]])-    ,("order"               , [defaultvalue "alpha", string, values ["alpha","numeric"]])-    ,("ensure_newline"      , [defaultvalue "false", string, values ["false", "true"]])+  [ ("name", [nameval]),+    ("ensure", [defaultvalue "present", string, values ["present", "absent"]]),+    ("path", [string]),+    ("owner", [string]),+    ("group", [string]),+    ("validate_cmd", [string]),+    ("mode", [defaultvalue "0644", string]),+    ("warn", [defaultvalue "false", string, values ["false", "true"]]),+    ("force", [defaultvalue "false", string, values ["false", "true"]]),+    ("backup", [defaultvalue "puppet", string]),+    ("replace", [defaultvalue "true", string, values ["false", "true"]]),+    ("order", [defaultvalue "alpha", string, values ["alpha", "numeric"]]),+    ("ensure_newline", [defaultvalue "false", string, values ["false", "true"]])     -- deprecated     -- ,("gnu"                 , [string])-    ]+  ]  fragmentparamfunctions :: [(Text, [Text -> NativeTypeValidate])] fragmentparamfunctions =-    [("name"                , [nameval])-    ,("target"              , [string, mandatory])-    ,("content"             , [string])-    ,("source"              , [string])-     -- order should be an int or a string-    ,("order"               , [defaultvalue "10", string])-    ]+  [ ("name", [nameval]),+    ("target", [string, mandatory]),+    ("content", [string]),+    ("source", [string]),+    -- order should be an int or a string+    ("order", [defaultvalue "10", string])+  ]
src/Puppet/Language/NativeTypes/Cron.hs view
@@ -1,61 +1,59 @@-module Puppet.Language.NativeTypes.Cron-       (nativeCron)-where--import qualified Data.Text                    as Text+module Puppet.Language.NativeTypes.Cron (nativeCron) where +import qualified Data.Text as Text import Puppet.Language.NativeTypes.Helpers  nativeCron :: (NativeTypeName, NativeTypeMethods)-nativeCron = ("cron", nativetypemethods parameterfunctions return )+nativeCron = ("cron", nativetypemethods parameterfunctions return)  -- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] parameterfunctions =-    [("ensure"              , [defaultvalue "present", string, values ["present","absent"]])-    ,("command"             , [string, mandatoryIfNotAbsent])-    ,("environment"         , [])-    ,("hour"                , [vrange 0 23 [] ])-    ,("minute"              , [vrange 0 59 [] ])-    ,("month"               , [vrange 1 12 ["January","February","March","April","May","June","July","August","September","October","November","December"] ])-    ,("monthday"            , [vrange 1 31 [] ])-    ,("name"                , [nameval])-    ,("provider"            , [defaultvalue "crontab", string, values ["crontab"]])-    ,("special"             , [string])-    ,("target"              , [string])-    ,("user"                , [defaultvalue "root", string])-    ,("weekday"             , [vrange 0 7 ["Monday","Tuesday","Wednesday","Thursday","Friday","Saturday","Sunday"]])-    ]-+  [ ("ensure", [defaultvalue "present", string, values ["present", "absent"]]),+    ("command", [string, mandatoryIfNotAbsent]),+    ("environment", []),+    ("hour", [vrange 0 23 []]),+    ("minute", [vrange 0 59 []]),+    ("month", [vrange 1 12 ["January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December"]]),+    ("monthday", [vrange 1 31 []]),+    ("name", [nameval]),+    ("provider", [defaultvalue "crontab", string, values ["crontab"]]),+    ("special", [string]),+    ("target", [string]),+    ("user", [defaultvalue "root", string]),+    ("weekday", [vrange 0 7 ["Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday"]])+  ]  vrange :: Integer -> Integer -> [Text] -> Text -> NativeTypeValidate vrange mi ma valuelist param res = case res ^. rattributes . at param of-    Just (PArray xs) -> foldM (vrange' mi ma valuelist param) res xs-    Just x           -> vrange' mi ma valuelist param res x-    Nothing          -> defaultvalue "*" param res+  Just (PArray xs) -> foldM (vrange' mi ma valuelist param) res xs+  Just x -> vrange' mi ma valuelist param res x+  Nothing -> defaultvalue "*" param res  vrange' :: Integer -> Integer -> [Text] -> Text -> Resource -> PValue -> Either PrettyError Resource vrange' mi ma valuelist param res y = case y of-    PString "*"      -> Right res-    PString "absent" -> Right res-    PNumber n        -> checkint' n mi ma param res-    PString x -> if x `elem` valuelist-        then Right res-        else parseval x mi ma param res-    x  -> perror $ "Parameter" <+> paramname param <+> "value should be a valid cron declaration and not" <+> pretty x+  PString "*" -> Right res+  PString "absent" -> Right res+  PNumber n -> checkint' n mi ma param res+  PString x ->+    if x `elem` valuelist+      then Right res+      else parseval x mi ma param res+  x -> perror $ "Parameter" <+> paramname param <+> "value should be a valid cron declaration and not" <+> pretty x  parseval :: Text -> Integer -> Integer -> Text -> NativeTypeValidate-parseval resval mi ma pname res | "*/" `Text.isPrefixOf` resval = checkint (Text.drop 2 resval)  1 ma pname res-                                | otherwise                  = checkint resval            mi ma pname res+parseval resval mi ma pname res+  | "*/" `Text.isPrefixOf` resval = checkint (Text.drop 2 resval) 1 ma pname res+  | otherwise = checkint resval mi ma pname res  checkint :: Text -> Integer -> Integer -> Text -> NativeTypeValidate checkint st mi ma pname res =-    case text2Scientific st of-        Just n  -> checkint' n mi ma pname res-        Nothing -> perror $ "Invalid value type for parameter" <+> paramname pname <+> ": " <+> red (ppline st)+  case text2Scientific st of+    Just n -> checkint' n mi ma pname res+    Nothing -> perror $ "Invalid value type for parameter" <+> paramname pname <+> ": " <+> red (ppline st)  checkint' :: Scientific -> Integer -> Integer -> Text -> NativeTypeValidate checkint' i mi ma param res =-    if (i >= fromIntegral mi) && (i <= fromIntegral ma)-        then Right res-        else perror $ "Parameter" <+> paramname param <+> "value is out of bound, should satisfy" <+> pretty mi <+> "<=" <+> pplines (show i) <+> "<=" <+> pretty ma+  if (i >= fromIntegral mi) && (i <= fromIntegral ma)+    then Right res+    else perror $ "Parameter" <+> paramname param <+> "value is out of bound, should satisfy" <+> pretty mi <+> "<=" <+> pplines (show i) <+> "<=" <+> pretty ma
src/Puppet/Language/NativeTypes/Exec.hs view
@@ -1,7 +1,6 @@ module Puppet.Language.NativeTypes.Exec (nativeExec) where -import qualified Data.Text                  as Text-+import qualified Data.Text as Text import Puppet.Language.NativeTypes.Helpers  nativeExec :: (NativeTypeName, NativeTypeMethods)@@ -10,29 +9,30 @@ -- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] parameterfunctions =-    [("command"     , [nameval])-    ,("creates"     , [rarray, strings, fullyQualifieds])-    ,("cwd"         , [string, fullyQualified])-    ,("environment" , [rarray, strings])-    ,("group"       , [string])-    ,("logoutput"   , [defaultvalue "false", string, values ["true","false","on_failure"]])-    ,("onlyif"      , [string])-    ,("path"        , [rarray, strings, fullyQualifieds])-    ,("provider"    , [string, values ["posix","shell","windows"]])-    ,("refresh"     , [string])-    ,("refreshonly" , [defaultvalue "false", string, values ["true","false"]])-    ,("returns"     , [defaultvalue "0", rarray, integers])-    ,("timeout"     , [defaultvalue "300", integer])-    ,("tries"       , [defaultvalue "1", integer])-    ,("try_sleep"   , [defaultvalue "0", integer])-    ,("unless"      , [string])-    ,("user"        , [string])-    ]+  [ ("command", [nameval]),+    ("creates", [rarray, strings, fullyQualifieds]),+    ("cwd", [string, fullyQualified]),+    ("environment", [rarray, strings]),+    ("group", [string]),+    ("logoutput", [defaultvalue "false", string, values ["true", "false", "on_failure"]]),+    ("onlyif", [string]),+    ("path", [rarray, strings, fullyQualifieds]),+    ("provider", [string, values ["posix", "shell", "windows"]]),+    ("refresh", [string]),+    ("refreshonly", [defaultvalue "false", string, values ["true", "false"]]),+    ("returns", [defaultvalue "0", rarray, integers]),+    ("timeout", [defaultvalue "300", integer]),+    ("tries", [defaultvalue "1", integer]),+    ("try_sleep", [defaultvalue "0", integer]),+    ("unless", [string]),+    ("user", [string])+  ]  fullyQualifiedOrPath :: NativeTypeValidate fullyQualifiedOrPath res =   case (res ^. rattributes . at "path", res ^. rattributes . at "command") of-    (Nothing, Just (PString x)) -> if Text.head x == '/'-                                     then Right res-                                     else Left "Command must be fully qualified if path is not defined"+    (Nothing, Just (PString x)) ->+      if Text.head x == '/'+        then Right res+        else Left "Command must be fully qualified if path is not defined"     _ -> Right res
src/Puppet/Language/NativeTypes/File.hs view
@@ -1,51 +1,50 @@-module Puppet.Language.NativeTypes.File (nativeFile) where--import qualified Data.Attoparsec.Text                as AT-import qualified Data.Char                           as Char-import qualified Data.Map.Strict                     as Map-import qualified Data.Set                            as Set-import qualified Data.Text                           as Text+{-# LANGUAGE TupleSections #-} -import           Puppet.Language.NativeTypes.Helpers+module Puppet.Language.NativeTypes.File (nativeFile) where +import qualified Data.Attoparsec.Text as AT+import qualified Data.Char as Char+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Text as Text+import Puppet.Language.NativeTypes.Helpers  nativeFile :: (NativeTypeName, NativeTypeMethods) nativeFile = ("file", nativetypemethods parameterfunctions (validateSourceOrContent >=> validateMode)) - -- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them.  parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] parameterfunctions =-    [("backup"               , [string])-    ,("checksum"             , [values ["md5", "md5lite", "mtime", "ctime", "none"]])-    ,("content"              , [string])-    --,("ensure"               , [defaultvalue "present", string, values ["directory","file","present","absent","link"]])-    ,("ensure"               , [defaultvalue "present", string])-    ,("force"                , [string, values ["true","false"]])-    ,("group"                , [defaultvalue "root", string])-    ,("ignore"               , [strings])-    ,("links"                , [string])-    ,("mode"                 , [defaultvalue "0644", string])-    ,("owner"                , [string])-    ,("path"                 , [nameval, fullyQualified, noTrailingSlash'])-    ,("provider"             , [values ["posix","windows"]])-    ,("purge"                , [string, values ["true","false"]])-    ,("recurse"              , [string, values ["inf","true","false","remote"]])-    ,("recurselimit"         , [integer])-    ,("replace"              , [string, values ["true","false","yes","no"]])-    ,("show_diff"            , [string, values ["true","false"]])-    ,("sourceselect"         , [values ["first","all"]])-    ,("seltype"              , [string])-    ,("selrange"             , [string])-    ,("selinux_ignore_defaults", [string, values ["true","false"]])-    ,("selrole"              , [string])-    ,("target"               , [string])-    ,("source"               , [rarray, strings, flip runarray checkSource])-    ,("seluser"              , [string])-    ,("validate_cmd"         , [string])-    ,("validate_replacement" , [string])-    ]+  [ ("backup", [string]),+    ("checksum", [values ["md5", "md5lite", "mtime", "ctime", "none"]]),+    ("content", [string]),+    -- ,("ensure"               , [defaultvalue "present", string, values ["directory","file","present","absent","link"]])+    ("ensure", [defaultvalue "present", string]),+    ("force", [string, values ["true", "false"]]),+    ("group", [defaultvalue "root", string]),+    ("ignore", [strings]),+    ("links", [string]),+    ("mode", [defaultvalue "0644", string]),+    ("owner", [string]),+    ("path", [nameval, fullyQualified, noTrailingSlash']),+    ("provider", [values ["posix", "windows"]]),+    ("purge", [string, values ["true", "false"]]),+    ("recurse", [string, values ["inf", "true", "false", "remote"]]),+    ("recurselimit", [integer]),+    ("replace", [string, values ["true", "false", "yes", "no"]]),+    ("show_diff", [string, values ["true", "false"]]),+    ("sourceselect", [values ["first", "all"]]),+    ("seltype", [string]),+    ("selrange", [string]),+    ("selinux_ignore_defaults", [string, values ["true", "false"]]),+    ("selrole", [string]),+    ("target", [string]),+    ("source", [rarray, strings, flip runarray checkSource]),+    ("seluser", [string]),+    ("validate_cmd", [string]),+    ("validate_replacement", [string])+  ]  noTrailingSlash' :: Text -> NativeTypeValidate noTrailingSlash' param res@@ -54,41 +53,47 @@  validateMode :: NativeTypeValidate validateMode res = do-    modestr <- case res ^. rattributes . at "mode" of-                  Just (PString s) -> return s-                  Just x -> throwError $ PrettyError ("Invalide mode type, should be a string " <+> pretty x)-                  Nothing -> throwError "Could not find mode!"-    (numeric modestr <|> except (ugo modestr)) & runExcept & _Right %~ ($ res)+  modestr <- case res ^. rattributes . at "mode" of+    Just (PString s) -> return s+    Just x -> throwError $ PrettyError ("Invalide mode type, should be a string " <+> pretty x)+    Nothing -> throwError "Could not find mode!"+  (numeric modestr <|> except (ugo modestr)) & runExcept & _Right %~ ($ res)  numeric :: Text -> Except PrettyError (Resource -> Resource) numeric modestr = do-    when ((Text.length modestr /= 3) && (Text.length modestr /= 4)) (throwError "Invalid mode size")-    unless (Text.all Char.isDigit modestr) (throwError "The mode should only be made of digits")-    return $ if Text.length modestr == 3-                 then rattributes . at "mode" ?~ PString (Text.cons '0' modestr)-                 else identity+  when ((Text.length modestr /= 3) && (Text.length modestr /= 4)) (throwError "Invalid mode size")+  unless (Text.all Char.isDigit modestr) (throwError "The mode should only be made of digits")+  return $+    if Text.length modestr == 3+      then rattributes . at "mode" ?~ PString (Text.cons '0' modestr)+      else identity  checkSource :: Text -> PValue -> NativeTypeValidate-checkSource _ (PString x) res | any (`Text.isPrefixOf` x) ["puppet://", "file://", "/", "http://", "https://"] = Right res-                              | otherwise = throwError "A source should start with either puppet://, http://, https:// or file:// or an absolute path"+checkSource _ (PString x) res+  | any (`Text.isPrefixOf` x) ["puppet://", "file://", "/", "http://", "https://"] = Right res+  | otherwise = throwError "A source should start with either puppet://, http://, https:// or file:// or an absolute path" checkSource _ x _ = throwError $ PrettyError ("Expected a string, not" <+> pretty x)  data PermParts = Special | User | Group | Other-               deriving (Eq, Ord)+  deriving (Eq, Ord)  data PermSet = R | W | X-             deriving (Ord, Eq)+  deriving (Ord, Eq)  ugo :: Text -> Either PrettyError (Resource -> Resource)-ugo t = AT.parseOnly (modestring <* AT.endOfInput) t-        & _Left %~ (\rr -> PrettyError $ "Could not parse the mode string: " <> ppstring rr)-        & _Right %~ (\s -> rattributes . at "mode" ?~ PString (mkmode Special s <> mkmode User s <> mkmode Group s <> mkmode Other s))+ugo t =+  AT.parseOnly (modestring <* AT.endOfInput) t+    & _Left %~ (\rr -> PrettyError $ "Could not parse the mode string: " <> ppstring rr)+    & _Right %~ (\s -> rattributes . at "mode" ?~ PString (mkmode Special s <> mkmode User s <> mkmode Group s <> mkmode Other s))  mkmode :: PermParts -> Map PermParts (Set PermSet) -> Text-mkmode p m = let s = m ^. at p . non mempty-             in  Text.pack $ show $ fromEnum (Set.member R s) * 4-                               + fromEnum (Set.member W s) * 2-                               + fromEnum (Set.member X s)+mkmode p m =+  let s = m ^. at p . non mempty+   in Text.pack $+        show $+          fromEnum (Set.member R s) * 4+            + fromEnum (Set.member W s) * 2+            + fromEnum (Set.member X s)  modestring :: AT.Parser (Map PermParts (Set.Set PermSet)) modestring = Map.fromList . mconcat <$> (modepart `AT.sepBy` AT.char ',')@@ -96,14 +101,16 @@ -- TODO suid, sticky and other funky things are not yet supported modepart :: AT.Parser [(PermParts, Set PermSet)] modepart = do-    let permpart =   (AT.char 'u' *> pure [User])-                 <|> (AT.char 'g' *> pure [Group])-                 <|> (AT.char 'o' *> pure [Other])-                 <|> (AT.char 'a' *> pure [User,Group,Other])-        permission =   (AT.char 'r' *> pure R)-                   <|> (AT.char 'w' *> pure W)-                   <|> (AT.char 'x' *> pure X)-    pp <- mconcat <$> some permpart-    void $ AT.char '='-    pr <- Set.fromList <$> some permission-    return (map (\p -> (p, pr)) pp)+  let permpart =+        (AT.char 'u' $> [User])+          <|> (AT.char 'g' $> [Group])+          <|> (AT.char 'o' $> [Other])+          <|> (AT.char 'a' $> [User, Group, Other])+      permission =+        (AT.char 'r' $> R)+          <|> (AT.char 'w' $> W)+          <|> (AT.char 'x' $> X)+  pp <- mconcat <$> some permpart+  void $ AT.char '='+  pr <- Set.fromList <$> some permission+  return (map (,pr) pp)
src/Puppet/Language/NativeTypes/Group.hs view
@@ -1,6 +1,6 @@ module Puppet.Language.NativeTypes.Group (nativeGroup) where -import           Puppet.Language.NativeTypes.Helpers+import Puppet.Language.NativeTypes.Helpers  nativeGroup :: (NativeTypeName, NativeTypeMethods) nativeGroup = ("group", nativetypemethods parameterfunctions return)@@ -8,15 +8,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. parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] parameterfunctions =-    [("allowdupe"               , [string, defaultvalue "false", values ["true","false"]])-    ,("attribute_membership"    , [string, defaultvalue "minimum", values ["inclusive","minimum"]])-    ,("attributes"              , [strings])-    ,("auth_membership"         , [defaultvalue "minimum", string, values ["inclusive","minimum"]])-    ,("ensure"                  , [defaultvalue "present", string, values ["present","absent"]])-    ,("gid"                     , [integer])-    ,("ia_load_module"          , [string])-    ,("members"                 , [strings])-    ,("name"                    , [nameval])-    ,("provider"                , [string, values ["aix","directoryservice","groupadd","ldap","pw","window_adsi"]])-    ,("system"                  , [string, defaultvalue "false", values ["true","false"]])-    ]+  [ ("allowdupe", [string, defaultvalue "false", values ["true", "false"]]),+    ("attribute_membership", [string, defaultvalue "minimum", values ["inclusive", "minimum"]]),+    ("attributes", [strings]),+    ("auth_membership", [defaultvalue "minimum", string, values ["inclusive", "minimum"]]),+    ("ensure", [defaultvalue "present", string, values ["present", "absent"]]),+    ("gid", [integer]),+    ("ia_load_module", [string]),+    ("members", [strings]),+    ("name", [nameval]),+    ("provider", [string, values ["aix", "directoryservice", "groupadd", "ldap", "pw", "window_adsi"]]),+    ("system", [string, defaultvalue "false", values ["true", "false"]])+  ]
src/Puppet/Language/NativeTypes/Helpers.hs view
@@ -1,62 +1,64 @@ {-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Use camelCase" #-} --  Private modules. --  Function and data types that are used to define the native types. module Puppet.Language.NativeTypes.Helpers-  ( module Exports-  , ipaddr-  , nativetypemethods-  , NativeTypeName-  , NativeTypeValidate-  , NativeTypeMethods-  , HasNativeTypeMethods(..)-  , paramname-  , rarray-  , string-  , strings-  , string_s-  , noTrailingSlash-  , fullyQualified-  , fullyQualifieds-  , values-  , defaultvalue-  , nameval-  , defaultValidate-  , integer-  , integers-  , mandatory-  , mandatoryIfNotAbsent-  , inrange-  , faketype-  , defaulttype-  , runarray-  , perror-  , validateSourceOrContent-  ) where--import           XPrelude                 as Exports--import           Data.Char                (isDigit)-import qualified Data.HashMap.Strict      as Map-import qualified Data.HashSet             as HS-import qualified Data.Text                as Text-import qualified Data.Vector              as V+  ( module Exports,+    ipaddr,+    nativetypemethods,+    NativeTypeName,+    NativeTypeValidate,+    NativeTypeMethods,+    HasNativeTypeMethods (..),+    paramname,+    rarray,+    string,+    strings,+    string_s,+    noTrailingSlash,+    fullyQualified,+    fullyQualifieds,+    values,+    defaultvalue,+    nameval,+    defaultValidate,+    integer,+    integers,+    mandatory,+    mandatoryIfNotAbsent,+    inrange,+    faketype,+    defaulttype,+    runarray,+    perror,+    validateSourceOrContent,+  )+where -import           Puppet.Language.Core     as Exports-import           Puppet.Language.Resource as Exports-import           Puppet.Language.Value    as Exports+import Data.Char as Char+import qualified Data.HashMap.Strict as Map+import qualified Data.HashSet as HS+import qualified Data.Text as Text+import qualified Data.Vector as V+import Puppet.Language.Core as Exports+import Puppet.Language.Resource as Exports+import Puppet.Language.Value as Exports import qualified Text.Read-+import XPrelude as Exports  metaparameters :: HS.HashSet Text-metaparameters = HS.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"]+metaparameters = HS.fromList ["tag", "stage", "name", "title", "alias", "audit", "check", "loglevel", "noop", "schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"]  type NativeTypeName = Text+ type NativeTypeValidate = Resource -> Either PrettyError Resource  -- | Attributes (and providers) of a puppet resource type bundled with validation rules data NativeTypeMethods = NativeTypeMethods-  { _puppetValidate :: NativeTypeValidate-  , _puppetFields   :: HS.HashSet Text+  { _puppetValidate :: NativeTypeValidate,+    _puppetFields :: HS.HashSet Text   }  makeClassy ''NativeTypeMethods@@ -72,7 +74,7 @@ nativetypemethods :: [(Text, [Text -> NativeTypeValidate])] -> NativeTypeValidate -> NativeTypeMethods nativetypemethods def extraV =   let params = fromKeys def-  in NativeTypeMethods (defaultValidate params >=> parameterFunctions def >=> extraV)  params+   in NativeTypeMethods (defaultValidate params >=> parameterFunctions def >=> extraV) params   where     fromKeys = HS.fromList . map fst @@ -82,72 +84,76 @@ defaulttype :: NativeTypeName -> (NativeTypeName, NativeTypeMethods) defaulttype tname = (tname, NativeTypeMethods (defaultValidate HS.empty) HS.empty) -{-| Validate resources given a list of valid parameters:--      * checks that no unknown parameters have been set (except metaparameters)--}+-- | Validate resources given a list of valid parameters:+--+--      * checks that no unknown parameters have been set (except metaparameters) defaultValidate :: HS.HashSet Text -> NativeTypeValidate defaultValidate validparameters = checkParameterList validparameters >=> addDefaults  checkParameterList :: HS.HashSet Text -> NativeTypeValidate-checkParameterList validparameters res | HS.null validparameters = Right res-                                       | otherwise = if HS.null setdiff-                                            then Right res-                                            else perror $ "Unknown parameters: " <+> list (map paramname $ HS.toList setdiff)-    where-        keyset = HS.fromList $ Map.keys (res ^. rattributes)-        setdiff = HS.difference keyset (metaparameters `HS.union` validparameters)+checkParameterList validparameters res+  | HS.null validparameters = Right res+  | otherwise =+      if HS.null setdiff+        then Right res+        else perror $ "Unknown parameters: " <+> list (map paramname $ HS.toList setdiff)+  where+    keyset = HS.fromList $ Map.keys (res ^. rattributes)+    setdiff = HS.difference keyset (metaparameters `HS.union` validparameters)  -- | This validator always accept the resources, but add the default parameters (to be defined :) addDefaults :: NativeTypeValidate addDefaults res = Right (res & rattributes %~ newparams)-    where-        def PUndef = False-        def _      = True-        newparams p = Map.filter def $ Map.union p defaults-        defaults    = Map.empty+  where+    def PUndef = False+    def _ = True+    newparams p = Map.filter def $ Map.union p defaults+    defaults = Map.empty  -- | Helper function that runs a validor on a 'PArray' runarray :: Text -> (Text -> PValue -> NativeTypeValidate) -> NativeTypeValidate runarray param func res = case res ^. rattributes . at param of   Just (PArray x) -> V.foldM (flip (func param)) res x-  Just x          -> perror $ "Parameter" <+> paramname param <+> "should be an array, not" <+> pretty x-  Nothing         -> Right res+  Just x -> perror $ "Parameter" <+> paramname param <+> "should be an array, not" <+> pretty x+  Nothing -> Right res -{-| This checks that a given parameter is a string. If it is a 'PBoolean' or-'PNumber' it will convert them to a string.--}+-- | This checks that a given parameter is a string. If it is a 'PBoolean' or+-- 'PNumber' it will convert them to a string. string :: Text -> NativeTypeValidate string param res = case res ^. rattributes . at param of-  Just x  -> string' param x res+  Just x -> string' param x res   Nothing -> Right res  strings :: Text -> NativeTypeValidate strings param = runarray param string' --- | Validates a string or an array of strings+-- |  Validates a string or an array of strings string_s :: Text -> NativeTypeValidate string_s param res = case res ^. rattributes . at param of-  Nothing         -> Right res+  Nothing -> Right res   Just (PArray _) -> strings param res-  Just _          -> string param res+  Just _ -> string param res  string' :: Text -> PValue -> NativeTypeValidate string' param rev res = case rev of-  PString _      -> Right res-  PBoolean True  -> Right (res & rattributes . at param ?~ PString "true")+  PString _ -> Right res+  PBoolean True -> Right (res & rattributes . at param ?~ PString "true")   PBoolean False -> Right (res & rattributes . at param ?~ PString "false")-  PNumber n      -> Right (res & rattributes . at param ?~ PString (scientific2text n))-  x              -> perror $ "Parameter" <+> paramname param <+> "should be a string, and not" <+> pretty x+  PNumber n -> Right (res & rattributes . at param ?~ PString (scientific2text n))+  PSensitive x -> case string' param x res of+    Right v -> Right v+    Left _ -> perror $ "Parameter" <+> paramname param <+> "should be a string, and not" <+> pretty x+  x -> perror $ "Parameter" <+> paramname param <+> "should be a string, and not" <+> pretty x  -- | Makes sure that the parameter, if defined, has a value among this list. values :: [Text] -> Text -> NativeTypeValidate values valuelist param res = case res ^. rattributes . at param of-    Just (PString x) -> if x `elem` valuelist-        then Right res-        else perror $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ppline valuelist) <+> "and not" <+> ppline x-    Just x  -> perror $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ppline valuelist) <+> "and not" <+> pretty x-    Nothing -> Right res+  Just (PString x) ->+    if x `elem` valuelist+      then Right res+      else perror $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ppline valuelist) <+> "and not" <+> ppline x+  Just x -> perror $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ppline valuelist) <+> "and not" <+> pretty x+  Nothing -> Right res  -- | This fills the default values of unset parameters. defaultvalue :: Text -> Text -> NativeTypeValidate@@ -184,7 +190,7 @@ mandatoryIfNotAbsent :: Text -> NativeTypeValidate mandatoryIfNotAbsent param res =   case res ^. rattributes . at param of-    Just _  -> Right res+    Just _ -> Right res     Nothing -> case res ^. rattributes . at "ensure" of       Just "absent" -> Right res       _ -> perror $ "Parameter" <+> paramname param <+> "should be set."@@ -192,13 +198,13 @@ -- | Checks that a given parameter is set. mandatory :: Text -> NativeTypeValidate mandatory param res = case res ^. rattributes . at param of-    Just _  -> Right res-    Nothing -> perror $ "Parameter" <+> paramname param <+> "should be set."+  Just _ -> Right res+  Nothing -> perror $ "Parameter" <+> paramname param <+> "should be set."  -- Helper that takes a list of stuff and will generate a validator. parameterFunctions :: [(Text, [Text -> NativeTypeValidate])] -> NativeTypeValidate parameterFunctions argrules rs = foldM parameterFunctions' rs argrules-    where+  where     parameterFunctions' :: Resource -> (Text, [Text -> NativeTypeValidate]) -> Either PrettyError Resource     parameterFunctions' r (param, validationfunctions) = foldM (parameterFunctions'' param) r validationfunctions     parameterFunctions'' :: Text -> Resource -> (Text -> NativeTypeValidate) -> Either PrettyError Resource@@ -207,15 +213,16 @@ -- checks that a parameter is fully qualified fullyQualified :: Text -> NativeTypeValidate fullyQualified param res = case res ^. rattributes . at param of-    Just path -> fullyQualified' param path res-    Nothing   -> Right res+  Just path -> fullyQualified' param path res+  Nothing -> Right res  noTrailingSlash :: Text -> NativeTypeValidate noTrailingSlash param res =   case res ^. rattributes . at param of-    Just (PString x) -> if Text.last x == '/'-                          then perror ("Parameter" <+> paramname param <+> "should not have a trailing slash")-                          else Right res+    Just (PString x) ->+      if Text.last x == '/'+        then perror ("Parameter" <+> paramname param <+> "should not have a trailing slash")+        else Right res     _ -> Right res  fullyQualifieds :: Text -> NativeTypeValidate@@ -224,55 +231,58 @@ fullyQualified' :: Text -> PValue -> NativeTypeValidate fullyQualified' param path res =   case path of-    PString ("") -> perror $ "Empty path for parameter" <+> paramname param-    PString p    -> if Text.head p == '/'-                      then Right res-                      else perror $ "Path must be absolute, not" <+> ppline p <+> "for parameter" <+> paramname param-    x            -> perror $ "SHOULD NOT HAPPEN: path is not a resolved string, but" <+> pretty x <+> "for parameter" <+> paramname param+    PString "" -> perror $ "Empty path for parameter" <+> paramname param+    PString p ->+      if Text.head p == '/'+        then Right res+        else perror $ "Path must be absolute, not" <+> ppline p <+> "for parameter" <+> paramname param+    x -> perror $ "SHOULD NOT HAPPEN: path is not a resolved string, but" <+> pretty x <+> "for parameter" <+> paramname param  rarray :: Text -> NativeTypeValidate rarray param res = case res ^. rattributes . at param of-    Just (PArray _) -> Right res-    Just x          -> Right $ res & rattributes . at param ?~ PArray (V.singleton x)-    Nothing         -> Right res+  Just (PArray _) -> Right res+  Just x -> Right $ res & rattributes . at param ?~ PArray (V.singleton x)+  Nothing -> Right res  ipaddr :: Text -> NativeTypeValidate ipaddr param res =   case res ^. rattributes . at param of     Nothing -> Right res     Just (PString ip) ->-        if checkipv4 ip 0-          then Right res-          else perror $ "Invalid IP address for parameter" <+> paramname param+      if checkipv4 ip 0+        then Right res+        else perror $ "Invalid IP address for parameter" <+> paramname param     Just x -> perror $ "Parameter" <+> paramname param <+> "should be an IP address string, not" <+> pretty x  checkipv4 :: Text -> Int -> Bool-checkipv4 _  4 = False -- means that there are more than 4 groups+checkipv4 _ 4 = False -- means that there are more than 4 groups checkipv4 "" _ = False -- should never get an empty string checkipv4 ip v =-    let (cur, nxt) = Text.break (=='.') ip-        nextfunc = if Text.null nxt-            then v == 3-            else checkipv4 (Text.tail nxt) (v+1)-        goodcur = not (Text.null cur) && Text.all isDigit cur && (let rcur = Text.Read.read (Text.unpack cur) :: Int in (rcur >= 0) && (rcur <= 255))-    in goodcur && nextfunc+  let (cur, nxt) = Text.break (== '.') ip+      nextfunc =+        if Text.null nxt+          then v == 3+          else checkipv4 (Text.tail nxt) (v + 1)+      goodcur = not (Text.null cur) && Text.all Char.isDigit cur && (let rcur = Text.Read.read (Text.unpack cur) :: Int in (rcur >= 0) && (rcur <= 255))+   in goodcur && nextfunc  inrange :: Integer -> Integer -> Text -> NativeTypeValidate inrange mi ma param res =-    let va = res ^. rattributes . at param-        na = va ^? traverse . _PValueNumber-    in case (va,na) of+  let va = res ^. rattributes . at param+      na = va ^? traverse . _PValueNumber+   in case (va, na) of         (Nothing, _) -> Right res-        (_,Just v)   -> if (v >= fromIntegral mi) && (v <= fromIntegral ma)-                          then Right res-                          else perror $ "Parameter" <+> paramname param <> "'s value should be between" <+> pretty mi <+> "and" <+> pretty ma-        (Just x,_)   -> perror $ "Parameter" <+> paramname param <+> "should be an integer, and not" <+> pretty x+        (_, Just v) ->+          if (v >= fromIntegral mi) && (v <= fromIntegral ma)+            then Right res+            else perror $ "Parameter" <+> paramname param <> "'s value should be between" <+> pretty mi <+> "and" <+> pretty ma+        (Just x, _) -> perror $ "Parameter" <+> paramname param <+> "should be an integer, and not" <+> pretty x  validateSourceOrContent :: NativeTypeValidate-validateSourceOrContent res = let-    parammap =  res ^. rattributes-    source    = Map.member "source"  parammap-    content   = Map.member "content" parammap-    in if source && content-         then perror "Source and content can't be specified at the same time"-         else Right res+validateSourceOrContent res =+  let parammap = res ^. rattributes+      source = Map.member "source" parammap+      content = Map.member "content" parammap+   in if source && content+        then perror "Source and content can't be specified at the same time"+        else Right res
src/Puppet/Language/NativeTypes/Host.hs view
@@ -1,9 +1,8 @@ module Puppet.Language.NativeTypes.Host (nativeHost) where -import qualified Data.Char                           as Char-import qualified Data.Text                           as Text--import           Puppet.Language.NativeTypes.Helpers+import qualified Data.Char as Char+import qualified Data.Text as Text+import Puppet.Language.NativeTypes.Helpers  nativeHost :: (NativeTypeName, NativeTypeMethods) nativeHost = ("host", nativetypemethods parameterfunctions return)@@ -11,34 +10,35 @@ -- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] parameterfunctions =-    [("comment"      , [string, values ["true","false"]])-    ,("ensure"       , [defaultvalue "present", string, values ["present","absent"]])-    ,("host_aliases" , [rarray, strings, checkhostname])-    ,("ip"           , [string, mandatory, ipaddr])-    ,("name"         , [nameval, checkhostname])-    ,("provider"     , [string, values ["parsed"]])-    ,("target"       , [string, fullyQualified])-    ]+  [ ("comment", [string, values ["true", "false"]]),+    ("ensure", [defaultvalue "present", string, values ["present", "absent"]]),+    ("host_aliases", [rarray, strings, checkhostname]),+    ("ip", [string, mandatory, ipaddr]),+    ("name", [nameval, checkhostname]),+    ("provider", [string, values ["parsed"]]),+    ("target", [string, fullyQualified])+  ]  checkhostname :: Text -> NativeTypeValidate checkhostname param res = case res ^. rattributes . at param of-    Nothing            -> Right res-    Just (PArray xs)   -> foldM (checkhostname' param) res xs-    Just x@(PString _) -> checkhostname' param res x-    Just x             -> perror $ paramname param <+> "should be an array or a single string, not" <+> pretty x+  Nothing -> Right res+  Just (PArray xs) -> foldM (checkhostname' param) res xs+  Just x@(PString _) -> checkhostname' param res x+  Just x -> perror $ paramname param <+> "should be an array or a single string, not" <+> pretty x  checkhostname' :: Text -> Resource -> PValue -> Either PrettyError Resource-checkhostname' prm _   (PString "") = perror $ "Empty hostname for parameter" <+> paramname prm-checkhostname' prm res (PString x ) = checkhostname'' prm res x-checkhostname' prm _   x            = perror $ "Parameter " <+> paramname prm <+> "should be an string or an array of strings, but this was found :" <+> pretty x+checkhostname' prm _ (PString "") = perror $ "Empty hostname for parameter" <+> paramname prm+checkhostname' prm res (PString x) = checkhostname'' prm res x+checkhostname' prm _ x = perror $ "Parameter " <+> paramname prm <+> "should be an string or an array of strings, but this was found :" <+> pretty x  checkhostname'' :: Text -> Resource -> Text -> Either PrettyError Resource-checkhostname'' prm _   "" = perror $ "Empty hostname part in parameter" <+> paramname prm+checkhostname'' prm _ "" = perror $ "Empty hostname part in parameter" <+> paramname prm checkhostname'' prm res prt =-    let (cur,nxt) = Text.break (=='.') prt-        nextfunc = if Text.null nxt-                        then Right res-                        else checkhostname'' prm res (Text.tail nxt)-    in if Text.null cur || (Text.head cur == '-') || not (Text.all (\x -> Char.isAlphaNum x || (x=='-')) cur)-            then perror $ "Invalid hostname part for parameter" <+> paramname prm-            else nextfunc+  let (cur, nxt) = Text.break (== '.') prt+      nextfunc =+        if Text.null nxt+          then Right res+          else checkhostname'' prm res (Text.tail nxt)+   in if Text.null cur || (Text.head cur == '-') || not (Text.all (\x -> Char.isAlphaNum x || (x == '-')) cur)+        then perror $ "Invalid hostname part for parameter" <+> paramname prm+        else nextfunc
src/Puppet/Language/NativeTypes/Mount.hs view
@@ -1,22 +1,22 @@ module Puppet.Language.NativeTypes.Mount (nativeMount) where -import           Puppet.Language.NativeTypes.Helpers+import Puppet.Language.NativeTypes.Helpers  nativeMount :: (NativeTypeName, NativeTypeMethods) nativeMount = ("mount", nativetypemethods parameterfunctions return)  parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] parameterfunctions =-    [("atboot"      , [string, values ["true","false"]])-    ,("blockdevice" , [string])-    ,("device"      , [string, mandatoryIfNotAbsent])-    ,("dump"        , [integer, inrange 0 2])-    ,("ensure"      , [defaultvalue "present", string, values ["present","absent","mounted"]])-    ,("fstype"      , [string, mandatoryIfNotAbsent])-    ,("name"        , [nameval])-    ,("options"     , [string])-    ,("pass"        , [defaultvalue "0", integer])-    ,("provider"    , [defaultvalue "parsed", string, values ["parsed"]])-    ,("remounts"    , [string, values ["true","false"]])-    ,("target"      , [string, fullyQualified])-    ]+  [ ("atboot", [string, values ["true", "false"]]),+    ("blockdevice", [string]),+    ("device", [string, mandatoryIfNotAbsent]),+    ("dump", [integer, inrange 0 2]),+    ("ensure", [defaultvalue "present", string, values ["present", "absent", "mounted"]]),+    ("fstype", [string, mandatoryIfNotAbsent]),+    ("name", [nameval]),+    ("options", [string]),+    ("pass", [defaultvalue "0", integer]),+    ("provider", [defaultvalue "parsed", string, values ["parsed"]]),+    ("remounts", [string, values ["true", "false"]]),+    ("target", [string, fullyQualified])+  ]
src/Puppet/Language/NativeTypes/Notify.hs view
@@ -1,12 +1,12 @@ module Puppet.Language.NativeTypes.Notify (nativeNotify) where -import           Puppet.Language.NativeTypes.Helpers+import Puppet.Language.NativeTypes.Helpers  nativeNotify :: (NativeTypeName, NativeTypeMethods) nativeNotify = ("notify", nativetypemethods parameterfunctions return)  parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] parameterfunctions =-  [("message"   , [])-  ,("withpath"  , [string, defaultvalue "false", values ["true","false"]])+  [ ("message", []),+    ("withpath", [string, defaultvalue "false", values ["true", "false"]])   ]
src/Puppet/Language/NativeTypes/Package.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE DeriveGeneric #-}-module Puppet.Language.NativeTypes.Package-  ( nativePackage-  ) where -import qualified Data.HashMap.Strict                 as HM-import qualified Data.HashSet                        as Set+module Puppet.Language.NativeTypes.Package+  ( nativePackage,+  )+where -import           Puppet.Language.NativeTypes.Helpers+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as Set+import Puppet.Language.NativeTypes.Helpers  nativePackage :: (NativeTypeName, NativeTypeMethods) nativePackage = ("package", nativetypemethods parameterfunctions (getFeature >=> checkFeatures))@@ -29,56 +30,58 @@ instance Hashable PackagingFeatures  isFeatureSupported :: HashMap Text (HashSet PackagingFeatures)-isFeatureSupported = HM.fromList [ ("aix", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])-                                  , ("appdmg", Set.fromList [Installable])-                                  , ("apple", Set.fromList [Installable])-                                  , ("apt", Set.fromList [Holdable, InstallOptions, Installable, Purgeable, Uninstallable, Upgradeable, Versionable])-                                  , ("aptitude", Set.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable])-                                  , ("aptrpm", Set.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable])-                                  , ("blastwave", Set.fromList [Installable, Uninstallable, Upgradeable])-                                  , ("dpkg", Set.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable])-                                  , ("fink", Set.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable])-                                  , ("freebsd", Set.fromList [Installable, Uninstallable])-                                  , ("gem", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])-                                  , ("hpux", Set.fromList [Installable, Uninstallable])-                                  , ("macports", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])-                                  , ("msi", Set.fromList [InstallOptions, Installable, UninstallOptions, Uninstallable])-                                  , ("nim", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])-                                  , ("openbsd", Set.fromList [Installable, Uninstallable, Versionable])-                                  , ("pacman", Set.fromList [Installable, Uninstallable, Upgradeable])-                                  , ("pip", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])-                                  , ("pkg", Set.fromList [Holdable, Installable, Uninstallable, Upgradeable, Versionable])-                                  , ("pkgdmg", Set.fromList [Installable])-                                  , ("pkgin", Set.fromList [Installable, Uninstallable])-                                  , ("pkgutil", Set.fromList [Installable, Uninstallable, Upgradeable])-                                  , ("portage", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])-                                  , ("ports", Set.fromList [Installable, Uninstallable, Upgradeable])-                                  , ("portupgrade", Set.fromList [Installable, Uninstallable, Upgradeable])-                                  , ("rpm", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])-                                  , ("rug", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])-                                  , ("sun", Set.fromList [InstallOptions, Installable, Uninstallable, Upgradeable])-                                  , ("sunfreeware", Set.fromList [Installable, Uninstallable, Upgradeable])-                                  , ("up2date", Set.fromList [Installable, Uninstallable, Upgradeable])-                                  , ("urpmi", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])-                                  , ("windows", Set.fromList [InstallOptions, Installable, UninstallOptions, Uninstallable])-                                  , ("yum", Set.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable])-                                  , ("zypper", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])-                                  ]+isFeatureSupported =+  HM.fromList+    [ ("aix", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]),+      ("appdmg", Set.fromList [Installable]),+      ("apple", Set.fromList [Installable]),+      ("apt", Set.fromList [Holdable, InstallOptions, Installable, Purgeable, Uninstallable, Upgradeable, Versionable]),+      ("aptitude", Set.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable]),+      ("aptrpm", Set.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable]),+      ("blastwave", Set.fromList [Installable, Uninstallable, Upgradeable]),+      ("dpkg", Set.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable]),+      ("fink", Set.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable]),+      ("freebsd", Set.fromList [Installable, Uninstallable]),+      ("gem", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]),+      ("hpux", Set.fromList [Installable, Uninstallable]),+      ("macports", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]),+      ("msi", Set.fromList [InstallOptions, Installable, UninstallOptions, Uninstallable]),+      ("nim", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]),+      ("openbsd", Set.fromList [Installable, Uninstallable, Versionable]),+      ("pacman", Set.fromList [Installable, Uninstallable, Upgradeable]),+      ("pip", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]),+      ("pkg", Set.fromList [Holdable, Installable, Uninstallable, Upgradeable, Versionable]),+      ("pkgdmg", Set.fromList [Installable]),+      ("pkgin", Set.fromList [Installable, Uninstallable]),+      ("pkgutil", Set.fromList [Installable, Uninstallable, Upgradeable]),+      ("portage", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]),+      ("ports", Set.fromList [Installable, Uninstallable, Upgradeable]),+      ("portupgrade", Set.fromList [Installable, Uninstallable, Upgradeable]),+      ("rpm", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]),+      ("rug", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]),+      ("sun", Set.fromList [InstallOptions, Installable, Uninstallable, Upgradeable]),+      ("sunfreeware", Set.fromList [Installable, Uninstallable, Upgradeable]),+      ("up2date", Set.fromList [Installable, Uninstallable, Upgradeable]),+      ("urpmi", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]),+      ("windows", Set.fromList [InstallOptions, Installable, UninstallOptions, Uninstallable]),+      ("yum", Set.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable]),+      ("zypper", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable])+    ]  parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] parameterfunctions =-  [("adminfile"        , [string, fullyQualified])-  ,("allowcdrom"       , [string, values ["true","false"]])-  ,("configfiles"      , [string, values ["keep","replace"]])-  --,("ensure"           , [defaultvalue "present", string, values ["present","absent","latest","held","purged","installed"]])-  ,("ensure"           , [defaultvalue "present", string])-  ,("flavor"           , [])-  ,("install_options"  , [rarray])-  ,("name"             , [nameval])-  ,("provider"         , [defaultvalue "apt", string])-  ,("responsefile"     , [string, fullyQualified])-  ,("source"           , [string])-  ,("uninstall_options", [rarray])+  [ ("adminfile", [string, fullyQualified]),+    ("allowcdrom", [string, values ["true", "false"]]),+    ("configfiles", [string, values ["keep", "replace"]]),+    -- ,("ensure"           , [defaultvalue "present", string, values ["present","absent","latest","held","purged","installed"]])+    ("ensure", [defaultvalue "present", string]),+    ("flavor", []),+    ("install_options", [rarray]),+    ("name", [nameval]),+    ("provider", [defaultvalue "apt", string]),+    ("responsefile", [string, fullyQualified]),+    ("source", [string]),+    ("uninstall_options", [rarray])   ]  getFeature :: Resource -> Either PrettyError (HashSet PackagingFeatures, Resource)@@ -86,36 +89,38 @@   case res ^. rattributes . at "provider" of     Just (PString x) ->       case HM.lookup x isFeatureSupported of-        Just s  -> Right (s, res)+        Just s -> Right (s, res)         Nothing -> Left $ PrettyError ("Do not know provider" <+> ppline x)     _ -> Left "Can't happen at Puppet.NativeTypes.Package"  checkFeatures :: (HashSet PackagingFeatures, Resource) -> Either PrettyError Resource checkFeatures =   checkAdminFile-  >=> checkEnsure-  >=> checkParam "install_options" InstallOptions-  >=> checkParam "uninstall_options" UninstallOptions-  >=> decap+    >=> checkEnsure+    >=> checkParam "install_options" InstallOptions+    >=> checkParam "uninstall_options" UninstallOptions+    >=> decap   where-      checkFeature :: HashSet PackagingFeatures -> Resource -> PackagingFeatures -> Either PrettyError (HashSet PackagingFeatures, Resource)-      checkFeature s r f = if Set.member f s-                             then Right (s, r)-                             else Left $ PrettyError ("Feature" <+> pretty f <+> "is required for the current configuration")-      checkParam :: Text -> PackagingFeatures -> (HashSet PackagingFeatures, Resource) -> Either PrettyError (HashSet PackagingFeatures, Resource)-      checkParam pn f (s,r) = if has (ix pn) (r ^. rattributes)-                                  then checkFeature s r f-                                  else Right (s,r)-      checkAdminFile :: (HashSet PackagingFeatures, Resource) -> Either PrettyError (HashSet PackagingFeatures, Resource)-      checkAdminFile = Right -- TODO, check that it only works for aix-      checkEnsure :: (HashSet PackagingFeatures, Resource) -> Either PrettyError (HashSet PackagingFeatures, Resource)-      checkEnsure (s, res) = case res ^. rattributes . at "ensure" of-                                 Just (PString "latest")    -> checkFeature s res Installable-                                 Just (PString "purged")    -> checkFeature s res Purgeable-                                 Just (PString "absent")    -> checkFeature s res Uninstallable-                                 Just (PString "installed") -> checkFeature s res Installable-                                 Just (PString "present")   -> checkFeature s res Installable-                                 Just (PString "held")      -> checkFeature s res Installable >> checkFeature s res Holdable-                                 _ -> checkFeature s res Versionable-      decap :: (HashSet PackagingFeatures, Resource) -> Either PrettyError Resource-      decap = Right . snd+    checkFeature :: HashSet PackagingFeatures -> Resource -> PackagingFeatures -> Either PrettyError (HashSet PackagingFeatures, Resource)+    checkFeature s r f =+      if Set.member f s+        then Right (s, r)+        else Left $ PrettyError ("Feature" <+> pretty f <+> "is required for the current configuration")+    checkParam :: Text -> PackagingFeatures -> (HashSet PackagingFeatures, Resource) -> Either PrettyError (HashSet PackagingFeatures, Resource)+    checkParam pn f (s, r) =+      if has (ix pn) (r ^. rattributes)+        then checkFeature s r f+        else Right (s, r)+    checkAdminFile :: (HashSet PackagingFeatures, Resource) -> Either PrettyError (HashSet PackagingFeatures, Resource)+    checkAdminFile = Right -- TODO, check that it only works for aix+    checkEnsure :: (HashSet PackagingFeatures, Resource) -> Either PrettyError (HashSet PackagingFeatures, Resource)+    checkEnsure (s, res) = case res ^. rattributes . at "ensure" of+      Just (PString "latest") -> checkFeature s res Installable+      Just (PString "purged") -> checkFeature s res Purgeable+      Just (PString "absent") -> checkFeature s res Uninstallable+      Just (PString "installed") -> checkFeature s res Installable+      Just (PString "present") -> checkFeature s res Installable+      Just (PString "held") -> checkFeature s res Installable >> checkFeature s res Holdable+      _ -> checkFeature s res Versionable+    decap :: (HashSet PackagingFeatures, Resource) -> Either PrettyError Resource+    decap = Right . snd
src/Puppet/Language/NativeTypes/SshSecure.hs view
@@ -1,8 +1,9 @@ module Puppet.Language.NativeTypes.SshSecure-  ( nativeSshSecure-  ) where+  ( nativeSshSecure,+  )+where -import           Puppet.Language.NativeTypes.Helpers+import Puppet.Language.NativeTypes.Helpers  nativeSshSecure :: (NativeTypeName, NativeTypeMethods) nativeSshSecure = ("ssh_authorized_key_secure", nativetypemethods parameterfunctions (userOrTarget >=> keyIfPresent))@@ -10,12 +11,12 @@ -- Autorequires: If Puppet is managing the user or user that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] parameterfunctions =-  [ ("type", [string, defaultvalue "ssh-rsa", values ["rsa", "dsa", "ssh-rsa", "ssh-dss"]])-  , ("key", [string])-  , ("user", [string])-  , ("ensure", [defaultvalue "present", string, values ["present", "absent", "role"]])-  , ("target", [string])-  , ("options", [rarray, strings])+  [ ("type", [string, defaultvalue "ssh-rsa", values ["rsa", "dsa", "ssh-rsa", "ssh-dss"]]),+    ("key", [string]),+    ("user", [string]),+    ("ensure", [defaultvalue "present", string, values ["present", "absent", "role"]]),+    ("target", [string]),+    ("options", [rarray, strings])   ]  userOrTarget :: NativeTypeValidate@@ -23,7 +24,6 @@   case (res ^. rattributes & has (ix "user"), res ^. rattributes & has (ix "target")) of     (False, False) -> Left "Parameters user or target are mandatory"     _ -> Right res-  keyIfPresent :: NativeTypeValidate keyIfPresent res =
src/Puppet/Language/NativeTypes/User.hs view
@@ -1,6 +1,6 @@ module Puppet.Language.NativeTypes.User (nativeUser) where -import           Puppet.Language.NativeTypes.Helpers+import Puppet.Language.NativeTypes.Helpers  nativeUser :: (NativeTypeName, NativeTypeMethods) nativeUser = ("user", nativetypemethods parameterfunctions return)@@ -9,35 +9,35 @@ -- If Puppet is managing any parent directories of a file, the file resource will autorequire them. parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] parameterfunctions =-    [("allowdupe"               , [string, defaultvalue "false", values ["true","false"]])-    ,("attribute_membership"    , [string, defaultvalue "minimum", values ["inclusive","minimum"]])-    ,("attributes"              , [rarray,strings])-    ,("auth_membership"         , [defaultvalue "minimum", string, values ["inclusive","minimum"]])-    ,("auths"                   , [rarray,strings])-    ,("comment"                 , [string])-    ,("ensure"                  , [defaultvalue "present", string, values ["present","absent","role"]])-    ,("expiry"                  , [string])-    ,("gid"                     , [string])-    ,("groups"                  , [rarray,strings])-    ,("home"                    , [string, fullyQualified, noTrailingSlash])-    ,("ia_load_module"          , [string])-    ,("iterations"              , [integer])-    ,("key_membership"          , [string, defaultvalue "minimum", values ["inclusive","minimum"]])-    ,("keys"                    , [])-    ,("managehome"              , [string, defaultvalue "false", values ["true","false"]])-    ,("membership"              , [string, defaultvalue "minimum", values ["inclusive","minimum"]])-    ,("name"                    , [nameval])-    ,("password"                , [string])-    ,("password_max_age"        , [integer])-    ,("password_min_age"        , [integer])-    ,("profile_membership"      , [string, defaultvalue "minimum", values ["inclusive","minimum"]])-    ,("profiles"                , [rarray,strings])-    ,("project"                 , [string])-    ,("provider"                , [string, values ["aix","directoryservice","hpuxuseradd","useradd","ldap","pw","user_role_add","window_adsi"]])-    ,("role_membership"         , [string, defaultvalue "minimum", values ["inclusive","minimum"]])-    ,("roles"                   , [rarray,strings])-    ,("salt"                    , [string])-    ,("shell"                   , [string, fullyQualified, noTrailingSlash])-    ,("system"                  , [string, defaultvalue "false", values ["true","false"]])-    ,("uid"                     , [integer])-    ]+  [ ("allowdupe", [string, defaultvalue "false", values ["true", "false"]]),+    ("attribute_membership", [string, defaultvalue "minimum", values ["inclusive", "minimum"]]),+    ("attributes", [rarray, strings]),+    ("auth_membership", [defaultvalue "minimum", string, values ["inclusive", "minimum"]]),+    ("auths", [rarray, strings]),+    ("comment", [string]),+    ("ensure", [defaultvalue "present", string, values ["present", "absent", "role"]]),+    ("expiry", [string]),+    ("gid", [string]),+    ("groups", [rarray, strings]),+    ("home", [string, fullyQualified, noTrailingSlash]),+    ("ia_load_module", [string]),+    ("iterations", [integer]),+    ("key_membership", [string, defaultvalue "minimum", values ["inclusive", "minimum"]]),+    ("keys", []),+    ("managehome", [string, defaultvalue "false", values ["true", "false"]]),+    ("membership", [string, defaultvalue "minimum", values ["inclusive", "minimum"]]),+    ("name", [nameval]),+    ("password", [string]),+    ("password_max_age", [integer]),+    ("password_min_age", [integer]),+    ("profile_membership", [string, defaultvalue "minimum", values ["inclusive", "minimum"]]),+    ("profiles", [rarray, strings]),+    ("project", [string]),+    ("provider", [string, values ["aix", "directoryservice", "hpuxuseradd", "useradd", "ldap", "pw", "user_role_add", "window_adsi"]]),+    ("role_membership", [string, defaultvalue "minimum", values ["inclusive", "minimum"]]),+    ("roles", [rarray, strings]),+    ("salt", [string]),+    ("shell", [string, fullyQualified, noTrailingSlash]),+    ("system", [string, defaultvalue "false", values ["true", "false"]]),+    ("uid", [integer])+  ]
src/Puppet/Language/NativeTypes/ZoneRecord.hs view
@@ -1,7 +1,6 @@ module Puppet.Language.NativeTypes.ZoneRecord (nativeZoneRecord) where -import           Puppet.Language.NativeTypes.Helpers-+import Puppet.Language.NativeTypes.Helpers  nativeZoneRecord :: (NativeTypeName, NativeTypeMethods) nativeZoneRecord = ("zone_record", nativetypemethods parameterfunctions validateMandatories)@@ -10,21 +9,21 @@ -- If Puppet is managing any parent directories of a file, the file resource will autorequire them. parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] parameterfunctions =-  [("name"                , [nameval])-  ,("owner"               , [string])-  ,("dest"                , [string])-  ,("ensure"              , [defaultvalue "present", string, values ["present","absent"]])-  ,("rtype"               , [string, defaultvalue "A", values ["SOA", "A", "AAAA", "MX", "NS", "CNAME", "PTR", "SRV"]])-  ,("rclass"              , [defaultvalue "IN", string])-  ,("ttl"                 , [defaultvalue "2d", string])-  ,("target"              , [string, mandatory])-  ,("nsname"              , [string])-  ,("serial"              , [string])-  ,("slave_refresh"       , [string])-  ,("slave_retry"         , [string])-  ,("slave_expiration"    , [string])-  ,("min_ttl"             , [string])-  ,("email"               , [string])+  [ ("name", [nameval]),+    ("owner", [string]),+    ("dest", [string]),+    ("ensure", [defaultvalue "present", string, values ["present", "absent"]]),+    ("rtype", [string, defaultvalue "A", values ["SOA", "A", "AAAA", "MX", "NS", "CNAME", "PTR", "SRV"]]),+    ("rclass", [defaultvalue "IN", string]),+    ("ttl", [defaultvalue "2d", string]),+    ("target", [string, mandatory]),+    ("nsname", [string]),+    ("serial", [string]),+    ("slave_refresh", [string]),+    ("slave_retry", [string]),+    ("slave_expiration", [string]),+    ("min_ttl", [string]),+    ("email", [string])   ]  validateMandatories :: NativeTypeValidate
src/Puppet/Language/Paths.hs view
@@ -1,14 +1,20 @@ {-# LANGUAGE TemplateHaskell #-}+ module Puppet.Language.Paths where -import           XPrelude+import XPrelude  data PuppetDirPaths = PuppetDirPaths-  { _baseDir       :: FilePath -- ^ Puppet base working directory-  , _manifestPath  :: FilePath -- ^ The path to the manifests.-  , _modulesPath   :: FilePath -- ^ The path to the modules.-  , _templatesPath :: FilePath -- ^ The path to the template.-  , _testPath      :: FilePath -- ^ The path to a tests folders to hold tests files such as the pdbfiles.+  { -- | Puppet base working directory+    _baseDir :: FilePath,+    -- | The path to the manifests.+    _manifestPath :: FilePath,+    -- | The path to the modules.+    _modulesPath :: FilePath,+    -- | The path to the template.+    _templatesPath :: FilePath,+    -- | The path to a tests folders to hold tests files such as the pdbfiles.+    _testPath :: FilePath   }  makeClassy ''PuppetDirPaths
src/Puppet/Language/Resource.hs view
@@ -1,60 +1,70 @@-{-# LANGUAGE DeriveGeneric   #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-}  module Puppet.Language.Resource-  ( Resource(..)-  , HasResource(..)-  , RIdentifier(..)-  , HasRIdentifier(..)-  , LinkInformation(..)-  , HasLinkInformation(..)-  , LinkType(..)-  , Virtuality(..)-  , CurContainerDesc(..)-  , FinalCatalog-  , EdgeMap-  ) where--import           XPrelude--import           Data.Aeson-import qualified Data.HashMap.Strict   as Map-import qualified Data.HashSet          as Set-import qualified Data.Text             as Text-import qualified Data.Vector           as Vector-import qualified GHC.Exts              as Exts-import qualified Text.Megaparsec.Pos   as Pos--import           Puppet.Language.Core-import           Puppet.Language.Value+  ( Resource (..),+    HasResource (..),+    RIdentifier (..),+    HasRIdentifier (..),+    LinkInformation (..),+    HasLinkInformation (..),+    LinkType (..),+    Virtuality (..),+    CurContainerDesc (..),+    FinalCatalog,+    EdgeMap,+  )+where +import Data.Aeson+import qualified Data.Aeson.KeyMap as KM+import qualified Data.HashMap.Strict as Map+import qualified Data.HashSet as Set+import qualified Data.Text as Text+import qualified Data.Vector as Vector+import qualified GHC.Exts as Exts+import Puppet.Language.Core+import Puppet.Language.Value+import qualified Text.Megaparsec.Pos as Pos+import XPrelude  rel2text :: LinkType -> Text-rel2text RNotify    = "notify"-rel2text RRequire   = "require"-rel2text RBefore    = "before"+rel2text RNotify = "notify"+rel2text RRequire = "require"+rel2text RBefore = "before" rel2text RSubscribe = "subscribe"  data Virtuality-  = Normal -- ^ Normal resource, that will be included in the catalog.-  | Virtual -- ^ Type for virtual resources.-  | Exported -- ^ Type for exported resources.-  | ExportedRealized -- ^ These are resources that are exported AND realized in the catalog.+  = -- | Normal resource, that will be included in the catalog.+    Normal+  | -- | Type for virtual resources.+    Virtual+  | -- | Type for exported resources.+    Exported+  | -- | These are resources that are exported AND realized in the catalog.+    ExportedRealized   deriving (Eq, Show)  data CurContainerDesc-  = ContRoot -- ^ Contained at node or root level.-  | ContClass !Text -- ^ Contained in a class.-  | ContDefine !Text-               !Text-               !PPosition -- ^ Contained in a define, along with the position where this define was ... defined-  | ContImported !CurContainerDesc -- ^ Dummy container for imported resources, so that we know we must update the nodename-  | ContImport !NodeName-               !CurContainerDesc -- ^ This one is used when finalizing imported resources, and contains the current node name+  = -- | Contained at node or root level.+    ContRoot+  | -- | Contained in a class.+    ContClass !Text+  | -- | Contained in a define, along with the position where this define was ... defined+    ContDefine+      !Text+      !Text+      !PPosition+  | -- | Dummy container for imported resources, so that we know we must update the nodename+    ContImported !CurContainerDesc+  | -- | This one is used when finalizing imported resources, and contains the current node name+    ContImport+      !NodeName+      !CurContainerDesc   deriving (Eq, Generic, Ord, Show)  instance Pretty CurContainerDesc where-  pretty (ContImport  p x) = magenta "import" <> braces (ppline p) <> braces (pretty x)+  pretty (ContImport p x) = magenta "import" <> braces (ppline p) <> braces (pretty x)   pretty (ContImported x) = magenta "imported" <> braces (pretty x)   pretty ContRoot = dullyellow "::"   pretty (ContClass cname) = dullyellow "class" <+> dullgreen (ppline cname)@@ -62,35 +72,40 @@  -- | Relationship/ordering between resources. data LinkType-  = RRequire -- ^ Applies a resource after the target resource.-  | RBefore -- ^ Applies a resource before the target resource.-  | RNotify -- ^ Applies a resource before the target resource. The target resource refreshes if the notifying resource changes.-  | RSubscribe -- ^ Applies a resource after the target resource. The subscribing resource refreshes if the target resource changes.+  = -- | Applies a resource after the target resource.+    RRequire+  | -- | Applies a resource before the target resource.+    RBefore+  | -- | Applies a resource before the target resource. The target resource refreshes if the notifying resource changes.+    RNotify+  | -- | Applies a resource after the target resource. The subscribing resource refreshes if the target resource changes.+    RSubscribe   deriving (Show, Eq, Generic)  instance Hashable LinkType  instance FromJSON LinkType where-  parseJSON (String "require")   = return RRequire-  parseJSON (String "notify")    = return RNotify+  parseJSON (String "require") = return RRequire+  parseJSON (String "notify") = return RNotify   parseJSON (String "subscribe") = return RSubscribe-  parseJSON (String "before")    = return RBefore-  parseJSON _                    = panic "invalid linktype"+  parseJSON (String "before") = return RBefore+  parseJSON _ = panic "invalid linktype"  instance ToJSON LinkType where-    toJSON = String . rel2text+  toJSON = String . rel2text  instance Pretty LinkType where-  pretty RNotify    = "~>"-  pretty RRequire   = "<-"-  pretty RBefore    = "->"+  pretty RNotify = "~>"+  pretty RRequire = "<-"+  pretty RBefore = "->"   pretty RSubscribe = "<~"  -- | In Puppet, a resource is identified by a name and a type. data RIdentifier = RIdentifier-  { _itype :: !Text-  , _iname :: !Text-  } deriving (Show, Eq, Generic, Ord)+  { _itype :: !Text,+    _iname :: !Text+  }+  deriving (Show, Eq, Generic, Ord)  instance Pretty RIdentifier where   pretty (RIdentifier t n) = pretty (PResourceReference t n)@@ -106,16 +121,26 @@  -- | A fully resolved puppet resource that will be used in the 'FinalCatalog'. data Resource = Resource-  { _rid :: !RIdentifier -- ^ Resource name.-  , _ralias :: !(HashSet Text) -- ^ All the resource aliases-  , _rattributes :: !(Container PValue) -- ^ Resource parameters.-  , _rrelations :: !(HashMap RIdentifier (HashSet LinkType)) -- ^ Resource relations.-  , _rscope :: ![CurContainerDesc] -- ^ Resource scope when it was defined, the real container will be the first item-  , _rvirtuality :: !Virtuality -- ^ Virtuality.-  , _rtags :: !(HashSet Text) -- ^ Tags.-  , _rpos :: !PPosition -- ^ Source code position of the resource definition.-  , _rnode :: !NodeName -- ^ The node were this resource was created, if remote-  } deriving (Eq, Show)+  { -- | Resource name.+    _rid :: !RIdentifier,+    -- | All the resource aliases+    _ralias :: !(HashSet Text),+    -- | Resource parameters.+    _rattributes :: !(Container PValue),+    -- | Resource relations.+    _rrelations :: !(HashMap RIdentifier (HashSet LinkType)),+    -- | Resource scope when it was defined, the real container will be the first item+    _rscope :: ![CurContainerDesc],+    -- | Virtuality.+    _rvirtuality :: !Virtuality,+    -- | Tags.+    _rtags :: !(HashSet Text),+    -- | Source code position of the resource definition.+    _rpos :: !PPosition,+    -- | The node were this resource was created, if remote+    _rnode :: !NodeName+  }+  deriving (Eq, Show)  makeClassy ''Resource makeClassy ''RIdentifier@@ -129,111 +154,117 @@ meta r = showPPos (r ^. rpos) <+> red node <+> green (brackets scp)   where     node = ppline (r ^. rnode)-    scp = "Scope" <+> pretty (r ^.. rscope . folded . filtered (/=ContRoot) . to pretty)+    scp = "Scope" <+> pretty (r ^.. rscope . folded . filtered (/= ContRoot) . to pretty)  resourceBody :: Resource -> Doc resourceBody r =   virtuality <> blue (ppline (r ^. rid . iname)) <> ":" <+> meta r <> line <> containerComma'' insde <> ";"-    where-      virtuality = case r ^. rvirtuality of-        Normal           -> mempty-        Virtual          -> dullred "@"-        Exported         -> dullred "@@"-        ExportedRealized -> dullred "<@@>"-      insde = alignlst dullblue attriblist1 ++ alignlst dullmagenta attriblist2-      alignlst col = map (first (fill maxalign . col . ppline))-      attriblist1 = Exts.sortWith fst $ Map.toList (r ^. rattributes) ++ aliasdiff-      aliasWithoutTitle = r ^. ralias & contains (r ^. rid . iname) .~ False-      aliasPValue = aliasWithoutTitle & PArray . Vector.fromList . map PString . Set.toList-      aliasdiff | Set.null aliasWithoutTitle = []-                | otherwise = [("alias", aliasPValue)]-      attriblist2 = map totext (resourceRelations r)-      totext (RIdentifier t n, lt) = (rel2text lt , PResourceReference t n)-      maxalign = max (maxalign' attriblist1) (maxalign' attriblist2)-      maxalign' [] = 0-      maxalign' x  = maximum . map (Text.length . fst) $ x+  where+    virtuality = case r ^. rvirtuality of+      Normal -> mempty+      Virtual -> dullred "@"+      Exported -> dullred "@@"+      ExportedRealized -> dullred "<@@>"+    insde = alignlst dullblue attriblist1 ++ alignlst dullmagenta attriblist2+    alignlst col = map (first (fill maxalign . col . ppline))+    attriblist1 = Exts.sortWith fst $ Map.toList (r ^. rattributes) ++ aliasdiff+    aliasWithoutTitle = r ^. ralias & contains (r ^. rid . iname) .~ False+    aliasPValue = aliasWithoutTitle & PArray . Vector.fromList . map PString . Set.toList+    aliasdiff+      | Set.null aliasWithoutTitle = []+      | otherwise = [("alias", aliasPValue)]+    attriblist2 = map totext (resourceRelations r)+    totext (RIdentifier t n, lt) = (rel2text lt, PResourceReference t n)+    maxalign = max (maxalign' attriblist1) (maxalign' attriblist2)+    maxalign' [] = 0+    maxalign' x = maximum . map (Text.length . fst) $ x  instance Pretty Resource where   prettyList lst =-     let grouped = Map.toList $ Map.fromListWith (++) [ (r ^. rid . itype, [r]) | r <- lst ] :: [ (Text, [Resource]) ]-         sorted = Exts.sortWith fst (map (second (Exts.sortWith (view (rid.iname)))) grouped)-         showGroup :: (Text, [Resource]) -> Doc-         showGroup (rt, res) = dullyellow (ppline rt) <+> lbrace <> line <> indent 2 (vcat (map resourceBody res)) <> line <> rbrace-     in  vcat (map showGroup sorted)+    let grouped = Map.toList $ Map.fromListWith (++) [(r ^. rid . itype, [r]) | r <- lst] :: [(Text, [Resource])]+        sorted = Exts.sortWith fst (map (second (Exts.sortWith (view (rid . iname)))) grouped)+        showGroup :: (Text, [Resource]) -> Doc+        showGroup (rt, res) = dullyellow (ppline rt) <+> lbrace <> line <> indent 2 (vcat (map resourceBody res)) <> line <> rbrace+     in vcat (map showGroup sorted)   pretty r = dullyellow (ppline (r ^. rid . itype)) <+> lbrace <> line <> indent 2 (resourceBody r) <> line <> rbrace - instance ToJSON Resource where   toJSON r =-    object [ ("type", String $ r ^. rid . itype)-           , ("title", String $ r ^. rid . iname)-           , ("aliases", toJSON $ r ^. ralias)-           , ("exported", Bool $ r ^. rvirtuality == Exported)-           , ("tags", toJSON $ r ^. rtags)-           , ("parameters", Object ( fmap toJSON (r ^. rattributes) `Map.union` relations ))-           , ("sourceline", r ^. rpos . _1 . _sourceLine . to (toJSON . Pos.unPos))-           , ("sourcefile", r ^. rpos . _1 . _sourceName . to toJSON)-           ]+    object+      [ ("type", String $ r ^. rid . itype),+        ("title", String $ r ^. rid . iname),+        ("aliases", toJSON $ r ^. ralias),+        ("exported", Bool $ r ^. rvirtuality == Exported),+        ("tags", toJSON $ r ^. rtags),+        ("parameters", Object $ KM.fromHashMapText (fmap toJSON (r ^. rattributes) `Map.union` relations)),+        ("sourceline", r ^. rpos . _1 . _sourceLine . to (toJSON . Pos.unPos)),+        ("sourcefile", r ^. rpos . _1 . _sourceName . to toJSON)+      ]     where       relations = r ^. rrelations & Map.fromListWith (Vector.++) . concatMap changeRelations . Map.toList & fmap toValue-      toValue v | Vector.length v == 1 = Vector.head v-                | otherwise = Array v+      toValue v+        | Vector.length v == 1 = Vector.head v+        | otherwise = Array v       changeRelations :: (RIdentifier, HashSet LinkType) -> [(Text, Vector Value)]-      changeRelations (k,v) = do-          c <- Set.toList v-          return (rel2text c, Vector.singleton (String (rid2text k)))+      changeRelations (k, v) = do+        c <- Set.toList v+        return (rel2text c, Vector.singleton (String (rid2text k)))       rid2text :: RIdentifier -> Text       rid2text (RIdentifier t n) = capitalizeRT t `Text.append` "[" `Text.append` capn `Text.append` "]"         where-          capn = if t == "classe"-                   then capitalizeRT n-                   else n+          capn =+            if t == "classe"+              then capitalizeRT n+              else n  instance FromJSON Resource where   parseJSON (Object v) = do     isExported <- v .: "exported"-    let virtuality = if isExported-                         then Exported-                         else Normal+    let virtuality =+          if isExported+            then Exported+            else Normal         getResourceIdentifier :: PValue -> Maybe RIdentifier         getResourceIdentifier (PString x) =-            let (restype, brckts) = Text.breakOn "[" x-                rna | Text.null brckts        = Nothing-                    | Text.null restype       = Nothing-                    | Text.last brckts == ']' = Just (Text.tail (Text.init brckts))-                    | otherwise            = Nothing-            in case rna of-                 Just resname -> Just (RIdentifier (Text.toLower restype) (Text.toLower resname))-                 _ -> Nothing+          let (restype, brckts) = Text.breakOn "[" x+              rna+                | Text.null brckts = Nothing+                | Text.null restype = Nothing+                | Text.last brckts == ']' = Just (Text.tail (Text.init brckts))+                | otherwise = Nothing+           in case rna of+                Just resname -> Just (RIdentifier (Text.toLower restype) (Text.toLower resname))+                _ -> Nothing         getResourceIdentifier _ = Nothing         -- TODO : properly handle metaparameters         separate :: (Container PValue, HashMap RIdentifier (HashSet LinkType)) -> Text -> PValue -> (Container PValue, HashMap RIdentifier (HashSet LinkType))         separate (curAttribs, curRelations) k val = case (fromJSON (String k), getResourceIdentifier val) of           (Success rel, Just ri) -> (curAttribs, curRelations & at ri . non mempty . contains rel .~ True)-          _                      -> (curAttribs & at k ?~ val, curRelations)-    (attribs,relations) <- Map.foldlWithKey' separate (mempty,mempty) <$> v .: "parameters"+          _ -> (curAttribs & at k ?~ val, curRelations)+    (attribs, relations) <- Map.foldlWithKey' separate (mempty, mempty) <$> v .: "parameters"     contimport <- v .:? "certname" .!= "unknown"-    Resource <$> (RIdentifier <$> fmap Text.toLower (v .: "type") <*> v .: "title")-             <*> v .:? "aliases" .!= mempty-             <*> pure attribs-             <*> pure relations-             <*> pure [ContImport contimport ContRoot]-             <*> pure virtuality-             <*> v .: "tags"-             <*> (toPPos <$> v .:? "sourcefile" .!= "null" <*> v .:? "sourceline" .!= 1)-             <*> pure contimport-+    Resource+      <$> (RIdentifier <$> fmap Text.toLower (v .: "type") <*> v .: "title")+      <*> v .:? "aliases" .!= mempty+      <*> pure attribs+      <*> pure relations+      <*> pure [ContImport contimport ContRoot]+      <*> pure virtuality+      <*> v .: "tags"+      <*> (toPPos <$> v .:? "sourcefile" .!= "null" <*> v .:? "sourceline" .!= 1)+      <*> pure contimport   parseJSON _ = mempty  type FinalCatalog = HashMap RIdentifier Resource  -- | Relationship/ordering information between two resources (used in the 'EdgeMap'). data LinkInformation = LinkInformation-  { _linksrc :: !RIdentifier-  , _linkdst :: !RIdentifier-  , _linkType :: !LinkType-  , _linkPos :: !PPosition-  } deriving (Show)+  { _linksrc :: !RIdentifier,+    _linkdst :: !RIdentifier,+    _linkType :: !LinkType,+    _linkPos :: !PPosition+  }+  deriving (Show)  makeClassy ''LinkInformation
src/Puppet/Language/Value.hs view
@@ -1,65 +1,67 @@-{-# LANGUAGE TemplateHaskell   #-}-module Puppet.Language.Value--where--import           XPrelude+{-# LANGUAGE TemplateHaskell #-} -import           Data.Aeson-import           Data.Aeson.TH-import qualified Data.HashMap.Strict as HM-import           Data.Scientific (isInteger)-import           Foreign.Ruby.Helpers+module Puppet.Language.Value where -import           Puppet.Language.Core+import Data.Aeson+import qualified Data.Aeson.KeyMap as KM+import Data.Aeson.TH+import Data.Scientific (isInteger)+import Foreign.Ruby.Helpers+import Puppet.Language.Core+import XPrelude  data DataType-    = DTType-    | DTString (Maybe Int) (Maybe Int)-    | DTInteger (Maybe Int) (Maybe Int)-    | DTFloat (Maybe Double) (Maybe Double)-    | DTBoolean-    | DTArray DataType Int (Maybe Int)-    | DTHash DataType DataType Int (Maybe Int)-    | DTUndef-    | DTScalar-    | DTData-    | DTOptional DataType-    | NotUndef-    | DTVariant (NonEmpty DataType)-    | DTPattern (NonEmpty CompRegex)-    | DTEnum (NonEmpty Text)-    | DTAny-    | DTCollection-    | DTRegexp (Maybe CompRegex)-    deriving (Show, Eq)+  = DTType+  | DTString (Maybe Int) (Maybe Int)+  | DTInteger (Maybe Int) (Maybe Int)+  | DTFloat (Maybe Double) (Maybe Double)+  | DTBoolean+  | DTArray DataType Int (Maybe Int)+  | DTHash DataType DataType Int (Maybe Int)+  | DTUndef+  | DTScalar+  | DTData+  | DTOptional DataType+  | NotUndef+  | DTVariant (NonEmpty DataType)+  | DTPattern (NonEmpty CompRegex)+  | DTEnum (NonEmpty Text)+  | DTAny+  | DTCollection+  | DTRegexp (Maybe CompRegex)+  | DTDeferred+  | DTSensitive DataType+  deriving (Show, Eq)  instance Pretty DataType where   pretty t = case t of-    DTType              -> "Type"-    DTString ma mb      -> bounded "String" ma mb-    DTInteger ma mb     -> bounded "Integer" ma mb-    DTFloat ma mb       -> bounded "Float" ma mb-    DTBoolean           -> "Boolean"-    DTArray dt mi mmx   -> "Array" <> list (pretty dt : pretty mi : maybe [] (pure . pretty) mmx)+    DTType -> "Type"+    DTString ma mb -> bounded "String" ma mb+    DTInteger ma mb -> bounded "Integer" ma mb+    DTFloat ma mb -> bounded "Float" ma mb+    DTBoolean -> "Boolean"+    DTArray dt mi mmx -> "Array" <> list (pretty dt : pretty mi : maybe [] (pure . pretty) mmx)     DTHash kt dt mi mmx -> "Hash" <> list (pretty kt : pretty dt : pretty mi : maybe [] (pure . pretty) mmx)-    DTUndef             -> "Undef"-    DTScalar            -> "Scalar"-    DTData              -> "Data"-    DTOptional o        -> "Optional" <> brackets (pretty o)-    NotUndef            -> "NotUndef"-    DTVariant vs        -> "Variant" <> list (foldMap (pure . pretty) vs)-    DTPattern vs        -> "Pattern" <> list (foldMap (pure . pretty) vs)-    DTEnum tx           -> "Enum" <> list (foldMap (pure . ppline) tx)-    DTAny               -> "Any"-    DTCollection        -> "Collection"-    DTRegexp mr         -> "Regex" <> foldMap (brackets . pretty) mr+    DTUndef -> "Undef"+    DTScalar -> "Scalar"+    DTData -> "Data"+    DTOptional o -> "Optional" <> brackets (pretty o)+    NotUndef -> "NotUndef"+    DTVariant vs -> "Variant" <> list (foldMap (pure . pretty) vs)+    DTPattern vs -> "Pattern" <> list (foldMap (pure . pretty) vs)+    DTEnum tx -> "Enum" <> list (foldMap (pure . ppline) tx)+    DTAny -> "Any"+    DTCollection -> "Collection"+    DTRegexp mr -> "Regex" <> foldMap (brackets . pretty) mr+    DTDeferred -> "Deferred"+    DTSensitive o -> "Sensitive" <> brackets (pretty o)     where       bounded :: (Pretty a, Pretty b) => Doc -> Maybe a -> Maybe b -> Doc-      bounded s ma mb = s <> case (ma, mb) of-        (Just a, Nothing) -> list [pretty a]-        (Just a, Just b)  -> list [pretty a, pretty b]-        _                 -> mempty+      bounded s ma mb =+        s <> case (ma, mb) of+          (Just a, Nothing) -> list [pretty a]+          (Just a, Just b) -> list [pretty a, pretty b]+          _ -> mempty  $(deriveJSON defaultOptions ''DataType) @@ -73,14 +75,15 @@   | PHash !(Container PValue)   | PNumber !Scientific   | PType !DataType-  | PRegexp !CompRegex+  | PRegexp !CompRegex+  | PSensitive !PValue   deriving (Eq, Show)  makePrisms ''PValue  instance Pretty PValue where-  pretty (PBoolean True) = dullmagenta $ "true"-  pretty (PBoolean False) = dullmagenta $ "false"+  pretty (PBoolean True) = dullmagenta "true"+  pretty (PBoolean False) = dullmagenta "false"   pretty (PString s) = dullcyan (ppline (stringEscape s))   pretty (PNumber n) = cyan (ppline (scientific2text n))   pretty PUndef = dullmagenta "undef"@@ -89,6 +92,7 @@   pretty (PHash g) = containerComma g   pretty (PType dt) = pretty dt   pretty (PRegexp cr) = pretty cr+  pretty (PSensitive _) = red "[SENSITIVE]"  instance IsString PValue where   fromString = PString . toS@@ -110,9 +114,9 @@  _ScientificInteger :: Prism' Scientific Integer _ScientificInteger = prism fromIntegral $ \n ->-    if isInteger n-      then Right (truncate n)-      else Left n+  if isInteger n+    then Right (truncate n)+    else Left n  _PValueInteger :: Prism' PValue Integer _PValueInteger = _PValueNumber . _ScientificInteger@@ -123,8 +127,8 @@   parseJSON (String s) = return (PString s)   parseJSON (Bool b) = return (PBoolean b)   parseJSON (Array v) = fmap PArray (mapM parseJSON v)-  parseJSON (Object o) | HM.size o == 1 && HM.keys o == ["regexp"] = o .: "regexp"-  parseJSON (Object o) = fmap PHash (mapM parseJSON o)+  parseJSON (Object o) | KM.size o == 1 && KM.keys o == ["regexp"] = o .: "regexp"+  parseJSON (Object o) = fmap (PHash . KM.toHashMapText) (traverse parseJSON o)  instance ToJSON PValue where   toJSON (PType t) = toJSON t@@ -133,16 +137,18 @@   toJSON (PString s) = String s   toJSON (PResourceReference _ _) = Null -- TODO   toJSON (PArray r) = Array (fmap toJSON r)-  toJSON (PHash x) = Object (fmap toJSON x)+  toJSON (PHash x) = Object (KM.fromHashMapText (fmap toJSON x))   toJSON (PNumber n) = Number n   toJSON (PRegexp r) = object [("regexp", toJSON r)]+  toJSON (PSensitive x) = toJSON x  instance ToRuby PValue where-    toRuby = toRuby . toJSON+  toRuby = toRuby . toJSON+ instance FromRuby PValue where   fromRuby = fmap chk . fromRuby     where       chk (Left x) = Left x       chk (Right x) = case fromJSON x of-        Error rr    -> Left rr+        Error rr -> Left rr         Success suc -> Right suc
src/Puppet/Language/WireCatalog.hs view
@@ -1,54 +1,56 @@ {-# LANGUAGE TemplateHaskell #-}-module Puppet.Language.WireCatalog -where--import           XPrelude--import           Data.Aeson+module Puppet.Language.WireCatalog where -import           Puppet.Language.Core-import           Puppet.Language.Resource+import Data.Aeson+import Puppet.Language.Core+import Puppet.Language.Resource+import XPrelude  -- | Used to represent a relationship between two resources within the wired format (json). -- -- See <http://docs.puppetlabs.com/puppetdb/2.3/api/wire_format/catalog_format_v5.html#data-type-edge>-data PuppetEdge = PuppetEdge RIdentifier RIdentifier LinkType deriving Show+data PuppetEdge = PuppetEdge RIdentifier RIdentifier LinkType deriving (Show)  instance FromJSON PuppetEdge where-    parseJSON (Object v) = PuppetEdge <$> v .: "source" <*> v .: "target" <*> v .: "relationship"-    parseJSON _ = fail "invalid puppet edge"+  parseJSON (Object v) = PuppetEdge <$> v .: "source" <*> v .: "target" <*> v .: "relationship"+  parseJSON _ = fail "invalid puppet edge"  instance ToJSON PuppetEdge where-    toJSON (PuppetEdge s t r) = object [("source", toJSON s), ("target", toJSON t), ("relationship", toJSON r)]+  toJSON (PuppetEdge s t r) = object [("source", toJSON s), ("target", toJSON t), ("relationship", toJSON r)]  -- | See <http://docs.puppetlabs.com/puppetdb/1.5/api/wire_format/catalog_format.html puppet reference>. data WireCatalog = WireCatalog-    { _wireCatalogNodename        :: !NodeName-    , _wireCatalogVersion         :: !Text-    , _wireCatalogEdges           :: !(Vector PuppetEdge)-    , _wireCatalogResources       :: !(Vector Resource)-    , _wireCatalogTransactionUUID :: !Text-} deriving Show+  { _wireCatalogNodename :: !NodeName,+    _wireCatalogVersion :: !Text,+    _wireCatalogEdges :: !(Vector PuppetEdge),+    _wireCatalogResources :: !(Vector Resource),+    _wireCatalogTransactionUUID :: !Text+  }+  deriving (Show)  makeClassy ''WireCatalog  instance FromJSON WireCatalog where-  parseJSON (Object d) = d .: "data" >>= \case-      (Object v) -> WireCatalog-              <$> v .: "name"-              <*> v .: "version"-              <*> v .: "edges"-              <*> v .: "resources"-              <*> v .: "transaction-uuid"+  parseJSON (Object d) =+    d .: "data" >>= \case+      (Object v) ->+        WireCatalog+          <$> v .: "name"+          <*> v .: "version"+          <*> v .: "edges"+          <*> v .: "resources"+          <*> v .: "transaction-uuid"       _ -> fail "Data is not an object"   parseJSON _ = fail "invalid wire catalog"  instance ToJSON WireCatalog where   toJSON (WireCatalog n v e r t) = object [("metadata", object [("api_version", Number 1)]), ("data", object d)]-    where d = [ ("name", String n)-              , ("version", String v)-              , ("edges", toJSON e)-              , ("resources", toJSON r)-              , ("transaction-uuid", String t)-              ]+    where+      d =+        [ ("name", String n),+          ("version", String v),+          ("edges", toJSON e),+          ("resources", toJSON r),+          ("transaction-uuid", String t)+        ]
src/Puppet/Parser.hs view
@@ -1,25 +1,25 @@-{-| Parse puppet source code from text. -}-module Puppet.Parser (-  -- * Runner-    runPuppetParser-  -- * Parsers-  , puppetParser-  , prettyParseError-  -- * Pretty Print-  , module Puppet.Parser.PrettyPrinter-  , module Puppet.Parser.Types-  , module Puppet.Parser.Lens-) where--import           XPrelude+-- | Parse puppet source code from text.+module Puppet.Parser+  ( -- * Runner+    runPuppetParser, -import           Text.Megaparsec+    -- * Parsers+    puppetParser,+    prettyParseError, -import           Puppet.Parser.PrettyPrinter-import           Puppet.Parser.Lens-import           Puppet.Parser.Internal-import           Puppet.Parser.Types+    -- * Pretty Print+    module Puppet.Parser.PrettyPrinter,+    module Puppet.Parser.Types,+    module Puppet.Parser.Lens,+  )+where +import Puppet.Parser.Internal+import Puppet.Parser.Lens+import Puppet.Parser.PrettyPrinter+import Puppet.Parser.Types+import Text.Megaparsec+import XPrelude  -- | Build a 'PrettyError' from a 'ParseError' given the text source. -- The source is used to display the line on which the error occurs.
src/Puppet/Parser/Internal.hs view
@@ -1,24 +1,25 @@ {-# LANGUAGE TupleSections #-}-module Puppet.Parser.Internal-where+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -import           XPrelude.Extra                   hiding (many, option, some, try)+{-# HLINT ignore "Use id" #-}+{-# HLINT ignore "Use <$>" #-}+module Puppet.Parser.Internal where -import           Control.Monad.Combinators.Expr-import qualified Data.Char                        as Char-import qualified Data.List                        as List-import qualified Data.List.NonEmpty               as NE-import qualified Data.Maybe.Strict                as S-import qualified Data.Scientific                  as Scientific-import qualified Data.Text                        as Text-import qualified Data.Vector                      as V-import           Text.Megaparsec-import           Text.Megaparsec.Char-import qualified Text.Megaparsec.Char.Lexer       as Lexer+import Control.Monad.Combinators.Expr+import qualified Data.Char as Char+import qualified Data.List as List+import qualified Data.List.NonEmpty as NE+import qualified Data.Maybe.Strict as S+import qualified Data.Scientific as Scientific+import qualified Data.Text as Text+import qualified Data.Vector as V+import Puppet.Language+import Puppet.Parser.Types+import Text.Megaparsec+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as Lexer import qualified Text.Regex.PCRE.ByteString.Utils as Regex--import           Puppet.Language-import           Puppet.Parser.Types+import XPrelude.Extra hiding (key, many, some, try)  -- | Space consumer sc :: Parser ()@@ -61,16 +62,18 @@   ms <- optional $ do     symbolic '?'     let case_expr = do-          c <-     SelectorDefault <$ symbol "default" -- default case-               <|> SelectorType <$> try datatype-               <|> fmap SelectorValue-                     (   UVariableReference <$> variableReference-                     <|> UBoolean <$> puppetBool-                     <|> UUndef <$ symbol "undef"-                     <|> literalValue-                     <|> UInterpolable <$> interpolableString-                     <|> URegexp <$> termRegexp-                     )+          c <-+            SelectorDefault <$ symbol "default" -- default case+              <|> SelectorType <$> try datatype+              <|> fmap+                SelectorValue+                ( UVariableReference <$> variableReference+                    <|> UBoolean <$> puppetBool+                    <|> UUndef <$ symbol "undef"+                    <|> literalValue+                    <|> UInterpolable <$> interpolableString+                    <|> URegexp <$> termRegexp+                )           symbol "=>"           e <- expression           pure (c :!: e)@@ -85,7 +88,7 @@   where     interior = Text.pack . concat <$> many (some (noneOf ['\'', '\\']) <|> (char '\\' *> fmap escape anySingle))     escape '\'' = "'"-    escape x    = ['\\',x]+    escape x = ['\\', x]  identifier :: Parser (Tokens Text) identifier = takeWhile1P Nothing isIdentifierChar@@ -111,7 +114,7 @@ qualif :: Parser Text -> Parser Text qualif p = do   header <- option "" (chunk "::")-  ( header <> ) . Text.intercalate "::" <$> p `sepBy1` chunk "::"+  (header <>) . Text.intercalate "::" <$> p `sepBy1` chunk "::"  qualif1 :: Parser Text -> Parser Text qualif1 p = do@@ -151,10 +154,11 @@ genericModuleName :: Bool -> Parser Text genericModuleName isReference = do   let acceptable x = Char.isAsciiLower x || Char.isDigit x || (x == '_')-      firstletter = if isReference-                      then fmap Char.toLower (satisfy Char.isAsciiUpper)-                      else satisfy Char.isAsciiLower-  (Text.cons) <$> firstletter <*> takeWhileP Nothing acceptable+      firstletter =+        if isReference+          then fmap Char.toLower (satisfy Char.isAsciiUpper)+          else satisfy Char.isAsciiLower+  Text.cons <$> firstletter <*> takeWhileP Nothing acceptable  -- | Variable expression varExpression :: Parser Expression@@ -162,28 +166,34 @@  -- | String interpolation interpolableString :: Parser (Vector Expression)-interpolableString = V.fromList <$> between (char '"') (symbolic '"')- ( many (interpolableVariableReference <|> doubleQuotedStringContent <|> fmap (Terminal . UString . Text.singleton) (char '$')) )+interpolableString =+  V.fromList+    <$> between+      (char '"')+      (symbolic '"')+      (many (interpolableVariableReference <|> doubleQuotedStringContent <|> fmap (Terminal . UString . Text.singleton) (char '$')))   where-    doubleQuotedStringContent = Terminal . UString . Text.pack . concat <$>-      some ((char '\\' *> fmap escaper anySingle) <|> some (noneOf [ '"', '\\', '$' ]))+    doubleQuotedStringContent =+      Terminal . UString . Text.pack . concat+        <$> some ((char '\\' *> fmap escaper anySingle) <|> some (noneOf ['"', '\\', '$']))     escaper :: Char -> String-    escaper 'n'  = "\n"-    escaper 't'  = "\t"-    escaper 'r'  = "\r"-    escaper '"'  = "\""+    escaper 'n' = "\n"+    escaper 't' = "\t"+    escaper 'r' = "\r"+    escaper '"' = "\""     escaper '\\' = "\\"-    escaper '$'  = "$"-    escaper x    = ['\\',x]+    escaper '$' = "$"+    escaper x = ['\\', x]     -- this is specialized because we can't be "tokenized" here     varname = Text.concat <$> some (chunk "::" <|> identifier)     varexpr = Terminal . UVariableReference <$> varname-    indexchain =  makeExprParser varexpr [[Postfix indexLookupChain]] -- e.g: os['release']['major']+    indexchain = makeExprParser varexpr [[Postfix indexLookupChain]] -- e.g: os['release']['major']     interpolableVariableReference = do       void (char '$')-      let fenced =    try (indexchain <* char '}')-                  <|> try (varexpr <* char '}')-                  <|> (expression <* char '}')+      let fenced =+            try (indexchain <* char '}')+              <|> try (varexpr <* char '}')+              <|> (expression <* char '}')       (symbolic '{' *> fenced) <|> try varexpr <|> pure (Terminal (UString (Text.singleton '$')))  integerOrDouble :: Parser (Either Integer Double)@@ -201,9 +211,9 @@  puppetBool :: Parser Bool puppetBool =-      (reserved "true" >> pure True)-  <|> (reserved "false" >> pure False)-  <?> "Boolean"+  (reserved "true" >> pure True)+    <|> (reserved "false" >> pure False)+    <?> "Boolean"  resourceReferenceRaw :: Parser (Text, [Expression]) resourceReferenceRaw = do@@ -215,41 +225,43 @@ resourceReference = do   (restype, resnames) <- resourceReferenceRaw   pure $ UResourceReference restype $ case resnames of-           [x] -> x-           _   -> Terminal $ UArray (V.fromList resnames)+    [x] -> x+    _ -> Terminal $ UArray (V.fromList resnames)  -- | Functions that have named that are not valid ... specialFunctions :: Parser Text specialFunctions =-      chunk "Integer"-  <|> chunk "Numeric"+  chunk "Integer"+    <|> chunk "Numeric"+    <|> chunk "Sensitive"  -- The first argument defines if non-parenthesized arguments are acceptable genFunctionCall :: Bool -> Parser (Text, Vector Expression) genFunctionCall nonparens = do   fname <- (specialFunctions <|> funcName) <?> "Function name"-  let-      -- first check if the function arg is not a qualified name (ex.: include foo::bar)+  let -- first check if the function arg is not a qualified name (ex.: include foo::bar)       -- if it is not, then we expect an expression-      qualif_param = (Terminal . UString) <$> qualif1 moduleName <* notFollowedBy (single '(') -- <* lookAhead (anySingleBut '(')-      func_arg expr =  try qualif_param <|> expr <?> "Function argument"+      qualif_param = Terminal . UString <$> qualif1 moduleName <* notFollowedBy (single '(') -- <* lookAhead (anySingleBut '(')+      func_arg expr = try qualif_param <|> expr <?> "Function argument"       terminalF = terminalG FunctionWithoutParens       expressionF = makeExprParser (lexeme terminalF) expressionTable <?> "Function expression"       withparens = parens (func_arg expression `sepEndBy` comma)-      withoutparens = if nonparens-                      then func_arg expressionF `sepEndBy1` comma-                      else fail "Not an argument list allowed with function without parentheses"-  args  <- withparens <|> withoutparens+      withoutparens =+        if nonparens+          then func_arg expressionF `sepEndBy1` comma+          else fail "Not an argument list allowed with function without parentheses"+  args <- withparens <|> withoutparens   pure (fname, V.fromList args)  literalValue :: Parser UnresolvedValue literalValue = lexeme (fmap UString stringLiteral' <|> fmap UString bareword <|> fmap UNumber numericalvalue <?> "Literal Value")   where-    signed :: Num n => Parser (n -> n)+    signed :: (Num n) => Parser (n -> n)     signed = (negate <$ char '-') <|> pure (\x -> x)-    numericalvalue = ((,) <$> signed <*> integerOrDouble) >>= \case-      (s, Left x)  -> pure (s (fromIntegral x))-      (s, Right y) -> pure (s (Scientific.fromFloatDigits y))+    numericalvalue =+      ((,) <$> signed <*> integerOrDouble) >>= \case+        (s, Left x) -> pure (s (fromIntegral x))+        (s, Right y) -> pure (s (Scientific.fromFloatDigits y))  data TerminalMode   = FunctionWithoutParens@@ -258,30 +270,32 @@ -- this is a hack for functions :( terminalG :: TerminalMode -> Parser Expression terminalG mode =-      parens expression-  <|> fmap (Terminal . UInterpolable) interpolableString-  <|> (Terminal UUndef <$ reserved "undef")-  <|> fmap (Terminal . URegexp) termRegexp-  <|> varExpression-  <|> fmap Terminal puppetArray-  <|> fmap Terminal puppetHash-  <|> fmap (Terminal . UBoolean) puppetBool-  <|> case mode of-        FunctionWithoutParens -> remaining-        StandardMode          -> lambda <|> remaining- where-   lambda = fmap Terminal (fmap UHOLambdaCall (try lambdaCall) <|> try funcCall)-   remaining = fmap (Terminal . UDataType) datatype-           <|> fmap Terminal resourceReference-           <|> fmap Terminal literalValue-   funcCall :: Parser UnresolvedValue-   funcCall = uncurry UFunctionCall <$> genFunctionCall False+  parens expression+    <|> fmap (Terminal . UInterpolable) interpolableString+    <|> (Terminal UUndef <$ reserved "undef")+    <|> fmap (Terminal . URegexp) termRegexp+    <|> varExpression+    <|> fmap Terminal puppetArray+    <|> fmap Terminal puppetHash+    <|> fmap (Terminal . UBoolean) puppetBool+    <|> case mode of+      FunctionWithoutParens -> remaining+      StandardMode -> lambda <|> remaining+  where+    lambda = fmap Terminal (fmap UHOLambdaCall (try lambdaCall) <|> try funcCall)+    remaining =+      fmap (Terminal . UDataType) datatype+        <|> fmap Terminal resourceReference+        <|> fmap Terminal literalValue+    funcCall :: Parser UnresolvedValue+    funcCall = uncurry UFunctionCall <$> genFunctionCall False  regexp :: Parser Text regexp = do   void (single '/')-  Text.pack . concat <$> many ( do { void (char '\\') ; x <- anySingle; return ['\\', x] } <|> some (noneOf [ '/', '\\' ]) )-      <* symbolic '/'+  Text.pack . concat+    <$> many (do { void (char '\\'); x <- anySingle; return ['\\', x] } <|> some (noneOf ['/', '\\']))+    <* symbolic '/'  compileRegexp :: Text -> Parser CompRegex compileRegexp p = case Regex.compile' Regex.compBlank Regex.execBlank (encodeUtf8 p) of@@ -295,35 +309,36 @@ terminal = terminalG StandardMode  expressionTable :: [[Operator Parser Expression]]-expressionTable = [ [ Postfix indexLookupChain ] -- http://stackoverflow.com/questions/10475337/parsec-expr-repeated-prefix-postfix-operator-not-supported-                  , [ Prefix ( symbolic '-'   *> pure Negate           ) ]-                  , [ Prefix ( symbolic '!'   *> pure Not              ) ]-                  , [ InfixL ( symbolic '.'   *> pure FunctionApplication ) ]-                  , [ InfixL ( reserved "in"  *> pure Contains         ) ]-                  , [ InfixL ( symbolic '/'   *> pure Division         )-                    , InfixL ( symbolic '*'   *> pure Multiplication   )-                    ]-                  , [ InfixL ( symbolic '+'   *> pure Addition     )-                    , InfixL ( symbolic '-'   *> pure Substraction )-                    ]-                  , [ InfixL ( symbol "<<"    *> pure LeftShift  )-                    , InfixL ( symbol ">>"    *> pure RightShift )-                    ]-                  , [ InfixL ( symbol "=="    *> pure Equal     )-                    , InfixL ( symbol "!="    *> pure Different )-                    ]-                  , [ InfixL ( symbol "=~"    *> pure RegexMatch    )-                    , InfixL ( symbol "!~"    *> pure NotRegexMatch )-                    ]-                  , [ InfixL ( symbol ">="    *> pure MoreEqualThan )-                    , InfixL ( symbol "<="    *> pure LessEqualThan )-                    , InfixL ( symbol ">"     *> pure MoreThan      )-                    , InfixL ( symbol "<"     *> pure LessThan      )-                    ]-                  , [ InfixL ( reserved "and" *> pure And )-                    , InfixL ( reserved "or"  *> pure Or  )-                    ]-                  ]+expressionTable =+  [ [Postfix indexLookupChain], -- http://stackoverflow.com/questions/10475337/parsec-expr-repeated-prefix-postfix-operator-not-supported+    [Prefix (symbolic '-' $> Negate)],+    [Prefix (symbolic '!' $> Not)],+    [InfixL (symbolic '.' $> FunctionApplication)],+    [InfixL (reserved "in" $> Contains)],+    [ InfixL (symbolic '/' $> Division),+      InfixL (symbolic '*' $> Multiplication)+    ],+    [ InfixL (symbolic '+' $> Addition),+      InfixL (symbolic '-' $> Substraction)+    ],+    [ InfixL (symbol "<<" $> LeftShift),+      InfixL (symbol ">>" $> RightShift)+    ],+    [ InfixL (symbol "==" $> Equal),+      InfixL (symbol "!=" $> Different)+    ],+    [ InfixL (symbol "=~" $> RegexMatch),+      InfixL (symbol "!~" $> NotRegexMatch)+    ],+    [ InfixL (symbol ">=" $> MoreEqualThan),+      InfixL (symbol "<=" $> LessEqualThan),+      InfixL (symbol ">" $> MoreThan),+      InfixL (symbol "<" $> LessThan)+    ],+    [ InfixL (reserved "and" $> And),+      InfixL (reserved "or" $> Or)+    ]+  ]  -- | Postfix of a chain of lookup indexes such as "['release']['major']" indexLookupChain :: Parser (Expression -> Expression)@@ -333,18 +348,18 @@  stringExpression :: Parser Expression stringExpression =-      (Terminal . UInterpolable) <$> interpolableString-  <|> (reserved "undef" $> Terminal UUndef)-  <|> (Terminal . UBoolean) <$> puppetBool-  <|> varExpression-  <|> Terminal <$> literalValue+  Terminal . UInterpolable <$> interpolableString+    <|> (reserved "undef" $> Terminal UUndef)+    <|> Terminal . UBoolean <$> puppetBool+    <|> varExpression+    <|> Terminal <$> literalValue  -- | a = b = 0 chainedVariableReferences :: Parser [Text] chainedVariableReferences = do   h <- variableReference   t <- many (try next)-  pure (h:t)+  pure (h : t)   where     next = symbolic '=' *> variableReference <* lookAhead (single '=' *> space1) @@ -364,7 +379,7 @@   reserved "node"   let toString (UString s) = s       toString (UNumber n) = scientific2text n-      toString _           = panic "Can't happen at nodeDecl"+      toString _ = panic "Can't happen at nodeDecl"       nodename = (reserved "default" >> pure NodeDefault) <|> fmap (NodeName . toString) literalValue   ns <- (fmap NodeMatch termRegexp <|> nodename) `sepBy1` comma   inheritance <- option S.Nothing (fmap S.Just (reserved "inherits" *> nodename))@@ -387,13 +402,13 @@ puppetClassParameters = V.fromList <$> parens (sepComma var)   where     toStrictMaybe (Just x) = S.Just x-    toStrictMaybe Nothing  = S.Nothing+    toStrictMaybe Nothing = S.Nothing     var :: Parser (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression))     var = do       tp <- toStrictMaybe <$> optional datatype-      n  <- variableReference+      n <- variableReference       df <- toStrictMaybe <$> optional (symbolic '=' *> expression)-      pure (n :!: tp :!: df)+      pure ((n :!: tp) :!: df)  puppetIfStyleCondition :: Parser (Pair Expression (Vector Statement)) puppetIfStyleCondition = (:!:) <$> expression <*> braces statementList@@ -404,22 +419,18 @@   reserved "unless"   (cond :!: stmts) <- puppetIfStyleCondition   elsecond <- option V.empty (reserved "else" *> braces statementList)-  let ec = if V.null elsecond-               then []-               else [Terminal (UBoolean True) :!: elsecond]+  let ec = [Terminal (UBoolean True) :!: elsecond | not (V.null elsecond)]   pe <- getSourcePos-  pure (ConditionalDecl (V.fromList ((Not cond :!: stmts) : ec )) (p :!: pe))+  pure (ConditionalDecl (V.fromList ((Not cond :!: stmts) : ec)) (p :!: pe))  ifCondition :: Parser ConditionalDecl ifCondition = do   p <- getSourcePos   reserved "if"   maincond <- puppetIfStyleCondition-  others   <- many (reserved "elsif" *> puppetIfStyleCondition)+  others <- many (reserved "elsif" *> puppetIfStyleCondition)   elsecond <- option V.empty (reserved "else" *> braces statementList)-  let ec = if V.null elsecond-               then []-               else [Terminal (UBoolean True) :!: elsecond]+  let ec = [Terminal (UBoolean True) :!: elsecond | not (V.null elsecond)]   pe <- getSourcePos   pure (ConditionalDecl (V.fromList (maincond : others ++ ec)) (p :!: pe)) @@ -428,10 +439,11 @@   let puppetRegexpCase = Terminal . URegexp <$> termRegexp       defaultCase = Terminal (UBoolean True) <$ reserved "default"       matchesToExpression e (x, stmts) = f x :!: stmts-        where f = case x of-                    (Terminal (UBoolean _)) -> identity-                    (Terminal (URegexp _))  -> RegexMatch e-                    _                       -> Equal e+        where+          f = case x of+            (Terminal (UBoolean _)) -> identity+            (Terminal (URegexp _)) -> RegexMatch e+            _ -> Equal e       cases = do         matches <- (puppetRegexpCase <|> defaultCase <|> expression) `sepBy1` comma         void $ symbolic ':'@@ -442,38 +454,38 @@   expr1 <- expression   condlist <- concat <$> braces (some cases)   pe <- getSourcePos-  pure (ConditionalDecl (V.fromList (map (matchesToExpression expr1) condlist)) (p :!: pe) )+  pure (ConditionalDecl (V.fromList (map (matchesToExpression expr1) condlist)) (p :!: pe))  data OperatorChain a   = OperatorChain a LinkType (OperatorChain a)   | EndOfChain a  instance Foldable OperatorChain where-  foldMap f (EndOfChain x)         = f x+  foldMap f (EndOfChain x) = f x   foldMap f (OperatorChain a _ nx) = f a <> foldMap f nx  operatorChainStatement :: OperatorChain a -> a operatorChainStatement (OperatorChain a _ _) = a-operatorChainStatement (EndOfChain x)        = x+operatorChainStatement (EndOfChain x) = x -zipChain :: OperatorChain a -> [ ( a, a, LinkType ) ]+zipChain :: OperatorChain a -> [(a, a, LinkType)] zipChain (OperatorChain a d nx) = (a, operatorChainStatement nx, d) : zipChain nx-zipChain (EndOfChain _)         = []+zipChain (EndOfChain _) = []  depOperator :: Parser LinkType depOperator =-      (RBefore <$ symbol "->")-  <|> (RNotify <$ symbol "~>")+  (RBefore <$ symbol "->")+    <|> (RNotify <$ symbol "~>")  assignment :: Parser AttributeDecl assignment =-      (AttributeDecl <$> lexeme key <*> arrowOp  <*> expression)-  <|> (AttributeWildcard <$> (symbolic '*' *> symbol "=>" *> expression))+  (AttributeDecl <$> lexeme key <*> arrowOp <*> expression)+    <|> (AttributeWildcard <$> (symbolic '*' *> symbol "=>" *> expression))   where     key = bareword <?> "Assignment key"     arrowOp =-          (AssignArrow <$ symbol "=>")-      <|> (AppendArrow <$ symbol "+>")+      (AssignArrow <$ symbol "=>")+        <|> (AppendArrow <$ symbol "+>")  -- | Resource Collector resCollDecl :: Position -> Text -> Parser ResCollDecl@@ -486,36 +498,41 @@   void (count (length openchev) (char '>'))   sc   overrides <- option [] $ braces (sepComma assignment)-  let collectortype = if length openchev == 1-                          then Collector-                          else ExportedCollector+  let collectortype =+        if length openchev == 1+          then Collector+          else ExportedCollector   pe <- getSourcePos-  pure (ResCollDecl collectortype restype e (V.fromList overrides) (p :!: pe) )+  pure (ResCollDecl collectortype restype e (V.fromList overrides) (p :!: pe))   where     searchExpression :: Parser SearchExpression     searchExpression =       let searchTable :: [[Operator Parser SearchExpression]]-          searchTable = [ [ InfixL ( reserved "and" *> pure AndSearch )-                          , InfixL ( reserved "or"  *> pure OrSearch  )-                          ] ]+          searchTable =+            [ [ InfixL (reserved "and" $> AndSearch),+                InfixL (reserved "or" $> OrSearch)+              ]+            ]           searchterm = parens searchExpression <|> check           check = do             attrib <- parameterName-            opr    <- (EqualitySearch <$ symbol "==")-                  <|> (NonEqualitySearch <$ symbol "!=")-            term   <- stringExpression+            opr <-+              (EqualitySearch <$ symbol "==")+                <|> (NonEqualitySearch <$ symbol "!=")+            term <- stringExpression             pure (opr attrib term)-      in makeExprParser (lexeme searchterm) searchTable+       in makeExprParser (lexeme searchterm) searchTable  classDecl :: Parser ClassDecl classDecl = do   p <- getSourcePos   reserved "class"-  ClassDecl <$> className-            <*> option V.empty puppetClassParameters-            <*> option S.Nothing (fmap S.Just (reserved "inherits" *> className))-            <*> braces statementList-            <*> ( (p :!:) <$> getSourcePos )+  ClassDecl+    <$> className+    <*> option V.empty puppetClassParameters+    <*> option S.Nothing (fmap S.Just (reserved "inherits" *> className))+    <*> braces statementList+    <*> ((p :!:) <$> getSourcePos)  mainFuncDecl :: Parser MainFuncDecl mainFuncDecl = do@@ -546,11 +563,10 @@     _ -> fail "A method chained by dots."   pure (HigherOrderLambdaDecl hf (p :!: pe)) - resDefaultDecl :: Parser ResDefaultDecl resDefaultDecl = do   p <- getSourcePos-  rnd  <- resourceNameRef+  rnd <- resourceNameRef   let assignmentList = V.fromList <$> sepComma1 assignment   asl <- braces assignmentList   pe <- getSourcePos@@ -559,11 +575,11 @@ resOverrideDecl :: Parser [ResOverrideDecl] resOverrideDecl = do   p <- getSourcePos-  restype  <- resourceNameRef+  restype <- resourceNameRef   names <- brackets (expression `sepBy1` comma) <?> "Resource reference values"   assignments <- V.fromList <$> braces (sepComma assignment)   pe <- getSourcePos-  pure [ ResOverrideDecl restype n assignments (p :!: pe) | n <- names ]+  pure [ResOverrideDecl restype n assignments (p :!: pe) | n <- names]  arrayof :: Parser p -> Parser [p] arrayof p = symbolic '[' *> sepBy p comma <* symbolic ']'@@ -577,31 +593,31 @@ chainableResources = do   let withresname = do         p <- getSourcePos-        restype  <- resourceNameRef+        restype <- resourceNameRef         lookAhead anySingle >>= \case           '[' -> do-              resnames <- brackets (expression `sepBy1` comma)-              pe <- getSourcePos-              pure (ChainResRefr restype resnames (p :!: pe))+            resnames <- brackets (expression `sepBy1` comma)+            pe <- getSourcePos+            pure (ChainResRefr restype resnames (p :!: pe))           _ -> ChainResColl <$> resCollDecl p restype   let oneresource = pure <$> try withresname <|> map ChainResDecl <$> resDeclGroup   chain <- parseRelationships (oneresource <|> concat <$> arrayof oneresource)   let relations = do         (g1, g2, lt) <- zipChain chain-        (rt1, rn1, _   :!: pe1) <- concatMap extractResRef g1-        (rt2, rn2, ps2 :!: _  ) <- concatMap extractResRef g2+        (rt1, rn1, _ :!: pe1) <- concatMap extractResRef g1+        (rt2, rn2, ps2 :!: _) <- concatMap extractResRef g2         pure (DepDecl (rt1 :!: rn1) (rt2 :!: rn2) lt (pe1 :!: ps2))   pure $ map DependencyDeclaration relations <> (chain ^.. folded . folded . to extractChainStatement . folded)   where     extractResRef :: ChainableRes -> [(Text, Expression, PPosition)]-    extractResRef (ChainResColl _)                      = []-    extractResRef (ChainResDecl (ResDecl rt rn _ _ pp)) = [(rt,rn,pp)]-    extractResRef (ChainResRefr rt rns pp)              = [(rt,rn,pp) | rn <- rns]+    extractResRef (ChainResColl _) = []+    extractResRef (ChainResDecl (ResDecl rt rn _ _ pp)) = [(rt, rn, pp)]+    extractResRef (ChainResRefr rt rns pp) = [(rt, rn, pp) | rn <- rns]      extractChainStatement :: ChainableRes -> [Statement]     extractChainStatement (ChainResColl r) = [ResourceCollectionDeclaration r]     extractChainStatement (ChainResDecl d) = [ResourceDeclaration d]-    extractChainStatement ChainResRefr{}   = []+    extractChainStatement ChainResRefr {} = []      parseRelationships :: Parser a -> Parser (OperatorChain a)     parseRelationships p = do@@ -618,67 +634,69 @@             p <- getSourcePos             names <- brackets (sepComma1 resourceName) <|> fmap pure resourceName             void $ symbolic ':'-            vals  <- fmap V.fromList (sepComma assignment)+            vals <- fmap V.fromList (sepComma assignment)             pe <- getSourcePos-            pure [(n, vals, p :!: pe) | n <- names ]+            pure [(n, vals, p :!: pe) | n <- names]           groupDeclaration = (,) <$> many (char '@') <*> typeName <* symbolic '{'       (virts, rtype) <- try groupDeclaration -- for matching reasons, this gets a try until the opening brace       let sep = symbolic ';' <|> comma       x <- resourceDeclaration `sepEndBy1` sep       void $ symbolic '}'       virtuality <- case virts of-        ""   -> pure Normal-        "@"  -> pure Virtual+        "" -> pure Normal+        "@" -> pure Virtual         "@@" -> pure Exported-        _    -> fail "Invalid virtuality"-      return [ ResDecl rtype rname conts virtuality pos | (rname, conts, pos) <- concat x ]+        _ -> fail "Invalid virtuality"+      return [ResDecl rtype rname conts virtuality pos | (rname, conts, pos) <- concat x]  statement :: Parser [Statement] statement =-      (pure . HigherOrderLambdaDeclaration <$> try dotLambdaDecl)-  <|> (pure . VarAssignmentDeclaration <$> varAssign)-  <|> (map NodeDeclaration <$> nodeDecl)-  <|> (pure . DefineDeclaration <$> defineDecl)-  <|> (pure . ConditionalDeclaration <$> unlessCondition)-  <|> (pure . ConditionalDeclaration <$> ifCondition)-  <|> (pure . ConditionalDeclaration <$> caseCondition)-  <|> (pure . ResourceDefaultDeclaration <$> try resDefaultDecl)-  <|> (map ResourceOverrideDeclaration <$> try resOverrideDecl)-  <|> chainableResources-  <|> (pure . ClassDeclaration <$> classDecl)-  <|> (pure . HigherOrderLambdaDeclaration <$> try hoLambdaDecl)-  <|> (pure . MainFunctionDeclaration <$> mainFuncDecl)-  <?> "Statement"+  (pure . HigherOrderLambdaDeclaration <$> try dotLambdaDecl)+    <|> (pure . VarAssignmentDeclaration <$> varAssign)+    <|> (map NodeDeclaration <$> nodeDecl)+    <|> (pure . DefineDeclaration <$> defineDecl)+    <|> (pure . ConditionalDeclaration <$> unlessCondition)+    <|> (pure . ConditionalDeclaration <$> ifCondition)+    <|> (pure . ConditionalDeclaration <$> caseCondition)+    <|> (pure . ResourceDefaultDeclaration <$> try resDefaultDecl)+    <|> (map ResourceOverrideDeclaration <$> try resOverrideDecl)+    <|> chainableResources+    <|> (pure . ClassDeclaration <$> classDecl)+    <|> (pure . HigherOrderLambdaDeclaration <$> try hoLambdaDecl)+    <|> (pure . MainFunctionDeclaration <$> mainFuncDecl)+    <?> "Statement"  datatype :: Parser UDataType datatype =-      dtString-  <|> dtInteger-  <|> dtFloat-  <|> dtNumeric-  <|> (UDTBoolean <$ reserved "Boolean")-  <|> (UDTScalar <$ reserved "Scalar")-  <|> (UDTData <$ reserved "Data")-  <|> (UDTAny <$ reserved "Any")-  <|> (UDTCollection <$ reserved "Collection")-  <|> dtArray-  <|> dtHash-  <|> (UDTUndef <$ reserved "Undef")-  <|> (reserved "Optional" *> (UDTOptional <$> brackets datatype))-  <|> (UNotUndef <$ reserved "NotUndef")-  <|> (reserved "Variant" *> (UDTVariant . NE.fromList <$> brackets (datatype `sepBy1` symbolic ',')))-  <|> (reserved "Regexp" *> (UDTRegexp <$> optional (brackets termRegexp)))-  -- while all the other cases are straightforward, it seems that the-  -- following syntax is a valid regexp for puppet:-  --   '^dqsqsdqs$'-  -- instead of:-  --   /^dqsqsdqs$/-  ---  -- That is the reason there is a "quotedRegexp" case-  <|> (reserved "Pattern" *> (UDTPattern . NE.fromList <$> brackets ( (termRegexp <|> quotedRegexp) `sepBy1` symbolic ',')))-  <|> (reserved "Enum" *> (UDTEnum . NE.fromList <$> brackets (expression `sepBy1` symbolic ',')))-  <|> dtExternal-  <?> "UDataType"+  dtString+    <|> dtInteger+    <|> dtFloat+    <|> dtNumeric+    <|> (UDTBoolean <$ reserved "Boolean")+    <|> (UDTScalar <$ reserved "Scalar")+    <|> (UDTData <$ reserved "Data")+    <|> (UDTAny <$ reserved "Any")+    <|> (UDTCollection <$ reserved "Collection")+    <|> dtArray+    <|> dtHash+    <|> (UDTUndef <$ reserved "Undef")+    <|> (reserved "Optional" *> (UDTOptional <$> brackets datatype))+    <|> (UNotUndef <$ reserved "NotUndef")+    <|> (reserved "Variant" *> (UDTVariant . NE.fromList <$> brackets (datatype `sepBy1` symbolic ',')))+    <|> (reserved "Regexp" *> (UDTRegexp <$> optional (brackets termRegexp)))+    <|> (UDTDeferred <$ reserved "Deferred")+    <|> (reserved "Sensitive" *> (UDTSensitive <$> brackets datatype))+    -- while all the other cases are straightforward, it seems that the+    -- following syntax is a valid regexp for puppet:+    --   '^dqsqsdqs$'+    -- instead of:+    --   /^dqsqsdqs$/+    --+    -- That is the reason there is a "quotedRegexp" case+    <|> (reserved "Pattern" *> (UDTPattern . NE.fromList <$> brackets ((termRegexp <|> quotedRegexp) `sepBy1` symbolic ',')))+    <|> (reserved "Enum" *> (UDTEnum . NE.fromList <$> brackets (expression `sepBy1` symbolic ',')))+    <|> dtExternal+    <?> "UDataType"   where     quotedRegexp = stringLiteral' >>= compileRegexp     integer = integerOrDouble >>= either (return . fromIntegral) (\d -> fail ("Integer value expected, instead of " ++ show d))@@ -689,9 +707,9 @@     dtbounded s constructor parser = dtArgs s (constructor Nothing Nothing) $ do       lst <- parser `sepBy1` symbolic ','       case lst of-        [minlen]        -> return $ constructor (Just minlen) Nothing-        [minlen,maxlen] -> return $ constructor (Just minlen) (Just maxlen)-        _               -> fail ("Too many arguments to datatype " ++ Text.unpack s)+        [minlen] -> return $ constructor (Just minlen) Nothing+        [minlen, maxlen] -> return $ constructor (Just minlen) (Just maxlen)+        _ -> fail ("Too many arguments to datatype " ++ Text.unpack s)     dtString = dtbounded "String" UDTString integer     dtInteger = dtbounded "Integer" UDTInteger integer     dtFloat = dtbounded "Float" UDTFloat float@@ -703,11 +721,11 @@         rst <- optional (symbolic ',' *> integer `sepBy1` symbolic ',')         return (tp, rst)       case ml of-        Nothing                 -> return (UDTArray UDTData 0 Nothing)-        Just (t, Nothing)       -> return (UDTArray t 0 Nothing)-        Just (t, Just [mi])     -> return (UDTArray t mi Nothing)+        Nothing -> return (UDTArray UDTData 0 Nothing)+        Just (t, Nothing) -> return (UDTArray t 0 Nothing)+        Just (t, Just [mi]) -> return (UDTArray t mi Nothing)         Just (t, Just [mi, mx]) -> return (UDTArray t mi (Just mx))-        Just (_, Just _)        -> fail "Too many arguments to datatype Array"+        Just (_, Just _) -> fail "Too many arguments to datatype Array"     dtHash = do       reserved "Hash"       ml <- optional $ brackets $ do@@ -717,62 +735,67 @@         rst <- optional (symbolic ',' *> integer `sepBy1` symbolic ',')         return (tk, tv, rst)       case ml of-        Nothing                      -> return (UDTHash UDTScalar UDTData 0 Nothing)-        Just (tk, tv, Nothing)       -> return (UDTHash tk tv 0 Nothing)-        Just (tk, tv, Just [mi])     -> return (UDTHash tk tv mi Nothing)+        Nothing -> return (UDTHash UDTScalar UDTData 0 Nothing)+        Just (tk, tv, Nothing) -> return (UDTHash tk tv 0 Nothing)+        Just (tk, tv, Just [mi]) -> return (UDTHash tk tv mi Nothing)         Just (tk, tv, Just [mi, mx]) -> return (UDTHash tk tv mi (Just mx))-        Just (_, _, Just _)          -> fail "Too many arguments to datatype Hash"+        Just (_, _, Just _) -> fail "Too many arguments to datatype Hash"     dtExternal =-      choice [ reserved "Stdlib::Absolutepath" $> UDTData-             , reserved "Stdlib::Base32" $> UDTData-             , reserved "Stdlib::Base64" $> UDTData-             , reserved "Stdlib::Compat::Absolute_path" $> UDTData-             , reserved "Stdlib::Compat::Array" $> UDTData-             , reserved "Stdlib::Compat::Bool" $> UDTData-             , reserved "Stdlib::Compat::Float" $> UDTData-             , reserved "Stdlib::Compat::Hash" $> UDTData-             , reserved "Stdlib::Compat::Integer" $> UDTData-             , reserved "Stdlib::Compat::Ip_address" $> UDTData-             , reserved "Stdlib::Compat::Ipv4" $> UDTData-             , reserved "Stdlib::Compat::Ipv6" $> UDTData-             , reserved "Stdlib::Compat::Numeric" $> UDTData-             , reserved "Stdlib::Compat::String" $> UDTData-             , reserved "Stdlib::Ensure::Service" $> UDTData-             , reserved "Stdlib::Filemode" $> UDTData-             , reserved "Stdlib::Filesource" $> UDTData-             , reserved "Stdlib::Fqdn" $> UDTData-             , reserved "Stdlib::Host" $> UDTData-             , reserved "Stdlib::HTTPSUrl" $> UDTData-             , reserved "Stdlib::HTTPUrl" $> UDTData-             , reserved "Stdlib::IP::Address::Nosubnet" $> UDTData-             , reserved "Stdlib::Ip_address" $> UDTData-             , reserved "Stdlib::IP::Address" $> UDTData-             , reserved "Stdlib::IP::Address::V4::CIDR" $> UDTData-             , reserved "Stdlib::IP::Address::V4::Nosubnet" $> UDTData-             , reserved "Stdlib::IP::Address::V4" $> UDTData-             , reserved "Stdlib::IP::Address::V6::Alternative" $> UDTData-             , reserved "Stdlib::IP::Address::V6::Compressed" $> UDTData-             , reserved "Stdlib::IP::Address::V6::Full" $> UDTData-             , reserved "Stdlib::IP::Address::V6::Nosubnet::Alternative" $> UDTData-             , reserved "Stdlib::IP::Address::V6::Nosubnet::Compressed" $> UDTData-             , reserved "Stdlib::IP::Address::V6::Nosubnet::Full" $> UDTData-             , reserved "Stdlib::IP::Address::V6::Nosubnet" $> UDTData-             , reserved "Stdlib::IP::Address::V6" $> UDTData-             , reserved "Stdlib::Ipv4" $> UDTData-             , reserved "Stdlib::Ipv6" $> UDTData-             , reserved "Stdlib::MAC" $> UDTData-             , reserved "Stdlib::Port::Privileged" $> UDTData-             , reserved "Stdlib::Port" $> UDTData-             , reserved "Stdlib::Port::Unprivileged" $> UDTData-             , reserved "Stdlib::Unixpath" $> UDTData-             , reserved "Stdlib::Windowspath" $> UDTData-             , reserved "Nginx::ErrorLogSeverity" $> UDTData-             , reserved "Jenkins::Tunnel" $> UDTData-             , reserved "Systemd::Unit" $> UDTData-             , reserved "Systemd::ServiceLimits" $> UDTData-             , reserved "Systemd::Dropin" $> UDTData-             , reserved "Systemd::JournaldSettings" $> UDTData-             ]+      choice+        [ reserved "Stdlib::Absolutepath" $> UDTData,+          reserved "Stdlib::Base32" $> UDTData,+          reserved "Stdlib::Base64" $> UDTData,+          reserved "Stdlib::Compat::Absolute_path" $> UDTData,+          reserved "Stdlib::Compat::Array" $> UDTData,+          reserved "Stdlib::Compat::Bool" $> UDTData,+          reserved "Stdlib::Compat::Float" $> UDTData,+          reserved "Stdlib::Compat::Hash" $> UDTData,+          reserved "Stdlib::Compat::Integer" $> UDTData,+          reserved "Stdlib::Compat::Ip_address" $> UDTData,+          reserved "Stdlib::Compat::Ipv4" $> UDTData,+          reserved "Stdlib::Compat::Ipv6" $> UDTData,+          reserved "Stdlib::Compat::Numeric" $> UDTData,+          reserved "Stdlib::Compat::String" $> UDTData,+          reserved "Stdlib::Ensure::Service" $> UDTData,+          reserved "Stdlib::Filemode" $> UDTData,+          reserved "Stdlib::Filesource" $> UDTData,+          reserved "Stdlib::Fqdn" $> UDTData,+          reserved "Stdlib::Host" $> UDTData,+          reserved "Stdlib::HTTPSUrl" $> UDTData,+          reserved "Stdlib::HTTPUrl" $> UDTData,+          reserved "Stdlib::IP::Address::Nosubnet" $> UDTData,+          reserved "Stdlib::Ip_address" $> UDTData,+          reserved "Stdlib::IP::Address" $> UDTData,+          reserved "Stdlib::IP::Address::V4::CIDR" $> UDTData,+          reserved "Stdlib::IP::Address::V4::Nosubnet" $> UDTData,+          reserved "Stdlib::IP::Address::V4" $> UDTData,+          reserved "Stdlib::IP::Address::V6::Alternative" $> UDTData,+          reserved "Stdlib::IP::Address::V6::Compressed" $> UDTData,+          reserved "Stdlib::IP::Address::V6::Full" $> UDTData,+          reserved "Stdlib::IP::Address::V6::Nosubnet::Alternative" $> UDTData,+          reserved "Stdlib::IP::Address::V6::Nosubnet::Compressed" $> UDTData,+          reserved "Stdlib::IP::Address::V6::Nosubnet::Full" $> UDTData,+          reserved "Stdlib::IP::Address::V6::Nosubnet" $> UDTData,+          reserved "Stdlib::IP::Address::V6" $> UDTData,+          reserved "Stdlib::Ipv4" $> UDTData,+          reserved "Stdlib::Ipv6" $> UDTData,+          reserved "Stdlib::MAC" $> UDTData,+          reserved "Stdlib::Port::Privileged" $> UDTData,+          reserved "Stdlib::Port" $> UDTData,+          reserved "Stdlib::Port::Unprivileged" $> UDTData,+          reserved "Stdlib::Unixpath" $> UDTData,+          reserved "Stdlib::Windowspath" $> UDTData,+          reserved "Nginx::ErrorLogSeverity" $> UDTData,+          reserved "Jenkins::Tunnel" $> UDTData,+          reserved "Systemd::Unit" $> UDTData,+          reserved "Systemd::ServiceLimits" $> UDTData,+          reserved "Systemd::Dropin" $> UDTData,+          reserved "Systemd::JournaldSettings" $> UDTData,+          reserved "Systemd::JournaldSettings::Ensure" $> UDTData,+          reserved "Systemd::LogindSettings" $> UDTData,+          reserved "Systemd::LogindSettings::Ensure" $> UDTData,+          reserved "Systemd::CoredumpSettings" $> UDTData+        ]  statementList :: Parser (Vector Statement) statementList = V.fromList . concat <$> many statement@@ -780,12 +803,14 @@ lambdaCall :: Parser HOLambdaCall lambdaCall = do   let tostrict (Just x) = S.Just x-      tostrict Nothing  = S.Nothing-  HOLambdaCall <$> lambFunc-               <*> parameters-               <*> lambParams-               <*> (symbolic '{' *> fmap (V.fromList . concat) (many (try statement)))-               <*> fmap tostrict (optional expression) <* symbolic '}'+      tostrict Nothing = S.Nothing+  HOLambdaCall+    <$> lambFunc+    <*> parameters+    <*> lambParams+    <*> (symbolic '{' *> fmap (V.fromList . concat) (many (try statement)))+    <*> fmap tostrict (optional expression)+    <* symbolic '}'   where     parameters :: Parser (V.Vector Expression)     parameters = maybe V.empty V.fromList <$> optional (parens (expression `sepBy` comma))
src/Puppet/Parser/Lens.hs view
@@ -1,53 +1,52 @@-{-# LANGUAGE TemplateHaskell  #-}-module Puppet.Parser.Lens- (- -- * Prism for 'Statement's-   _Statements- , _ResDecl- , _ResDefaultDecl- , _ResOverrDecl- , _ResCollDecl- , _ConditionalDecl- , _ClassDecl- , _DefineDecl- , _NodeDecl- , _VarAssignDecl- , _MainFuncDecl- , _HigherOrderLambdaDecl- , _DepDecl- -- * Prism for 'Expression's- , _Equal- , _Different- , _Not- , _And- , _Or- , _LessThan- , _MoreThan- , _LessEqualThan- , _MoreEqualThan- , _RegexMatch- , _NotRegexMatch- , _Contains- , _Addition- , _Substraction- , _Division- , _Multiplication- , _Modulo- , _RightShift- , _LeftShift- , _Lookup- , _Negate- , _ConditionalValue- , _FunctionApplication- , _Terminal- ) where-+{-# LANGUAGE TemplateHaskell #-} -import           XPrelude+module Puppet.Parser.Lens+  ( -- * Prism for 'Statement's+    _Statements,+    _ResDecl,+    _ResDefaultDecl,+    _ResOverrDecl,+    _ResCollDecl,+    _ConditionalDecl,+    _ClassDecl,+    _DefineDecl,+    _NodeDecl,+    _VarAssignDecl,+    _MainFuncDecl,+    _HigherOrderLambdaDecl,+    _DepDecl, -import qualified Data.Vector         as V+    -- * Prism for 'Expression's+    _Equal,+    _Different,+    _Not,+    _And,+    _Or,+    _LessThan,+    _MoreThan,+    _LessEqualThan,+    _MoreEqualThan,+    _RegexMatch,+    _NotRegexMatch,+    _Contains,+    _Addition,+    _Substraction,+    _Division,+    _Multiplication,+    _Modulo,+    _RightShift,+    _LeftShift,+    _Lookup,+    _Negate,+    _ConditionalValue,+    _FunctionApplication,+    _Terminal,+  )+where -import           Puppet.Parser.Types+import qualified Data.Vector as V+import Puppet.Parser.Types+import XPrelude  makePrisms ''Expression @@ -56,91 +55,91 @@   prism ResourceDeclaration $ \x ->     case x of       ResourceDeclaration a -> Right a-      _                     -> Left x+      _ -> Left x  _ResDefaultDecl :: Prism' Statement ResDefaultDecl _ResDefaultDecl =   prism ResourceDefaultDeclaration $ \x ->     case x of       ResourceDefaultDeclaration a -> Right a-      _                            -> Left x+      _ -> Left x  _ResOverrDecl :: Prism' Statement ResOverrideDecl _ResOverrDecl =   prism ResourceOverrideDeclaration $ \x ->     case x of       ResourceOverrideDeclaration a -> Right a-      _                             -> Left x+      _ -> Left x  _ResCollDecl :: Prism' Statement ResCollDecl _ResCollDecl =   prism ResourceCollectionDeclaration $ \x ->     case x of       ResourceCollectionDeclaration a -> Right a-      _                               -> Left x+      _ -> Left x  _ConditionalDecl :: Prism' Statement ConditionalDecl _ConditionalDecl =   prism ConditionalDeclaration $ \x ->     case x of       ConditionalDeclaration a -> Right a-      _                        -> Left x+      _ -> Left x  _ClassDecl :: Prism' Statement ClassDecl _ClassDecl =   prism ClassDeclaration $ \x ->     case x of       ClassDeclaration a -> Right a-      _                  -> Left x+      _ -> Left x  _DefineDecl :: Prism' Statement DefineDecl _DefineDecl =   prism DefineDeclaration $ \x ->     case x of       DefineDeclaration a -> Right a-      _                   -> Left x+      _ -> Left x  _NodeDecl :: Prism' Statement NodeDecl _NodeDecl =   prism NodeDeclaration $ \x ->     case x of       NodeDeclaration a -> Right a-      _                 -> Left x+      _ -> Left x  _VarAssignDecl :: Prism' Statement VarAssignDecl _VarAssignDecl =   prism VarAssignmentDeclaration $ \x ->     case x of       VarAssignmentDeclaration a -> Right a-      _                          -> Left x+      _ -> Left x  _MainFuncDecl :: Prism' Statement MainFuncDecl _MainFuncDecl =   prism MainFunctionDeclaration $ \x ->     case x of       MainFunctionDeclaration a -> Right a-      _                         -> Left x+      _ -> Left x  _HigherOrderLambdaDecl :: Prism' Statement HigherOrderLambdaDecl _HigherOrderLambdaDecl =   prism HigherOrderLambdaDeclaration $ \x ->     case x of       HigherOrderLambdaDeclaration a -> Right a-      _                              -> Left x+      _ -> Left x  _DepDecl :: Prism' Statement DepDecl _DepDecl =   prism DependencyDeclaration $ \x ->     case x of       DependencyDeclaration a -> Right a-      _                       -> Left x+      _ -> Left x  _TopContainer :: Prism' Statement (V.Vector Statement, Statement) _TopContainer =   prism (uncurry TopContainer) $ \x ->     case x of       TopContainer vs s -> Right (vs, s)-      _                 -> Left x+      _ -> Left x  _Statements :: Lens' Statement [Statement] _Statements =
src/Puppet/Parser/PrettyPrinter.hs view
@@ -1,22 +1,23 @@+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module Puppet.Parser.PrettyPrinter-  ( ppStatements-  ) where -import           XPrelude.Extra               hiding ((<$>))-import           XPrelude.PP--import qualified Data.Maybe.Strict            as S-import qualified Data.Text                    as Text-import qualified Data.Tuple.Strict            as Tuple-import qualified Data.Vector                  as V-import           Text.PrettyPrint.ANSI.Leijen ((<$>))--import           Puppet.Language-import           Puppet.Parser.Types+{-# HLINT ignore "Functor law" #-}+module Puppet.Parser.PrettyPrinter+  ( ppStatements,+  )+where +import qualified Data.Maybe.Strict as S+import qualified Data.Text as Text+import qualified Data.Tuple.Strict as Tuple+import qualified Data.Vector as V+import Puppet.Language+import Puppet.Parser.Types+import Text.PrettyPrint.ANSI.Leijen ((<$>))+import XPrelude.Extra hiding ((<$>))+import XPrelude.PP -parensList :: Pretty a => Vector a -> Doc+parensList :: (Pretty a) => Vector a -> Doc parensList = tupled . fmap pretty . V.toList  hashComma :: (Pretty a, Pretty b) => Vector (Pair a b) -> Doc@@ -24,37 +25,39 @@   where     showC (a :!: b) = pretty a <+> "=>" <+> pretty b - instance Pretty UDataType where   pretty t = case t of-    UDTType              -> "Type"-    UDTString ma mb      -> bounded "String" ma mb-    UDTInteger ma mb     -> bounded "Integer" ma mb-    UDTFloat ma mb       -> bounded "Float" ma mb-    UDTBoolean           -> "Boolean"-    UDTArray dt mi mmx   -> "Array" <> list (pretty dt : pretty mi : maybe [] (pure . pretty) mmx)+    UDTType -> "Type"+    UDTString ma mb -> bounded "String" ma mb+    UDTInteger ma mb -> bounded "Integer" ma mb+    UDTFloat ma mb -> bounded "Float" ma mb+    UDTBoolean -> "Boolean"+    UDTArray dt mi mmx -> "Array" <> list (pretty dt : pretty mi : maybe [] (pure . pretty) mmx)     UDTHash kt dt mi mmx -> "Hash" <> list (pretty kt : pretty dt : pretty mi : maybe [] (pure . pretty) mmx)-    UDTUndef             -> "Undef"-    UDTScalar            -> "Scalar"-    UDTData              -> "Data"-    UDTOptional o        -> "Optional" <> brackets (pretty o)-    UNotUndef            -> "NotUndef"-    UDTVariant vs        -> "Variant" <> list (foldMap (pure . pretty) vs)-    UDTPattern vs        -> "Pattern" <> list (foldMap (pure . pretty) vs)-    UDTEnum tx           -> "Enum" <> list (foldMap (pure . pretty) tx)-    UDTAny               -> "Any"-    UDTCollection        -> "Collection"-    UDTRegexp mr         -> "Regexp" <> foldMap (brackets . pretty) mr+    UDTUndef -> "Undef"+    UDTScalar -> "Scalar"+    UDTData -> "Data"+    UDTOptional o -> "Optional" <> brackets (pretty o)+    UNotUndef -> "NotUndef"+    UDTVariant vs -> "Variant" <> list (foldMap (pure . pretty) vs)+    UDTPattern vs -> "Pattern" <> list (foldMap (pure . pretty) vs)+    UDTEnum tx -> "Enum" <> list (foldMap (pure . pretty) tx)+    UDTAny -> "Any"+    UDTCollection -> "Collection"+    UDTRegexp mr -> "Regexp" <> foldMap (brackets . pretty) mr+    UDTDeferred -> "Deferred"+    UDTSensitive o -> "Sensitive" <> brackets (pretty o)     where       bounded :: (Pretty a, Pretty b) => Doc -> Maybe a -> Maybe b -> Doc-      bounded s ma mb = s <> case (ma, mb) of-        (Just a, Nothing) -> list [pretty a]-        (Just a, Just b)  -> list [pretty a, pretty b]-        _                 -> mempty+      bounded s ma mb =+        s <> case (ma, mb) of+          (Just a, Nothing) -> list [pretty a]+          (Just a, Just b) -> list [pretty a, pretty b]+          _ -> mempty  instance Pretty Expression where   pretty (Equal a b) = parens (pretty a <+> "==" <+> pretty b)-  pretty (Different a b) = parens (pretty a <+>"!=" <+> pretty b)+  pretty (Different a b) = parens (pretty a <+> "!=" <+> pretty b)   pretty (And a b) = parens (pretty a <+> "and" <+> pretty b)   pretty (Or a b) = parens (pretty a <+> "or" <+> pretty b)   pretty (LessThan a b) = parens (pretty a <+> pretty '<' <+> pretty b)@@ -116,7 +119,6 @@   pretty (UHOLambdaCall c) = pretty c   pretty (UDataType dt) = pretty dt - instance Pretty HOLambdaCall where   pretty (HOLambdaCall hf me bp stts mee) =     pretty hf <> parensList me <+> pretty bp <+> nest 2 (pretty '{' <> line <> ppStatements stts <> mmee) <$> pretty '}'@@ -125,6 +127,7 @@         case mee of           S.Just x -> mempty </> pretty x           S.Nothing -> mempty+ instance Pretty SelectorCase where   pretty SelectorDefault = dullmagenta "default"   pretty (SelectorType t) = pretty t@@ -134,13 +137,15 @@   pretty AssignArrow = "=>"   pretty AppendArrow = "+>" - showAss :: Vector AttributeDecl -> Doc showAss vx = folddoc (\a b -> a <> pretty ',' <$> b) prettyDecl (V.toList vx)   where     folddoc _ _ [] = mempty-    folddoc acc docGen (x:xs) = foldl acc (docGen x) (map docGen xs)-    maxlen = maximum (fmap (\(AttributeDecl k _ _) -> Text.length k) vx)+    folddoc acc docGen (x : xs) = foldl acc (docGen x) (map docGen xs)+    maxlen = maximum (fmap attributeLength vx)+    attributeLength ad = case ad of+      AttributeDecl k _ _ -> Text.length k+      AttributeWildcard _ -> 0     prettyDecl (AttributeDecl k op v) = dullblue (fill maxlen (ppline k)) <+> pretty op <+> pretty v     prettyDecl (AttributeWildcard v) = dullblue "*" <+> pretty AssignArrow <+> pretty v @@ -149,10 +154,13 @@   where     lst = V.toList vec     maxlen = maximum (map (Text.length . Tuple.fst . Tuple.fst) lst)-    ra (argname :!: mtype :!: rval) =-      dullblue (pretty '$' <> foldMap (\t -> pretty t <+> mempty) mtype-                           <> fill maxlen (ppline argname))-                           <> foldMap (\v -> mempty <+> pretty '=' <+> pretty v) rval+    ra ((argname :!: mtype) :!: rval) =+      dullblue+        ( pretty '$'+            <> foldMap (\t -> pretty t <+> mempty) mtype+            <> fill maxlen (ppline argname)+        )+        <> foldMap (\v -> mempty <+> pretty '=' <+> pretty v) rval  showFunc :: Text -> Vector Expression -> Doc showFunc funcname args = bold (red (ppline funcname)) <> parensList args@@ -170,49 +178,55 @@     foldMap (\t -> pretty t <+> mempty) mt <> dullblue (foldMap (\v -> pretty '$' <> ppline v) vs) <+> pretty '=' <+> pretty expr <+> showPPos p  instance Pretty Statement where-    pretty (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl c p)) = pretty c <+> showPPos p-    pretty (ConditionalDeclaration (ConditionalDecl conds p))-        | V.null conds = mempty-        | otherwise = "if" <+> pretty firstcond <+> showPPos p <+> braceStatements firststts <$> vcat (map rendernexts xs)-        where-            ( (firstcond :!: firststts) : xs ) = V.toList conds-            rendernexts (Terminal (UBoolean True) :!: st) = "else" <+> braceStatements st-            rendernexts (c :!: st) | V.null st = mempty-                                   | otherwise = "elsif" <+> pretty c <+> braceStatements st-    pretty (MainFunctionDeclaration (MainFuncDecl funcname args p)) = showFunc funcname args <+> showPPos p-    pretty (ResourceDefaultDeclaration (ResDefaultDecl rtype defaults p)) = capitalizeR rtype <+> nest 2 (pretty '{' <+> showPPos p <$> showAss defaults) <$> pretty '}'-    pretty (ResourceOverrideDeclaration (ResOverrideDecl rtype rnames overs p)) = pretty (UResourceReference rtype rnames) <+> nest 2 (pretty '{' <+> showPPos p <$> showAss overs) <$> pretty '}'-    pretty (ResourceDeclaration (ResDecl rtype rname args virt p)) = nest 2 (red vrt <> dullgreen (ppline rtype) <+> pretty '{' <+> showPPos p-                                                                           <$> nest 2 (pretty rname <> pretty ':' <$> showAss args))-                                                                           <$> pretty '}'-        where-            vrt = case virt of-                      Normal           -> mempty-                      Virtual          -> pretty '@'-                      Exported         -> "@@"-                      ExportedRealized -> "!!"-    pretty (DefineDeclaration (DefineDecl cname args stts p)) = dullyellow "define" <+> dullgreen (ppline cname) <> showArgs args <+> showPPos p <$> braceStatements stts-    pretty (ClassDeclaration (ClassDecl cname args inherit stts p)) = dullyellow "class" <+> dullgreen (ppline cname) <> showArgs args <> inheritance <+> showPPos p-                                                               <$> braceStatements stts-        where-          inheritance = case inherit of-            S.Nothing -> mempty-            S.Just x -> mempty <+> "inherits" <+> ppline x-    pretty (VarAssignmentDeclaration decl) = pretty decl-    pretty (NodeDeclaration (NodeDecl nodename stmts i p)) = dullyellow "node" <+> pretty nodename <> inheritance <+> showPPos p <$> braceStatements stmts-        where-          inheritance = case i of-            S.Nothing -> mempty-            S.Just n -> mempty <+> ppline "inherits" <+> pretty n-    pretty (DependencyDeclaration (DepDecl (st :!: sn) (dt :!: dn) lt p)) = pretty (UResourceReference st sn) <+> pretty lt <+> pretty (UResourceReference dt dn) <+> showPPos p-    pretty (TopContainer a b) = "TopContainer:" <+> braces ( nest 2 ("TOP" <$> braceStatements a <$> "STATEMENT" <$> pretty b))-    pretty (ResourceCollectionDeclaration (ResCollDecl coltype restype search overrides p)) = capitalizeR restype <> enc (pretty search) <+> overs-        where-            overs | V.null overrides = showPPos p-                  | otherwise = nest 2 (pretty '{' <+> showPPos p <$> showAss overrides) <$> pretty '}'-            enc = case coltype of-                      Collector         -> enclose "<|" "|>"-                      ExportedCollector -> enclose "<<|" "|>>"+  pretty (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl c p)) = pretty c <+> showPPos p+  pretty (ConditionalDeclaration (ConditionalDecl conds p)) = case V.toList conds of+    [] -> mempty+    (firstcond :!: firststts) : xs ->+      let rendernexts (Terminal (UBoolean True) :!: st) = "else" <+> braceStatements st+          rendernexts (c :!: st)+            | V.null st = mempty+            | otherwise = "elsif" <+> pretty c <+> braceStatements st+       in "if" <+> pretty firstcond <+> showPPos p <+> braceStatements firststts <$> vcat (map rendernexts xs)+  pretty (MainFunctionDeclaration (MainFuncDecl funcname args p)) = showFunc funcname args <+> showPPos p+  pretty (ResourceDefaultDeclaration (ResDefaultDecl rtype defaults p)) = capitalizeR rtype <+> nest 2 (pretty '{' <+> showPPos p <$> showAss defaults) <$> pretty '}'+  pretty (ResourceOverrideDeclaration (ResOverrideDecl rtype rnames overs p)) = pretty (UResourceReference rtype rnames) <+> nest 2 (pretty '{' <+> showPPos p <$> showAss overs) <$> pretty '}'+  pretty (ResourceDeclaration (ResDecl rtype rname args virt p)) =+    nest+      2+      ( red vrt <> dullgreen (ppline rtype) <+> pretty '{' <+> showPPos p+          <$> nest 2 (pretty rname <> pretty ':' <$> showAss args)+      )+      <$> pretty '}'+    where+      vrt = case virt of+        Normal -> mempty+        Virtual -> pretty '@'+        Exported -> "@@"+        ExportedRealized -> "!!"+  pretty (DefineDeclaration (DefineDecl cname args stts p)) = dullyellow "define" <+> dullgreen (ppline cname) <> showArgs args <+> showPPos p <$> braceStatements stts+  pretty (ClassDeclaration (ClassDecl cname args inherit stts p)) =+    dullyellow "class" <+> dullgreen (ppline cname) <> showArgs args <> inheritance <+> showPPos p+      <$> braceStatements stts+    where+      inheritance = case inherit of+        S.Nothing -> mempty+        S.Just x -> mempty <+> "inherits" <+> ppline x+  pretty (VarAssignmentDeclaration decl) = pretty decl+  pretty (NodeDeclaration (NodeDecl nodename stmts i p)) = dullyellow "node" <+> pretty nodename <> inheritance <+> showPPos p <$> braceStatements stmts+    where+      inheritance = case i of+        S.Nothing -> mempty+        S.Just n -> mempty <+> ppline "inherits" <+> pretty n+  pretty (DependencyDeclaration (DepDecl (st :!: sn) (dt :!: dn) lt p)) = pretty (UResourceReference st sn) <+> pretty lt <+> pretty (UResourceReference dt dn) <+> showPPos p+  pretty (TopContainer a b) = "TopContainer:" <+> braces (nest 2 ("TOP" <$> braceStatements a <$> "STATEMENT" <$> pretty b))+  pretty (ResourceCollectionDeclaration (ResCollDecl coltype restype search overrides p)) = capitalizeR restype <> enc (pretty search) <+> overs+    where+      overs+        | V.null overrides = showPPos p+        | otherwise = nest 2 (pretty '{' <+> showPPos p <$> showAss overrides) <$> pretty '}'+      enc = case coltype of+        Collector -> enclose "<|" "|>"+        ExportedCollector -> enclose "<<|" "|>>"  -- | Pretty print a series of statements. ppStatements :: Vector Statement -> Doc
src/Puppet/Parser/Types.hs view
@@ -1,63 +1,65 @@-{-# LANGUAGE DeriveGeneric   #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies    #-}+{-# LANGUAGE TypeFamilies #-}+ -- | All the types used for parsing, and helpers working on these types. module Puppet.Parser.Types- ( -- ** Expressions-   Expression(..),-   SelectorCase(..),-   UnresolvedValue(..),-   LambdaFunc(..),-   HOLambdaCall(..),-   ChainableRes(..),-   HasHOLambdaCall(..),-   LambdaParameter(..),-   LambdaParameters,-   CompRegex(..),-   CollectorType(..),-   Virtuality(..),-   NodeDesc(..),-   LinkType(..),-   -- ** Synonyms-   Parser,-   PuppetParseError,-   -- ** Datatypes-   UDataType(..),-   -- ** Search Expressions-   SearchExpression(..),-   -- ** Declaration-   AttributeDecl(..),-   ArrowOp(..),-   ConditionalDecl(..),-   ClassDecl(..),-   ResDefaultDecl(..),-   DepDecl(..),-   Statement(..),-   ResDecl(..),-   ResOverrideDecl(..),-   DefineDecl(..),-   NodeDecl(..),-   VarAssignDecl(..),-   MainFuncDecl(..),-   HigherOrderLambdaDecl(..),-   ResCollDecl(..),-   Parameters-   ) where+  ( -- ** Expressions+    Expression (..),+    SelectorCase (..),+    UnresolvedValue (..),+    LambdaFunc (..),+    HOLambdaCall (..),+    ChainableRes (..),+    HasHOLambdaCall (..),+    LambdaParameter (..),+    LambdaParameters,+    CompRegex (..),+    CollectorType (..),+    Virtuality (..),+    NodeDesc (..),+    LinkType (..), -import           XPrelude           hiding (show)+    -- ** Synonyms+    Parser,+    PuppetParseError, -import           Data.List.NonEmpty (NonEmpty)-import qualified Data.Maybe.Strict  as S-import qualified Data.Text          as Text-import qualified Data.Vector        as V-import qualified GHC.Exts           as Exts-import           GHC.Show           (Show (..))-import           Text.Megaparsec+    -- ** Datatypes+    UDataType (..), -import           Puppet.Language+    -- ** Search Expressions+    SearchExpression (..), +    -- ** Declaration+    AttributeDecl (..),+    ArrowOp (..),+    ConditionalDecl (..),+    ClassDecl (..),+    ResDefaultDecl (..),+    DepDecl (..),+    Statement (..),+    ResDecl (..),+    ResOverrideDecl (..),+    DefineDecl (..),+    NodeDecl (..),+    VarAssignDecl (..),+    MainFuncDecl (..),+    HigherOrderLambdaDecl (..),+    ResCollDecl (..),+    Parameters,+  )+where +import qualified Data.Maybe.Strict as S+import qualified Data.Text as Text+import qualified Data.Vector as V+import qualified GHC.Exts as Exts+import Puppet.Language+import Text.Megaparsec+import XPrelude hiding (show)+ type PuppetParseError = ParseError Char Void+ type Parser = Parsec Void Text  -- | /High Order lambdas/.@@ -71,14 +73,14 @@   deriving (Eq, Show)  -- The description of the /higher level lambda/ call.-data HOLambdaCall-  = HOLambdaCall-  { _hoLambdaFunc       :: !LambdaFunc-  , _hoLambdaExpr       :: !(Vector Expression)-  , _hoLambdaParams     :: !LambdaParameters-  , _hoLambdaStatements :: !(Vector Statement)-  , _hoLambdaLastExpr   :: !(S.Maybe Expression)-  } deriving (Eq,Show)+data HOLambdaCall = HOLambdaCall+  { _hoLambdaFunc :: !LambdaFunc,+    _hoLambdaExpr :: !(Vector Expression),+    _hoLambdaParams :: !LambdaParameters,+    _hoLambdaStatements :: !(Vector Statement),+    _hoLambdaLastExpr :: !(S.Maybe Expression)+  }+  deriving (Eq, Show)  data ChainableRes   = ChainResColl !ResCollDecl@@ -92,20 +94,28 @@   deriving (Show, Eq)  data ArrowOp-  = AppendArrow -- ^ `+>`-  | AssignArrow -- ^ `=>`+  = -- | `+>`+    AppendArrow+  | -- | `=>`+    AssignArrow   deriving (Show, Eq)  -- | An unresolved value, typically the parser's output. data UnresolvedValue-  = UBoolean !Bool -- ^ Special tokens generated when parsing the @true@ or @false@ literals.-  | UString !Text -- ^ Raw string.-  | UInterpolable !(Vector Expression) -- ^ A string that might contain variable references. The type should be refined at one point.-  | UUndef -- ^ Special token that is generated when parsing the @undef@ literal.-  | UResourceReference !Text !Expression -- ^ Alike @Resource[reference]@+  = -- | Special tokens generated when parsing the @true@ or @false@ literals.+    UBoolean !Bool+  | -- | Raw string.+    UString !Text+  | -- | A string that might contain variable references. The type should be refined at one point.+    UInterpolable !(Vector Expression)+  | -- | Special token that is generated when parsing the @undef@ literal.+    UUndef+  | -- | Alike @Resource[reference]@+    UResourceReference !Text !Expression   | UArray !(Vector Expression)   | UHash !(Vector (Pair Expression Expression))-  | URegexp !CompRegex -- ^ The regular expression compilation is performed during parsing.+  | -- | The regular expression compilation is performed during parsing.+    URegexp !CompRegex   | UVariableReference !Text   | UFunctionCall !Text !(Vector Expression)   | UHOLambdaCall !HOLambdaCall@@ -114,11 +124,11 @@   deriving (Show, Eq)  instance Exts.IsList UnresolvedValue where-  type Item UnresolvedValue  = Expression+  type Item UnresolvedValue = Expression   fromList = UArray . V.fromList   toList u = case u of     UArray lst -> V.toList lst-    _          -> [Terminal u]+    _ -> [Terminal u]  instance IsString UnresolvedValue where   fromString = UString . Text.pack@@ -150,11 +160,15 @@   | Modulo !Expression !Expression   | RightShift !Expression !Expression   | LeftShift !Expression !Expression-  | Lookup !Expression !Expression -- ^ Hash lookup @$var[\'key0\'][\'key1\']@+  | -- | Hash lookup @$var[\'key0\'][\'key1\']@+    Lookup !Expression !Expression   | Negate !Expression-  | ConditionalValue !Expression !(Vector (Pair SelectorCase Expression)) -- ^ All conditionals are stored in this format.-  | FunctionApplication !Expression !Expression -- ^ This is for /higher order functions/.-  | Terminal !UnresolvedValue -- ^ Terminal object contains no expression+  | -- | All conditionals are stored in this format.+    ConditionalValue !Expression !(Vector (Pair SelectorCase Expression))+  | -- | This is for /higher order functions/.+    FunctionApplication !Expression !Expression+  | -- | Terminal object contains no expression+    Terminal !UnresolvedValue   deriving (Eq, Show)  data UDataType@@ -176,6 +190,8 @@   | UDTAny   | UDTCollection   | UDTRegexp (Maybe CompRegex)+  | UDTDeferred+  | UDTSensitive UDataType   -- Tuple (NonEmpty DataType) Integer Integer   -- DTDefault   -- Struct TODO@@ -186,7 +202,7 @@   fromList = Terminal . Exts.fromList   toList u = case u of     Terminal t -> Exts.toList t-    _          -> [u]+    _ -> [u]  instance Num Expression where   (+) = Addition@@ -194,9 +210,15 @@   (*) = Multiplication   fromInteger = Terminal . UNumber . fromInteger   abs x = ConditionalValue (MoreEqualThan x 0) (V.fromList [SelectorValue (UBoolean True) :!: x, SelectorDefault :!: negate x])-  signum x = ConditionalValue (MoreThan x 0) (V.fromList [SelectorValue (UBoolean True) :!: 1, SelectorDefault :!:-                                                         ConditionalValue (Equal x 0) (V.fromList [SelectorValue (UBoolean True) :!: 0, SelectorDefault :!: (-1)])-                                                         ])+  signum x =+    ConditionalValue+      (MoreThan x 0)+      ( V.fromList+          [ SelectorValue (UBoolean True) :!: 1,+            SelectorDefault+              :!: ConditionalValue (Equal x 0) (V.fromList [SelectorValue (UBoolean True) :!: 0, SelectorDefault :!: (-1)])+          ]+      )  instance Fractional Expression where   (/) = Division@@ -216,8 +238,10 @@   deriving (Eq, Show)  data CollectorType-  = Collector -- ^ Single angle brackets @\<|   |>@-  | ExportedCollector -- ^ Double angle brackets @\<\<|   |>>@+  = -- | Single angle brackets @\<|   |>@+    Collector+  | -- | Double angle brackets @\<\<|   |>>@+    ExportedCollector   deriving (Eq, Show)  data NodeDesc@@ -226,7 +250,6 @@   | NodeDefault   deriving (Show, Eq) - -- | Resource declaration: -- -- @ file { mode => 755} @@@ -259,7 +282,7 @@ -- * an optional inherits -- * a list of statements -- * a position-data ClassDecl  = ClassDecl !Text  !Parameters !(S.Maybe Text) !(Vector Statement) !PPosition deriving (Eq, Show)+data ClassDecl = ClassDecl !Text !Parameters !(S.Maybe Text) !(Vector Statement) !PPosition deriving (Eq, Show)  -- | Declare a define with -- * a name@@ -274,15 +297,15 @@ data NodeDecl = NodeDecl !NodeDesc !(Vector Statement) !(S.Maybe NodeDesc) !PPosition deriving (Eq, Show)  -- | @ $newvar = 'world' @-data VarAssignDecl-  = VarAssignDecl-  { _vadtype  :: Maybe UDataType-  , _vadnames  :: [Text]-  , _vadvalue :: !Expression-  , _vadpos   :: !PPosition-  } deriving (Eq, Show)+data VarAssignDecl = VarAssignDecl+  { _vadtype :: Maybe UDataType,+    _vadnames :: [Text],+    _vadvalue :: !Expression,+    _vadpos :: !PPosition+  }+  deriving (Eq, Show) -data MainFuncDecl    = MainFuncDecl !Text !(Vector Expression) !PPosition deriving (Eq, Show)+data MainFuncDecl = MainFuncDecl !Text !(Vector Expression) !PPosition deriving (Eq, Show)  -- | /Higher order function/ call. data HigherOrderLambdaDecl = HigherOrderLambdaDecl !HOLambdaCall !PPosition deriving (Eq, Show)@@ -310,7 +333,8 @@   | MainFunctionDeclaration !MainFuncDecl   | HigherOrderLambdaDeclaration !HigherOrderLambdaDecl   | DependencyDeclaration !DepDecl-  | TopContainer !(Vector Statement) !Statement -- ^ Special statement used to include the expressions that are top level. Certainly buggy, but probably just like the original implementation.+  | -- | Special statement used to include the expressions that are top level. Certainly buggy, but probably just like the original implementation.+    TopContainer !(Vector Statement) !Statement   deriving (Eq, Show)  makeClassy ''HOLambdaCall
src/Puppet/Runner.hs view
@@ -7,27 +7,32 @@ -- * a bunch of pure runners -- -- Naturally nothing from "Puppet.Runner" should be used in lower abstraction layers.-module Puppet.Runner(-  -- * Preferences-    module Puppet.Runner.Preferences-  -- * Pure-  , module Puppet.Runner.Pure-  -- * Stats-  , module Puppet.Runner.Stats-  -- * Sdlib-  , module Puppet.Runner.Stdlib-  -- * Daemon-  , module Puppet.Runner.Daemon-  -- * Re-export-  , module Puppet.Runner.Erb.Evaluate-  , module Puppet.Interpreter+module Puppet.Runner+  ( -- * Preferences+    module Puppet.Runner.Preferences,++    -- * Pure+    module Puppet.Runner.Pure,++    -- * Stats+    module Puppet.Runner.Stats,++    -- * Sdlib+    module Puppet.Runner.Stdlib,++    -- * Daemon+    module Puppet.Runner.Daemon,++    -- * Re-export+    module Puppet.Runner.Erb.Evaluate,+    module Puppet.Interpreter,   )-  where+where +import Puppet.Interpreter import Puppet.Runner.Daemon+import Puppet.Runner.Erb.Evaluate import Puppet.Runner.Preferences+import Puppet.Runner.Pure import Puppet.Runner.Stats import Puppet.Runner.Stdlib-import Puppet.Runner.Pure-import Puppet.Runner.Erb.Evaluate-import Puppet.Interpreter
src/Puppet/Runner/Daemon.hs view
@@ -1,133 +1,137 @@-{-# LANGUAGE GADTs         #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE TupleSections #-}-module Puppet.Runner.Daemon (-    Daemon(..)-  , initDaemon-) where--import           XPrelude--import qualified Data.Either.Strict          as S-import           Data.FileCache              as FileCache-import qualified Data.HashMap.Strict         as HM-import qualified Data.Text                   as Text-import           Debug.Trace                 (traceEventIO)-import           Foreign.Ruby.Safe-import qualified System.Directory            as Directory-import qualified System.Log.Formatter        as Log (simpleLogFormatter)-import qualified System.Log.Handler          as Log (setFormatter)-import qualified System.Log.Handler.Simple   as Log (streamHandler)-import qualified System.Log.Logger           as Log--import           Facter-import           Hiera.Server-import           Puppet.Runner.Daemon.FileParser-import           Puppet.Runner.Daemon.OptionalTests-import           Puppet.Runner.Erb-import           Puppet.Interpreter-import           Puppet.Parser-import           Puppet.Runner.Preferences-import           Puppet.Runner.Stats---{-| API for the Daemon.-The main method is `getCatalog`: given a node and a list of facts, it returns the result of the compilation.-This will be either an error, or a tuple containing:+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -- all the resources in this catalog-- the dependency map-- the exported resources-- a list of known resources, that might not be up to date, but are here for code coverage tests.+{-# HLINT ignore "Use <$>" #-}+module Puppet.Runner.Daemon+  ( Daemon (..),+    initDaemon,+  )+where -Notes :+import qualified Data.Either.Strict as S+import Data.FileCache as FileCache+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as Text+import Debug.Trace (traceEventIO)+import Facter+import Foreign.Ruby.Safe+import Hiera.Server+import Puppet.Interpreter+import Puppet.Parser+import Puppet.Runner.Daemon.FileParser+import Puppet.Runner.Daemon.OptionalTests+import Puppet.Runner.Erb+import Puppet.Runner.Preferences+import Puppet.Runner.Stats+import qualified System.Directory as Directory+import qualified System.Log.Formatter as Log (simpleLogFormatter)+import qualified System.Log.Handler as Log (setFormatter)+import qualified System.Log.Handler.Simple as Log (streamHandler)+import qualified System.Log.Logger as Log+import XPrelude -* It might be buggy when top level statements that are not class\/define\/nodes are altered.--}+-- | API for the Daemon.+-- The main method is `getCatalog`: given a node and a list of facts, it returns the result of the compilation.+-- This will be either an error, or a tuple containing:+--+-- - all the resources in this catalog+-- - the dependency map+-- - the exported resources+-- - a list of known resources, that might not be up to date, but are here for code coverage tests.+--+-- Notes :+--+-- * It might be buggy when top level statements that are not class\/define\/nodes are altered. data Daemon = Daemon-  { getCatalog :: NodeName -> Facts -> IO (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))-  , parserStats :: MStats-  , catalogStats :: MStats-  , templateStats :: MStats+  { getCatalog :: NodeName -> Facts -> IO (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])),+    parserStats :: MStats,+    catalogStats :: MStats,+    templateStats :: MStats   } -{-| Entry point to get a Daemon.-It will initialize the parsing and interpretation infrastructure from the 'Preferences'.--Cache the AST of every .pp file. It could use a bit of memory. As a comparison, it-fits in 60 MB with the author's manifests, but really breathes when given 300 MB-of heap space. In this configuration, even if it spawns a ruby process for every-template evaluation, it is way faster than the puppet stack.--It can optionally talk with PuppetDB, by setting an URL via the 'prefPDB'.-The recommended way to set it to http://localhost:8080 and set a SSH tunnel :--> ssh -L 8080:localhost:8080 puppet.host--}-initDaemon :: Preferences IO-           -> IO Daemon+-- | Entry point to get a Daemon.+-- It will initialize the parsing and interpretation infrastructure from the 'Preferences'.+--+-- Cache the AST of every .pp file. It could use a bit of memory. As a comparison, it+-- fits in 60 MB with the author's manifests, but really breathes when given 300 MB+-- of heap space. In this configuration, even if it spawns a ruby process for every+-- template evaluation, it is way faster than the puppet stack.+--+-- It can optionally talk with PuppetDB, by setting an URL via the 'prefPDB'.+-- The recommended way to set it to http://localhost:8080 and set a SSH tunnel :+--+-- > ssh -L 8080:localhost:8080 puppet.host+initDaemon ::+  Preferences IO ->+  IO Daemon initDaemon pref = do   setupLogger (pref ^. prefLogLevel)   logDebug "Initialize daemon"   traceEventIO "initDaemon"-  hquery      <- hieraQuery pref-  fcache      <- newFileCache-  intr        <- startRubyInterpreter-  templStats  <- newStats+  hquery <- hieraQuery pref+  fcache <- newFileCache+  intr <- startRubyInterpreter+  templStats <- newStats   getTemplate <- initTemplateDaemon intr pref templStats-  catStats    <- newStats-  parseStats  <- newStats-  pure (Daemon-         (getCatalog' pref (parseFunc (pref ^. prefPuppetPaths) fcache parseStats) getTemplate catStats hquery)-         parseStats-         catStats-         templStats-       )+  catStats <- newStats+  parseStats <- newStats+  pure+    ( Daemon+        (getCatalog' pref (parseFunc (pref ^. prefPuppetPaths) fcache parseStats) getTemplate catStats hquery)+        parseStats+        catStats+        templStats+    ) -getCatalog' :: Preferences IO-         -> ( TopLevelType -> Text -> IO (S.Either PrettyError Statement) )-         -> (TemplateSource -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text))-         -> MStats-         -> HieraQueryLayers IO-         -> NodeName-         -> Facts-         -> IO (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))+getCatalog' ::+  Preferences IO ->+  (TopLevelType -> Text -> IO (S.Either PrettyError Statement)) ->+  (TemplateSource -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text)) ->+  MStats ->+  HieraQueryLayers IO ->+  NodeName ->+  Facts ->+  IO (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) getCatalog' pref parsingfunc getTemplate stats hquery node facts = do   logDebug ("Received query for node " <> node)   traceEventIO ("START getCatalog' " <> Text.unpack node)-  let catalogComputation = interpretCatalog (InterpreterReader-                                                (pref ^. prefNatTypes)-                                                parsingfunc-                                                getTemplate-                                                (pref ^. prefPDB)-                                                (pref ^. prefExtFuncs)-                                                node-                                                hquery-                                                defaultImpureMethods-                                                (pref ^. prefIgnoredmodules)-                                                (pref ^. prefExternalmodules)-                                                (pref ^. prefStrictness == Strict)-                                                (pref ^. prefPuppetPaths)-                                                (pref ^. prefRebaseFile)-                                                ((pref ^. prefFactsOverride) `HM.union` (pref ^. prefFactsDefault))-                                            )-                                            node-                                            facts-                                            (pref ^. prefPuppetSettings)+  let catalogComputation =+        interpretCatalog+          ( InterpreterReader+              (pref ^. prefNatTypes)+              parsingfunc+              getTemplate+              (pref ^. prefPDB)+              (pref ^. prefExtFuncs)+              node+              hquery+              defaultImpureMethods+              (pref ^. prefIgnoredmodules)+              (pref ^. prefExternalmodules)+              (pref ^. prefStrictness == Strict)+              (pref ^. prefPuppetPaths)+              (pref ^. prefRebaseFile)+              ((pref ^. prefFactsOverride) `HM.union` (pref ^. prefFactsDefault))+          )+          node+          facts+          (pref ^. prefPuppetSettings)   (stmts :!: warnings) <- measure stats node catalogComputation   mapM_ (\(p :!: m) -> Log.logM loggerName p (displayS (renderCompact (ppline node <> ":" <+> m)) "")) warnings   traceEventIO ("STOP getCatalog' " <> toS node)   case stmts of     Left _ -> pure stmts -- no catalog so we can't do the extra tests-    Right r@(c,_,_,_) -> do+    Right r@(c, _, _, _) -> do       if pref ^. prefExtraTests-        then second (const r) <$> (testCatalog pref c)+        then second (const r) <$> testCatalog pref c         else pure stmts  -- Build the 'HieraQueryLayers' needed by the interpreter to lookup hiera values. hieraQuery :: Preferences IO -> IO (HieraQueryLayers IO) hieraQuery pref = do   global_api <- case pref ^. prefHieraPath of-    Just p  -> startHiera "global" p+    Just p -> startHiera "global" p     Nothing -> pure dummyHiera   env_api <- getEnvApi   mod_api <- getModApis@@ -135,29 +139,31 @@   where     getEnvApi :: IO (HieraQueryFunc IO)     getEnvApi = do-      let f =  (pref ^. prefPuppetPaths . baseDir) <> "/hiera.yaml"+      let f = (pref ^. prefPuppetPaths . baseDir) <> "/hiera.yaml"       found <- Directory.doesFileExist f       if found then startHiera "environment" f else pure dummyHiera     getModApis :: IO (Container (HieraQueryFunc IO))     getModApis = do-      let ignored_modules = pref^.prefIgnoredmodules-          modpath = pref^.prefPuppetPaths.modulesPath+      let ignored_modules = pref ^. prefIgnoredmodules+          modpath = pref ^. prefPuppetPaths . modulesPath       dirs <- Directory.listDirectory modpath-      (HM.fromList . catMaybes) <$>-        for dirs (\dir -> runMaybeT $ do-          let modname = toS dir-              fp = modpath <> "/" <> dir <> "/hiera.yaml"-          guard (modname `notElem` ignored_modules)-          guard =<< liftIO (Directory.doesFileExist fp)-          liftIO $ (modname, ) <$> startHiera "module" fp)-+      HM.fromList . catMaybes+        <$> for+          dirs+          ( \dir -> runMaybeT $ do+              let modname = toS dir+                  fp = modpath <> "/" <> dir <> "/hiera.yaml"+              guard (modname `notElem` ignored_modules)+              guard =<< liftIO (Directory.doesFileExist fp)+              liftIO $ (modname,) <$> startHiera "module" fp+          ) -defaultImpureMethods :: MonadIO m => IoMethods m+defaultImpureMethods :: (MonadIO m) => IoMethods m defaultImpureMethods =   IoMethods (liftIO currentCallStack) (liftIO . file) (liftIO . traceEventIO)   where     file [] = return $ Left ""-    file (x:xs) = (Right <$> readFile (Text.unpack x)) `catch` (\SomeException {} -> file xs)+    file (x : xs) = (Right <$> readFile (Text.unpack x)) `catch` (\SomeException {} -> file xs)  setupLogger :: Log.Priority -> IO () setupLogger p = do@@ -165,6 +171,7 @@   hs <- consoleLogHandler   Log.updateGlobalLogger Log.rootLoggerName $ Log.setHandlers [hs]   where-    consoleLogHandler = Log.setFormatter-                       <$> Log.streamHandler stdout Log.DEBUG-                       <*> pure (Log.simpleLogFormatter "$prio: $msg")+    consoleLogHandler =+      Log.setFormatter+        <$> Log.streamHandler stdout Log.DEBUG+        <*> pure (Log.simpleLogFormatter "$prio: $msg")
src/Puppet/Runner/Daemon/FileParser.hs view
@@ -1,44 +1,42 @@ {-# LANGUAGE GADTs #-}-module Puppet.Runner.Daemon.FileParser (parseFunc) where -import           XPrelude+module Puppet.Runner.Daemon.FileParser (parseFunc) where -import qualified Data.Either.Strict               as S-import           Data.FileCache                   as FileCache-import qualified Data.HashMap.Strict              as Map-import qualified Data.List                        as List-import qualified Data.Text                        as Text-import qualified Data.Text.Encoding               as Text-import qualified Data.Vector                      as V-import           Debug.Trace                      (traceEventIO)-import qualified Text.Megaparsec                  as Megaparsec+import qualified Data.Either.Strict as S+import Data.FileCache as FileCache+import qualified Data.HashMap.Strict as Map+import qualified Data.List as List+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Vector as V+import Debug.Trace (traceEventIO)+import Puppet.Interpreter+import Puppet.Parser+import Puppet.Runner.Stats+import qualified Text.Megaparsec as Megaparsec import qualified Text.Regex.PCRE.ByteString.Utils as Regex--import           Puppet.Interpreter-import           Puppet.Parser-import           Puppet.Runner.Stats+import XPrelude  -- | Return an HOF that would parse the file associated with a toplevel. -- The toplevel is defined by the tuple (type, name) -- The result of the parsing is a single Statement (which recursively contains others statements) parseFunc :: PuppetDirPaths -> FileCacheR PrettyError (V.Vector Statement) -> MStats -> TopLevelType -> Text -> IO (S.Either PrettyError Statement)-parseFunc ppath filecache stats = \toptype topname ->-  let nameparts = Text.splitOn "::" topname in-  let topLevelFilePath :: TopLevelType -> Text -> Either PrettyError Text-      topLevelFilePath TopNode _ = Right $ Text.pack (ppath^.manifestPath <> "/site.pp")-      topLevelFilePath  _ name-          | length nameparts == 1 = Right $ Text.pack (ppath^.modulesPath) <> "/" <> name <> "/manifests/init.pp"-          | null nameparts        = Left $ PrettyError ("Invalid toplevel" <+> squotes (ppline name))-          | otherwise             = Right $ Text.pack (ppath^.modulesPath) <> "/" <> List.head nameparts <> "/manifests/" <> Text.intercalate "/" (List.tail nameparts) <> ".pp"-  in-  case topLevelFilePath toptype topname of-      Left rr     -> return (S.Left rr)-      Right fname -> do+parseFunc ppath filecache stats toptype topname =+  let nameparts = Text.splitOn "::" topname+      topLevelFilePath :: TopLevelType -> Text -> Either PrettyError Text+      topLevelFilePath TopNode _ = Right $ Text.pack (ppath ^. manifestPath <> "/site.pp")+      topLevelFilePath _ name+        | length nameparts == 1 = Right $ Text.pack (ppath ^. modulesPath) <> "/" <> name <> "/manifests/init.pp"+        | null nameparts = Left $ PrettyError ("Invalid toplevel" <+> squotes (ppline name))+        | otherwise = Right $ Text.pack (ppath ^. modulesPath) <> "/" <> List.head nameparts <> "/manifests/" <> Text.intercalate "/" (List.tail nameparts) <> ".pp"+   in case topLevelFilePath toptype topname of+        Left rr -> return (S.Left rr)+        Right fname -> do           let sfname = Text.unpack fname           x <- measure stats fname (FileCache.query filecache sfname (parseFile sfname))           case x of             S.Right stmts -> filterStatements toptype topname stmts-            S.Left rr     -> return (S.Left rr)+            S.Left rr -> return (S.Left rr)  parseFile :: FilePath -> IO (S.Either PrettyError (V.Vector Statement)) parseFile fname = do@@ -60,38 +58,38 @@   let (!spurious, !directnodes, !regexpmatches, !defaultnode) = V.foldl' triage (V.empty, Map.empty, V.empty, Nothing) stmts       triage curstuff n@(NodeDeclaration (NodeDecl (NodeName !nm) _ _ _)) = curstuff & _2 . at nm ?~ n       triage curstuff n@(NodeDeclaration (NodeDecl (NodeMatch (CompRegex _ !rg)) _ _ _)) = curstuff & _3 %~ (|> (rg :!: n))-      triage curstuff n@(NodeDeclaration (NodeDecl  NodeDefault _  _ _)) = curstuff & _4 ?~ n+      triage curstuff n@(NodeDeclaration (NodeDecl NodeDefault _ _ _)) = curstuff & _4 ?~ n       triage curstuff x = curstuff & _1 %~ (|> x)       bsnodename = Text.encodeUtf8 ndename       checkRegexp :: [Pair Regex Statement] -> ExceptT PrettyError IO (Maybe Statement)       checkRegexp [] = return Nothing-      checkRegexp ((regexp  :!: s):xs) =+      checkRegexp ((regexp :!: s) : xs) =         case Regex.execute' regexp bsnodename of-          Left rr        -> throwError (PrettyError ("Regexp match error:" <+> ppline (show rr)))-          Right Nothing  -> checkRegexp xs+          Left rr -> throwError (PrettyError ("Regexp match error:" <+> ppline (show rr)))+          Right Nothing -> checkRegexp xs           Right (Just _) -> return (Just s)-      strictEither (Left x)  = S.Left x+      strictEither (Left x) = S.Left x       strictEither (Right x) = S.Right x-  in case directnodes ^. at ndename of -- check if there is a node specifically called after my name-       Just r  -> return (S.Right (TopContainer spurious r))-       Nothing -> fmap strictEither $ runExceptT $ do-         regexpMatchM <- checkRegexp (V.toList regexpmatches) -- match regexps-         case regexpMatchM <|> defaultnode of -- check for regexp matches or use the default node-           Just r  -> return (TopContainer spurious r)-           Nothing -> throwError (PrettyError ("Couldn't find node" <+> ppline ndename))+   in case directnodes ^. at ndename of -- check if there is a node specifically called after my name+        Just r -> return (S.Right (TopContainer spurious r))+        Nothing -> fmap strictEither $ runExceptT $ do+          regexpMatchM <- checkRegexp (V.toList regexpmatches) -- match regexps+          case regexpMatchM <|> defaultnode of -- check for regexp matches or use the default node+            Just r -> return (TopContainer spurious r)+            Nothing -> throwError (PrettyError ("Couldn't find node" <+> ppline ndename)) filterStatements x ndename stmts =   let (!spurious, !defines, !classes) = V.foldl' triage (V.empty, Map.empty, Map.empty) stmts       triage curstuff n@(ClassDeclaration (ClassDecl cname _ _ _ _)) = curstuff & _3 . at cname ?~ n       triage curstuff n@(DefineDeclaration (DefineDecl cname _ _ _)) = curstuff & _2 . at cname ?~ n       triage curstuff n = curstuff & _1 %~ (|> n)-      tc n = if V.null spurious-               then n-               else TopContainer spurious n-  in  case x of-        TopNode -> return (S.Left "Case already covered, shoudln't happen in Puppet.Manifests")+      tc n =+        if V.null spurious+          then n+          else TopContainer spurious n+   in case x of         TopDefine -> case defines ^. at ndename of-          Just n  -> return (S.Right (tc n))+          Just n -> return (S.Right (tc n))           Nothing -> return (S.Left (PrettyError ("Couldn't find define " <+> ppline ndename)))         TopClass -> case classes ^. at ndename of-          Just n  -> return (S.Right (tc n))+          Just n -> return (S.Right (tc n))           Nothing -> return (S.Left (PrettyError ("Couldn't find class " <+> ppline ndename)))
src/Puppet/Runner/Daemon/OptionalTests.hs view
@@ -1,24 +1,22 @@ -- | The module accumulates 'PrettyError's in the ExceptT monad transformer. module Puppet.Runner.Daemon.OptionalTests (testCatalog) where -import           XPrelude--import qualified Data.HashSet              as Set-import qualified Data.Text                 as Text-import qualified System.Directory          as Directory--import           Puppet.Language-import           Puppet.Runner.Preferences-+import qualified Data.HashSet as Set+import qualified Data.Text as Text+import Puppet.Language+import Puppet.Runner.Preferences+import qualified System.Directory as Directory+import XPrelude  -- | Entry point for all optional tests-testCatalog :: Preferences IO-            -> FinalCatalog-            -> IO (Either PrettyError ())+testCatalog ::+  Preferences IO ->+  FinalCatalog ->+  IO (Either PrettyError ()) testCatalog prefs c =-  runExceptT-    $  testFileSources (prefs ^. prefPuppetPaths.baseDir) c-    *> testUsersGroups (prefs ^. prefKnownusers) (prefs ^. prefKnowngroups) c+  runExceptT $+    testFileSources (prefs ^. prefPuppetPaths . baseDir) c+      *> testUsersGroups (prefs ^. prefKnownusers) (prefs ^. prefKnowngroups) c  -- | Tests that all users and groups are defined testUsersGroups :: [Text] -> [Text] -> FinalCatalog -> ExceptT PrettyError IO ()@@ -27,43 +25,51 @@       groups = Set.fromList $ "" : "0" : map (view (rid . iname)) (getResourceFrom "group") ++ kgroups       checkResource lu lg = mapM_ (checkResource' lu lg)       checkResource' lu lg res = do-          let msg att name = align (vsep [ "Resource" <+> ppline (res^.rid.itype)-                                           <+> ppline (res^.rid.iname) <+> showPos (res^.rpos._1)-                                         , "references the unknown" <+> att <+> squotes (ppline name)])-                             <> line-          case lu of-              Just lu' -> do-                  let u = res ^. rattributes . lu' . _PString-                  unless (Set.member u users) $ throwE $ PrettyError (msg "user" u)-              Nothing -> pure ()-          case lg of-              Just lg' -> do-                  let g = res ^. rattributes . lg' . _PString-                  unless (Set.member g groups) $ throwE $ PrettyError (msg "group" g)-              Nothing -> pure ()+        let msg att name =+              align+                ( vsep+                    [ "Resource"+                        <+> ppline (res ^. rid . itype)+                        <+> ppline (res ^. rid . iname)+                        <+> showPos (res ^. rpos . _1),+                      "references the unknown" <+> att <+> squotes (ppline name)+                    ]+                )+                <> line+        case lu of+          Just lu' -> do+            let u = res ^. rattributes . lu' . _PString+            unless (Set.member u users) $ throwE $ PrettyError (msg "user" u)+          Nothing -> pure ()+        case lg of+          Just lg' -> do+            let g = res ^. rattributes . lg' . _PString+            unless (Set.member g groups) $ throwE $ PrettyError (msg "group" g)+          Nothing -> pure ()   do-      checkResource (Just $ ix "owner") (Just $ ix "group") (getResourceFrom "file")-      checkResource (Just $ ix "user")  (Just $ ix "group") (getResourceFrom "exec")-      checkResource (Just $ ix "user")  Nothing             (getResourceFrom "cron")-      checkResource (Just $ ix "user")  Nothing             (getResourceFrom "ssh_authorized_key")-      checkResource (Just $ ix "user")  Nothing             (getResourceFrom "ssh_authorized_key_secure")-      checkResource Nothing             (Just $ ix "gid")   (getResourceFrom "users")+    checkResource (Just $ ix "owner") (Just $ ix "group") (getResourceFrom "file")+    checkResource (Just $ ix "user") (Just $ ix "group") (getResourceFrom "exec")+    checkResource (Just $ ix "user") Nothing (getResourceFrom "cron")+    checkResource (Just $ ix "user") Nothing (getResourceFrom "ssh_authorized_key")+    checkResource (Just $ ix "user") Nothing (getResourceFrom "ssh_authorized_key_secure")+    checkResource Nothing (Just $ ix "gid") (getResourceFrom "users")   where     getResourceFrom t = c ^.. traverse . filtered (\r -> r ^. rid . itype == t && r ^. rattributes . at "ensure" /= Just "absent")  -- | Test source for every file resources in the catalog. testFileSources :: FilePath -> FinalCatalog -> ExceptT PrettyError IO () testFileSources basedir c = do-    let getfiles = filter presentFile . toList-        presentFile r = r ^. rid . itype == "file"-                        && (r ^. rattributes . at "ensure") `elem` [Nothing, Just "present"]-                        && r ^. rattributes . at "source" /= Just PUndef-        recurse r = case r ^? rattributes . ix "recurse" of-                      Just (PString "true") -> True-                      Just (PBoolean b) -> b-                      _ -> False-        getsource = mapMaybe (\r -> (,,) <$> pure r <*> r ^. rattributes . at "source" <*> pure (recurse r))-    checkAllSources basedir $ (getsource . getfiles) c+  let getfiles = filter presentFile . toList+      presentFile r =+        r ^. rid . itype == "file"+          && (r ^. rattributes . at "ensure") `elem` [Nothing, Just "present"]+          && r ^. rattributes . at "source" /= Just PUndef+      recurse r = case r ^? rattributes . ix "recurse" of+        Just (PString "true") -> True+        Just (PBoolean b) -> b+        _ -> False+      getsource = mapMaybe (\r -> (,,) r <$> r ^. rattributes . at "source" <*> pure (recurse r))+  checkAllSources basedir $ (getsource . getfiles) c  -- | Check source for all file resources and append failures along. checkAllSources :: FilePath -> [(Resource, PValue, Bool)] -> ExceptT PrettyError IO ()@@ -74,25 +80,35 @@   go fs []   where     go :: [(Resource, PValue, Bool)] -> [PrettyError] -> ExceptT PrettyError IO ()-    go ((res, filesrc, recurse):xs) es = ExceptT $ do+    go ((res, filesrc, recurse) : xs) es = ExceptT $ do       runExceptT (checkFile fp filesrc recurse) >>= \case         Right () -> runExceptT $ go xs es         Left err ->-          runExceptT-          $ go xs ((PrettyError $ align (vsep [ "Could not find" <+> pretty filesrc-                                              , getError err-                                              , showPos (res^.rpos^._1)-                                              ])):es)+          runExceptT $+            go+              xs+              ( PrettyError+                  ( align+                      ( vsep+                          [ "Could not find" <+> pretty filesrc,+                            getError err,+                            showPos (res ^. (rpos . _1))+                          ]+                      )+                  )+                  : es+              )     go [] [] = pure ()     go [] es = throwE (mconcat es)  testFile :: Bool -> FilePath -> ExceptT PrettyError IO () testFile recurse fp = do-    p <-  liftIO (Directory.doesFileExist fp)-    p' <- if recurse && not p-            then liftIO (Directory.doesDirectoryExist fp)-            else return p-    unless p' (throwE $ PrettyError $ "searched in" <+> squotes (pptext fp))+  p <- liftIO (Directory.doesFileExist fp)+  p' <-+    if recurse && not p+      then liftIO (Directory.doesDirectoryExist fp)+      else return p+  unless p' (throwE $ PrettyError $ "searched in" <+> squotes (pptext fp))  -- | Only test the `puppet:///` protocol (files managed by the puppet server) --   we don't test absolute path (puppet client files)@@ -100,11 +116,11 @@ checkFile basedir (PString f) recurse =   case Text.stripPrefix "puppet:///" f of     Just stringdir -> case Text.splitOn "/" stringdir of-        ("modules":modname:rest) -> testFile recurse (basedir <> "/modules/" <> toS modname <> "/files/" <> toS (Text.intercalate "/" rest))-        ("files":rest)           -> testFile recurse (basedir <> "/files/" <> toS (Text.intercalate "/" rest))-        ("private":_)            -> pure ()-        _                        -> throwE (PrettyError $ "Invalid file source:" <+> ppline f)-    Nothing        -> return ()+      ("modules" : modname : rest) -> testFile recurse (basedir <> "/modules/" <> toS modname <> "/files/" <> toS (Text.intercalate "/" rest))+      ("files" : rest) -> testFile recurse (basedir <> "/files/" <> toS (Text.intercalate "/" rest))+      ("private" : _) -> pure ()+      _ -> throwE (PrettyError $ "Invalid file source:" <+> ppline f)+    Nothing -> return () -- source is always an array of possible paths. We only fails if none of them check.-checkFile basedir (PArray xs) recurse  = asum [checkFile basedir x recurse | x <- toList xs]+checkFile basedir (PArray xs) recurse = asum [checkFile basedir x recurse | x <- toList xs] checkFile _ x _ = throwE (PrettyError $ "Source was not a string, but" <+> pretty x)
src/Puppet/Runner/Erb.hs view
@@ -1,48 +1,45 @@-{-# LANGUAGE NamedFieldPuns #-} -- | Internal module used to initialize the erb template daemon.-module Puppet.Runner.Erb (-     initTemplateDaemon-   , rubyEvaluate-) where--import           XPrelude--import qualified Data.Either.Strict         as S-import qualified Data.FileCache             as Cache-import qualified Data.List                  as List-import qualified Data.List.Split            as List-import qualified Data.Text                  as Text-import           Data.Tuple.Strict          (Pair (..))-import qualified Data.Vector                as Vector-import           Debug.Trace-import           Foreign.Ruby-import qualified Foreign.Ruby.Bindings      as FR-import qualified Foreign.Ruby.Helpers       as FR-import           GHC.Conc                   (labelThread)-import           Paths_language_puppet      (getDataFileName)-import           System.Environment         (getExecutablePath)-import           System.FilePath-import           System.Posix.Files-import           Text.Parsec                hiding (string)-import           Text.Parsec.Error-import           Text.Parsec.Pos--import           Erb-import           Puppet.Interpreter.Helpers-import           Puppet.Interpreter.IO-import           Puppet.Interpreter.Resolve-import           Puppet.Interpreter.Types-import           Puppet.Runner.Erb.Evaluate-import           Puppet.Runner.Preferences-import           Puppet.Runner.Stats+module Puppet.Runner.Erb+  ( initTemplateDaemon,+    rubyEvaluate,+  )+where +import qualified Data.Either.Strict as S+import qualified Data.FileCache as Cache+import qualified Data.List as List+import qualified Data.List.Split as List+import qualified Data.Text as Text+import qualified Data.Vector as Vector+import Debug.Trace+import Erb+import Foreign.Ruby+import qualified Foreign.Ruby.Bindings as FR+import qualified Foreign.Ruby.Helpers as FR+import GHC.Conc (labelThread)+import Paths_language_puppet (getDataFileName)+import Puppet.Interpreter.Helpers+import Puppet.Interpreter.IO+import Puppet.Interpreter.Resolve+import Puppet.Interpreter.Types+import Puppet.Runner.Erb.Evaluate+import Puppet.Runner.Preferences+import Puppet.Runner.Stats+import System.Environment (getExecutablePath)+import System.FilePath+import System.Posix.Files+import Text.Parsec hiding (string)+import Text.Parsec.Error+import Text.Parsec.Pos+import XPrelude  instance IsString TemplateParseError where   fromString s = TemplateParseError $ newErrorMessage (Message s) (initialPos mempty) -newtype TemplateParseError = TemplateParseError { tgetError :: ParseError }+newtype TemplateParseError = TemplateParseError {tgetError :: ParseError}  type TemplateQuery = (Chan TemplateAnswer, TemplateSource, InterpreterState, InterpreterReader IO)+ type TemplateAnswer = S.Either PrettyError Text  showRubyError :: RubyError -> PrettyError@@ -51,10 +48,11 @@ showRubyError (OtherError rr) = PrettyError (dullred (pptext rr))  -- | Parse and resolve erb files. Initializes a thread for the Ruby interpreter .-initTemplateDaemon :: RubyInterpreter-                   -> Preferences IO-                   -> MStats-                   -> IO (TemplateSource -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text))+initTemplateDaemon ::+  RubyInterpreter ->+  Preferences IO ->+  MStats ->+  IO (TemplateSource -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text)) initTemplateDaemon rubyintp prefs mvstats = do   controlchan <- newChan   templatecache <- Cache.newFileCache@@ -63,12 +61,16 @@     liftIO (getRubyScriptPath "hrubyerb.rb") >>= ExceptT . loadFile rubyintp     ExceptT (registerGlobalFunction4 rubyintp "varlookup" hrresolveVariable)     ExceptT (registerGlobalFunction5 rubyintp "callextfunc" hrcallfunction)-    liftIO $ void $ forkIO $ templateDaemon rubyintp-                                            (prefs ^. prefPuppetPaths.modulesPath)-                                            (prefs ^. prefPuppetPaths.templatesPath)-                                            controlchan-                                            mvstats-                                            templatecache+    liftIO $+      void $+        forkIO $+          templateDaemon+            rubyintp+            (prefs ^. prefPuppetPaths . modulesPath)+            (prefs ^. prefPuppetPaths . templatesPath)+            controlchan+            mvstats+            templatecache     pure $! templateQuery controlchan   either returnError pure x @@ -87,10 +89,12 @@   case fileinfo of     Filename filename -> do       let prts = List.splitOn "/" filename-          searchpathes | length prts > 1 = [ modpath </> List.head prts </> "templates" </> List.intercalate "/" (List.tail prts)-                                           , templatepath </> filename-                                           ]-                       | otherwise        = [templatepath </> filename]+          searchpathes+            | length prts > 1 =+                [ modpath </> List.head prts </> "templates" </> List.intercalate "/" (List.tail prts),+                  templatepath </> filename+                ]+            | otherwise = [templatepath </> filename]       acceptablefiles <- filterM fileExist searchpathes       if null acceptablefiles         then writeChan respchan (S.Left $ PrettyError $ "Can't find template file for" <+> pptext filename <+> ", looked in" <+> list (map pptext searchpathes))@@ -102,16 +106,17 @@ computeTemplate rubyintp srcinfo intpstate intpreader mstats filecache = do   let (curcontext, fvariables) =         case extractScope intpstate of-          Nothing    -> (mempty, mempty)-          Just (c,v) -> (c,v)+          Nothing -> (mempty, mempty)+          Just (c, v) -> (c, v)       template_src = templateSrc srcinfo-      mkSafe a = makeSafe rubyintp a >>= \case-        Left err -> return (S.Left (showRubyError err))-        Right x -> return x+      mkSafe a =+        makeSafe rubyintp a >>= \case+          Left err -> return (S.Left (showRubyError err))+          Right x -> return x       encapsulateError = _Left %~ TemplateParseError       variables = fvariables & traverse . scopeVariables . traverse . _1 . _1 %~ toStr       toStr (PNumber n) = PString (scientific2text n)-      toStr x           = x+      toStr x = x   traceEventIO ("START template " <> template_src)   parsed <- case srcinfo of     Filename _ -> measure mstats ("parsing - " <> toS template_src) $ Cache.lazyQuery filecache template_src $ fmap encapsulateError (parseErbFile template_src)@@ -125,8 +130,8 @@     Right ast -> case rubyEvaluate variables curcontext ast of       Right ev -> pure (S.Right ev)       Left err -> do-        let !msg = "At " <> showPPos'(intpstate^.curPos) <> " the evaluation of template '" <> template_src <> "' failed. " <> show err-      -- if the haskell evaluation fails the ruby one will fallback. It is likely that the reason for the failure is a real template issue.+        let !msg = "At " <> showPPos' (intpstate ^. curPos) <> " the evaluation of template '" <> template_src <> "' failed. " <> show err+        -- if the haskell evaluation fails the ruby one will fallback. It is likely that the reason for the failure is a real template issue.         logErrorStr msg         measure mstats ("ruby efail - " <> toS template_src) $ mkSafe $ computeTemplateWRuby srcinfo curcontext variables intpstate intpreader   traceEventIO ("STOP template " <> template_src)@@ -135,10 +140,7 @@ getRubyScriptPath :: String -> IO String getRubyScriptPath rubybin = do   let checkpath :: FilePath -> IO FilePath -> IO FilePath-      checkpath fp nxt =-        ifM (fileExist fp)-          (pure fp)-          nxt+      checkpath fp = ifM (fileExist fp) (pure fp)       withExecutablePath = do         path <- fmap takeDirectory getExecutablePath         let fullpath = path </> rubybin@@ -155,13 +157,13 @@   toresolve <- FR.fromRuby rtoresolve   let answer = case toresolve of         Right "~g~e~t_h~a~s~h~" ->-           let getvars ctx = (variables ^. ix ctx . scopeVariables) & traverse %~ view (_1 . _1)-               vars = getvars "::" <> getvars scope-           in  Right (PHash vars)+          let getvars ctx = (variables ^. ix ctx . scopeVariables) & traverse %~ view (_1 . _1)+              vars = getvars "::" <> getvars scope+           in Right (PHash vars)         Right t -> getVariable variables scope t         Left err -> Left ("The variable name is not a string" <+> pptext err)   case answer of-    Left _  -> getSymbol "undef"+    Left _ -> getSymbol "undef"     Right r -> FR.toRuby r  hrcallfunction :: RValue -> RValue -> RValue -> RValue -> RValue -> IO RValue@@ -171,21 +173,22 @@   rdr <- FR.extractHaskellValue rrdr   stt <- FR.extractHaskellValue rstt   let rubyerr :: String -> IO RValue-      rubyerr err = fmap (either snd identity) (FR.toRuby (Text.pack err) >>= FR.safeMethodCall "MyError" "new" . (:[]))+      rubyerr err = fmap (either snd identity) (FR.toRuby (Text.pack err) >>= FR.safeMethodCall "MyError" "new" . (: []))   case (,) <$> efname <*> eargs of-    Right (fname, varray) | fname `elem` ["template", "inline_template"] -> do-      logWarning $ "Can't parse a call to the external ruby function '" <> fname <> "'  n an erb file.\n\tIt is not possible to call it from a Ruby function. It would stall (yes it sucks ...).\n\tChoosing to output \"undef\" !"-      getSymbol "undef"-                          | otherwise -> do-      let args = case varray of-            [PArray vargs] -> Vector.toList vargs-            _              -> varray-      (x,_,_) <- interpretMonad rdr stt (resolveFunction' fname args)-      case x of-        Right o -> case o ^? _PValueNumber of-          Just n  -> FR.toRuby n-          Nothing -> FR.toRuby o-        Left err -> rubyerr (show err)+    Right (fname, varray)+      | fname `elem` ["template", "inline_template"] -> do+          logWarning $ "Can't parse a call to the external ruby function '" <> fname <> "'  n an erb file.\n\tIt is not possible to call it from a Ruby function. It would stall (yes it sucks ...).\n\tChoosing to output \"undef\" !"+          getSymbol "undef"+      | otherwise -> do+          let args = case varray of+                [PArray vargs] -> Vector.toList vargs+                _ -> varray+          (x, _, _) <- interpretMonad rdr stt (resolveFunction' fname args)+          case x of+            Right o -> case o ^? _PValueNumber of+              Just n -> FR.toRuby n+              Nothing -> FR.toRuby o+            Left err -> rubyerr (show err)     Left err -> rubyerr err  computeTemplateWRuby :: TemplateSource -> Text -> Container ScopeInformation -> InterpreterState -> InterpreterReader IO -> IO TemplateAnswer@@ -198,18 +201,18 @@   -- must be called from a "makeSafe" thingie   contentinfo <- case fileinfo of     Filename fname -> FR.toRuby (Text.pack fname)-    Inline _      -> FR.toRuby ("-" :: Text)+    Inline _ -> FR.toRuby ("-" :: Text)   let withBinding f =-        FR.safeMethodCall "ErbBinding" "new" [rscp,rvariables,rstt,rrdr,contentinfo] >>= \case+        FR.safeMethodCall "ErbBinding" "new" [rscp, rvariables, rstt, rrdr, contentinfo] >>= \case           Left x -> pure (Left x)           Right v -> do-           forM_ (itoList varlist) $ \(varname, varval :!: _ :!: _) -> FR.toRuby varval >>= FR.rb_iv_set v (toS varname)-           f v+            forM_ (itoList varlist) $ \(varname, (varval :!: _) :!: _) -> FR.toRuby varval >>= FR.rb_iv_set v (toS varname)+            f v   o <- case fileinfo of-    Filename fname  -> do+    Filename fname -> do       rfname <- FR.toRuby (Text.pack fname)-      withBinding $ \v -> FR.safeMethodCall "Controller" "runFromFile" [rfname,v]-    Inline content -> withBinding $ \v -> FR.toRuby content >>= FR.safeMethodCall "Controller" "runFromContent" . (:[v])+      withBinding $ \v -> FR.safeMethodCall "Controller" "runFromFile" [rfname, v]+    Inline content -> withBinding $ \v -> FR.toRuby content >>= FR.safeMethodCall "Controller" "runFromContent" . (: [v])   FR.freeHaskellValue rrdr   FR.freeHaskellValue rstt   FR.freeHaskellValue rvariables@@ -217,15 +220,16 @@   case o of     Left (err, _) ->       pure (S.Left $ PrettyError (dullred (pptext err) <+> "in" <+> dullgreen (pptext (templateSrc fileinfo))))-    Right r -> FR.fromRuby r >>= \case-      Right result -> pure (S.Right result)-      Left err -> pure (S.Left $ PrettyError ("Could not deserialiaze ruby output" <+> pptext err))+    Right r ->+      FR.fromRuby r >>= \case+        Right result -> pure (S.Right result)+        Left err -> pure (S.Left $ PrettyError ("Could not deserialiaze ruby output" <+> pptext err))  eitherDocIO :: IO (S.Either PrettyError a) -> IO (S.Either PrettyError a) eitherDocIO computation =   (computation >>= check) `catch` (\e -> pure $ S.Left $ PrettyError $ dullred $ ppline $ show (e :: SomeException))   where-    check (S.Left r)  = pure (S.Left r)+    check (S.Left r) = pure (S.Left r)     check (S.Right x) = pure (S.Right x)  templateSrc :: TemplateSource -> String
src/Puppet/Runner/Erb/Evaluate.hs view
@@ -1,47 +1,47 @@ -- | Private module. Evaluates a ruby template from what's generated by "Erb.Parser".-module Puppet.Runner.Erb.Evaluate (-    rubyEvaluate-  ) where--import           XPrelude+module Puppet.Runner.Erb.Evaluate+  ( rubyEvaluate,+  )+where -import qualified Data.Char           as Char+import qualified Data.Char as Char import qualified Data.HashMap.Strict as HM-import qualified Data.Text           as Text-import qualified Data.Vector         as V--import           Erb.Ruby-import           Puppet.Interpreter+import qualified Data.Text as Text+import qualified Data.Vector as V+import Erb.Ruby+import Puppet.Interpreter+import XPrelude  type ScopeName = Text  -- | Evaluate a list of ruby statements.-rubyEvaluate :: Container ScopeInformation-             -> ScopeName-             -> [RubyStatement]-             -> Either Doc Text+rubyEvaluate ::+  Container ScopeInformation ->+  ScopeName ->+  [RubyStatement] ->+  Either Doc Text rubyEvaluate vars ctx = foldl (evalruby vars ctx) (Right "") . optimize   where-    optimize []                             = []+    optimize [] = []     optimize (Puts x : DropPrevSpace' : xs) = optimize $ DropPrevSpace (Puts x) : xs-    optimize (x:xs)                         = x : optimize xs+    optimize (x : xs) = x : optimize xs  spaceNotCR :: Char -> Bool spaceNotCR c = Char.isSpace c && c /= '\n' && c /= '\r'  evalruby :: Container ScopeInformation -> ScopeName -> Either Doc Text -> RubyStatement -> Either Doc Text-evalruby _  _   (Left err)     _        = Left err-evalruby _ _  (Right _) (DropPrevSpace') = Left "Could not evaluate a non optimize DropPrevSpace'"+evalruby _ _ (Left err) _ = Left err+evalruby _ _ (Right _) DropPrevSpace' = Left "Could not evaluate a non optimize DropPrevSpace'" evalruby mp ctx (Right curstr) (DropNextSpace x) =   case evalruby mp ctx (Right curstr) x of     Left err -> Left err-    Right y  -> Right (Text.dropWhile spaceNotCR y)+    Right y -> Right (Text.dropWhile spaceNotCR y) evalruby mp ctx (Right curstr) (DropPrevSpace x) =   case evalruby mp ctx (Right curstr) x of     Left err -> Left err-    Right y  -> Right (Text.dropWhileEnd spaceNotCR y)+    Right y -> Right (Text.dropWhileEnd spaceNotCR y) evalruby mp ctx (Right curstr) (Puts e) =-  case (evalExpression mp ctx e >>= evalValue) of+  case evalExpression mp ctx e >>= evalValue of     Left err -> Left err     Right ex -> Right (curstr <> ex) @@ -53,10 +53,10 @@     PArray arr ->       case idx ^? _PValueInteger of         Nothing -> Left $ "Can't convert index to integer when resolving" <+> pretty val <> brackets (pretty idx)-        Just i  ->+        Just i ->           if fromIntegral (V.length arr) <= i-          then Left $ "Array out of bound" <+> pretty val <> brackets (pretty idx)-          else Right (arr V.! fromIntegral i)+            then Left $ "Array out of bound" <+> pretty val <> brackets (pretty idx)+            else Right (arr V.! fromIntegral i)     PHash hs ->       case idx of         PString idx' ->@@ -65,25 +65,23 @@             _ -> Left $ "Can't index variable" <+> pretty val <+> ", it is " <+> pretty (PHash hs)         _ -> Left $ "Can't index variable" <+> pretty val <+> ", it is " <+> pretty (PHash hs)     unexpectedval -> Left $ "Can't index variable" <+> pretty val <+> ", it is " <+> pretty unexpectedval--evalExpression _  _   (Value (Literal x))          = Right (PString x)+evalExpression _ _ (Value (Literal x)) = Right (PString x) evalExpression mp ctx (ScopeObject (Value (Literal x))) = getVariable mp ctx x evalExpression mp ctx (Object (Value (Literal x))) = do   case Text.stripPrefix "@" x of     Nothing -> Left $ "Erb variables '" <> ppline x <> "' should be prefixed by '@' in puppet version 4 and above."     Just x' -> getVariable mp ctx x'--evalExpression _  _   x = Left $ "Can't evaluate" <+> pretty x+evalExpression _ _ x = Left $ "Can't evaluate" <+> pretty x  evalValue :: PValue -> Either Doc Text evalValue = go False   where     go escaped p = case p of-      PString x      -> Right $ if escaped then show x else x-      PNumber x      -> Right (scientific2text x)-      PUndef         -> Right "nil"-      PBoolean True  -> Right "true"+      PString x -> Right $ if escaped then show x else x+      PNumber x -> Right (scientific2text x)+      PUndef -> Right "nil"+      PBoolean True -> Right "true"       PBoolean False -> Right "false"-      PArray lst     -> fmap (\c -> "[" <> Text.intercalate ", " c <> "]") (mapM (go True) (V.toList lst))-      PHash hash     -> fmap (\l -> "{" <> Text.intercalate ", " (map (\(k,v) -> show k <> "=>" <> v) l) <> "}") (mapM (traverse (go True)) (HM.toList hash))-      _              -> Left ("Can't display the ruby equivalent of" <+> pretty p)+      PArray lst -> fmap (\c -> "[" <> Text.intercalate ", " c <> "]") (mapM (go True) (V.toList lst))+      PHash hash -> fmap (\l -> "{" <> Text.intercalate ", " (map (\(k, v) -> show k <> "=>" <> v) l) <> "}") (mapM (traverse (go True)) (HM.toList hash))+      _ -> Left ("Can't display the ruby equivalent of" <+> pretty p)
src/Puppet/Runner/Preferences.hs view
@@ -1,150 +1,156 @@ {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE TemplateHaskell        #-}-module Puppet.Runner.Preferences (-   Preferences(Preferences)-  , prefPuppetPaths-  , prefPDB-  , prefNatTypes-  , prefExtFuncs-  , prefHieraPath-  , prefIgnoredmodules-  , prefStrictness-  , prefExtraTests-  , prefKnownusers-  , prefKnowngroups-  , prefExternalmodules-  , prefPuppetSettings-  , prefFactsOverride-  , prefFactsDefault-  , prefLogLevel-  , prefRebaseFile-  , dfPreferences-  , PuppetDirPaths-  , HasPuppetDirPaths(..)-) where--import           XPrelude+{-# LANGUAGE TemplateHaskell #-} -import           Data.Aeson-import qualified Data.HashMap.Strict      as HM-import qualified Data.HashSet             as HS-import qualified Data.List                as List-import qualified Data.Text                as Text-import qualified Data.Yaml                as Yaml-import qualified System.Directory         as Directory-import qualified System.FilePath          as FilePath-import qualified System.Log.Logger        as LOG+module Puppet.Runner.Preferences+  ( Preferences (Preferences),+    prefPuppetPaths,+    prefPDB,+    prefNatTypes,+    prefExtFuncs,+    prefHieraPath,+    prefIgnoredmodules,+    prefStrictness,+    prefExtraTests,+    prefKnownusers,+    prefKnowngroups,+    prefExternalmodules,+    prefPuppetSettings,+    prefFactsOverride,+    prefFactsDefault,+    prefLogLevel,+    prefRebaseFile,+    dfPreferences,+    PuppetDirPaths,+    HasPuppetDirPaths (..),+  )+where -import           Puppet.Interpreter+import Data.Aeson+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.List as List+import qualified Data.Text as Text+import qualified Data.Yaml as Yaml+import Puppet.Interpreter import qualified Puppet.Runner.Puppetlabs as Puppetlabs-import           Puppet.Runner.Stdlib-import           PuppetDB+import Puppet.Runner.Stdlib+import PuppetDB+import qualified System.Directory as Directory+import qualified System.FilePath as FilePath+import qualified System.Log.Logger as LOG+import XPrelude  data Preferences m = Preferences-  { _prefPuppetPaths     :: PuppetDirPaths-  , _prefPDB             :: PuppetDBAPI m-  , _prefNatTypes        :: Container NativeTypeMethods -- ^ The list of native types.-  , _prefExtFuncs        :: Container ([PValue] -> InterpreterMonad PValue)-  , _prefHieraPath       :: Maybe FilePath-  , _prefIgnoredmodules  :: HS.HashSet Text-  , _prefStrictness      :: Strictness-  , _prefExtraTests      :: Bool-  , _prefKnownusers      :: [Text]-  , _prefKnowngroups     :: [Text]-  , _prefExternalmodules :: HS.HashSet Text-  , _prefPuppetSettings  :: Container Text -- ^ Puppet server settings-  , _prefFactsOverride   :: Container PValue-  , _prefFactsDefault    :: Container PValue-  , _prefLogLevel        :: LOG.Priority-  , _prefRebaseFile      :: Maybe FilePath -- ^ Make all calls to file() with absolute pathes relative to the given path.+  { _prefPuppetPaths :: PuppetDirPaths,+    _prefPDB :: PuppetDBAPI m,+    -- | The list of native types.+    _prefNatTypes :: Container NativeTypeMethods,+    _prefExtFuncs :: Container ([PValue] -> InterpreterMonad PValue),+    _prefHieraPath :: Maybe FilePath,+    _prefIgnoredmodules :: HS.HashSet Text,+    _prefStrictness :: Strictness,+    _prefExtraTests :: Bool,+    _prefKnownusers :: [Text],+    _prefKnowngroups :: [Text],+    _prefExternalmodules :: HS.HashSet Text,+    -- | Puppet server settings+    _prefPuppetSettings :: Container Text,+    _prefFactsOverride :: Container PValue,+    _prefFactsDefault :: Container PValue,+    _prefLogLevel :: LOG.Priority,+    -- | Make all calls to file() with absolute pathes relative to the given path.+    _prefRebaseFile :: Maybe FilePath   }  data Defaults = Defaults-  { _dfKnownusers      :: Maybe [Text]-  , _dfKnowngroups     :: Maybe [Text]-  , _dfIgnoredmodules  :: Maybe [Text]-  , _dfStrictness      :: Maybe Strictness-  , _dfExtratests      :: Maybe Bool-  , _dfExternalmodules :: Maybe [Text]-  , _dfPuppetSettings  :: Maybe (Container Text)-  , _dfFactsDefault    :: Maybe (Container PValue)-  , _dfFactsOverride   :: Maybe (Container PValue)-  , _dfRebaseFile      :: Maybe FilePath-  } deriving (Show)-+  { _dfKnownusers :: Maybe [Text],+    _dfKnowngroups :: Maybe [Text],+    _dfIgnoredmodules :: Maybe [Text],+    _dfStrictness :: Maybe Strictness,+    _dfExtratests :: Maybe Bool,+    _dfExternalmodules :: Maybe [Text],+    _dfPuppetSettings :: Maybe (Container Text),+    _dfFactsDefault :: Maybe (Container PValue),+    _dfFactsOverride :: Maybe (Container PValue),+    _dfRebaseFile :: Maybe FilePath+  }+  deriving (Show)  makeLenses ''Preferences  instance FromJSON Defaults where-  parseJSON (Object v) = Defaults-                         <$> v .:? "knownusers"-                         <*> v .:? "knowngroups"-                         <*> v .:? "ignoredmodules"-                         <*> v .:? "strict"-                         <*> v .:? "extratests"-                         <*> v .:? "externalmodules"-                         <*> v .:? "settings"-                         <*> v .:? "factsdefault"-                         <*> v .:? "factsoverride"-                         <*> v .:? "rebasefile"+  parseJSON (Object v) =+    Defaults+      <$> v .:? "knownusers"+      <*> v .:? "knowngroups"+      <*> v .:? "ignoredmodules"+      <*> v .:? "strict"+      <*> v .:? "extratests"+      <*> v .:? "externalmodules"+      <*> v .:? "settings"+      <*> v .:? "factsdefault"+      <*> v .:? "factsoverride"+      <*> v .:? "rebasefile"   parseJSON _ = mzero  -- | Generate default preferences.-dfPreferences :: FilePath-               -> IO (Preferences IO)+dfPreferences ::+  FilePath ->+  IO (Preferences IO) dfPreferences basedir = do-    let dirpaths = puppetPaths basedir-        modulesdir = dirpaths ^. modulesPath-        testdir = dirpaths ^. testPath-        hierafile = basedir <> "/hiera.yaml"-        defaultfile = testdir <> "/defaults.yaml"-    defaults <- ifM (Directory.doesFileExist defaultfile) (Yaml.decodeFileThrow defaultfile) (pure Nothing)-    hieradir <- ifM (Directory.doesFileExist hierafile) (pure $ Just hierafile) (pure Nothing)-    loadedtypes <- loadedTypes modulesdir-    labsFunctions <- Puppetlabs.extFunctions modulesdir-    return $ Preferences dirpaths-                         dummyPuppetDB-                         (baseNativeTypes `HM.union` loadedtypes)-                         (HM.union stdlibFunctions labsFunctions)-                         hieradir-                         (getIgnoredmodules defaults)-                         (getStrictness defaults)-                         (getExtraTests defaults)-                         (getKnownusers defaults)-                         (getKnowngroups defaults)-                         (getExternalmodules defaults)-                         (getPuppetSettings dirpaths defaults)-                         (getFactsOverride defaults)-                         (getFactsDefault defaults)-                         LOG.NOTICE -- good default as INFO is quite noisy-                         Nothing+  let dirpaths = puppetPaths basedir+      modulesdir = dirpaths ^. modulesPath+      testdir = dirpaths ^. testPath+      hierafile = basedir <> "/hiera.yaml"+      defaultfile = testdir <> "/defaults.yaml"+  defaults <- ifM (Directory.doesFileExist defaultfile) (Yaml.decodeFileThrow defaultfile) (pure Nothing)+  hieradir <- ifM (Directory.doesFileExist hierafile) (pure $ Just hierafile) (pure Nothing)+  loadedtypes <- loadedTypes modulesdir+  labsFunctions <- Puppetlabs.extFunctions modulesdir+  return $+    Preferences+      dirpaths+      dummyPuppetDB+      (baseNativeTypes `HM.union` loadedtypes)+      (HM.union stdlibFunctions labsFunctions)+      hieradir+      (getIgnoredmodules defaults)+      (getStrictness defaults)+      (getExtraTests defaults)+      (getKnownusers defaults)+      (getKnowngroups defaults)+      (getExternalmodules defaults)+      (getPuppetSettings dirpaths defaults)+      (getFactsOverride defaults)+      (getFactsDefault defaults)+      LOG.NOTICE -- good default as INFO is quite noisy+      Nothing  loadedTypes :: FilePath -> IO (HM.HashMap NativeTypeName NativeTypeMethods) loadedTypes modulesdir = do   typenames <- map (Text.pack . FilePath.takeBaseName) <$> getFiles modulesdir "lib/puppet/type" ".rb"   pure $ HM.fromList (map defaulttype typenames)   where-   getFiles :: FilePath -> FilePath -> FilePath -> IO [FilePath]-   getFiles moduledir subdir extension =-     fmap concat-     $ Directory.listDirectory moduledir-       >>= mapM ( checkForSubFiles extension . (\x -> moduledir <> "/" <> x <> "/" <> subdir))-   checkForSubFiles :: FilePath -> FilePath -> IO [FilePath]-   checkForSubFiles extension dir =-     catch (fmap Right (Directory.listDirectory dir)) (\e -> return $ Left (e :: IOException)) >>= \case-       Right o -> return ((map (\x -> dir <> "/" <> x) . filter (List.isSuffixOf extension)) o )-       Left _ -> return []+    getFiles :: FilePath -> FilePath -> FilePath -> IO [FilePath]+    getFiles moduledir subdir extension =+      fmap concat $+        Directory.listDirectory moduledir+          >>= mapM (checkForSubFiles extension . (\x -> moduledir <> "/" <> x <> "/" <> subdir))+    checkForSubFiles :: FilePath -> FilePath -> IO [FilePath]+    checkForSubFiles extension dir =+      catch (fmap Right (Directory.listDirectory dir)) (\e -> return $ Left (e :: IOException)) >>= \case+        Right o -> return ((map (\x -> dir <> "/" <> x) . filter (List.isSuffixOf extension)) o)+        Left _ -> return []  -- Utilities for getting default values from the yaml file -- It provides (the same) static defaults (see the 'Nothing' case) when --     no default yaml file or --     not key/value for the option has been provided getKnownusers :: Maybe Defaults -> [Text]-getKnownusers = fromMaybe ["mysql", "vagrant","nginx", "nagios", "postgres", "puppet", "root", "syslog", "www-data"] . (>>= _dfKnownusers)+getKnownusers = fromMaybe ["mysql", "vagrant", "nginx", "nagios", "postgres", "puppet", "root", "syslog", "www-data"] . (>>= _dfKnownusers)  getKnowngroups :: Maybe Defaults -> [Text]-getKnowngroups = fromMaybe ["adm", "syslog", "mysql", "nagios","postgres", "puppet", "root", "www-data", "postfix"] . (>>= _dfKnowngroups)+getKnowngroups = fromMaybe ["adm", "syslog", "mysql", "nagios", "postgres", "puppet", "root", "www-data", "postfix"] . (>>= _dfKnowngroups)  getStrictness :: Maybe Defaults -> Strictness getStrictness = fromMaybe Permissive . (>>= _dfStrictness)@@ -162,9 +168,11 @@ getPuppetSettings dirpaths = fromMaybe df . (>>= _dfPuppetSettings)   where     df :: Container Text-    df = HM.fromList [ ("confdir", Text.pack $ dirpaths^.baseDir)-                     , ("strict_variables", "true")-                     ]+    df =+      HM.fromList+        [ ("confdir", Text.pack $ dirpaths ^. baseDir),+          ("strict_variables", "true")+        ]  getFactsOverride :: Maybe Defaults -> Container PValue getFactsOverride = fromMaybe mempty . (>>= _dfFactsOverride)
src/Puppet/Runner/Puppetlabs.hs view
@@ -1,119 +1,114 @@ {-# LANGUAGE OverloadedLists #-}+ -- | Contains an Haskell implementation (or mock implementation) of some ruby functions found in puppetlabs modules. module Puppet.Runner.Puppetlabs (extFunctions) where -import           XPrelude--import           Crypto.Hash         as Crypto-import           Data.ByteString     (ByteString)-import           Data.Char           (isDigit)-import           Data.Foldable       (foldlM)+import Crypto.Hash as Crypto import qualified Data.HashMap.Strict as Map-import           Data.Scientific     as Sci-import qualified Data.Text           as Text-import qualified Data.Text.Encoding  as Text-import           Data.Vector         (Vector)-import           Formatting          (scifmt, sformat, (%), (%.))-import qualified Formatting          as FMT-import qualified System.Directory    as Directory-import           System.FilePath     ((</>), (<.>))-import           System.Random       (mkStdGen, randomRs)--import           Puppet.Interpreter+import Data.Scientific as Sci+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Formatting (scifmt, sformat, (%), (%.))+import qualified Formatting as FMT+import Puppet.Interpreter+import qualified System.Directory as Directory+import System.FilePath ((<.>), (</>))+import System.Random (mkStdGen, randomRs)+import XPrelude  md5 :: Text -> Text md5 = Text.pack . show . (Crypto.hash :: ByteString -> Digest MD5) . Text.encodeUtf8  extFun :: [(Text, Text, [PValue] -> InterpreterMonad PValue)]-extFun =  [ ("apache", "bool2httpd", apacheBool2httpd)-          , ("docker", "docker_swarm_join_flags", mockDockerSwarmJoinFlags)-          , ("docker", "docker_swarm_init_flags", mockDockerSwarmInitFlags)-          , ("docker", "docker_run_flags", mockDockerRunFlags)-          , ("docker", "docker_stack_flags", mockDockerStackFlags)-          , ("docker", "docker_secrets_flags", mockDockerSecretsFlags)-          , ("docker", "sanitised_name", dockerSanitisedName)-          , ("jenkins", "jenkins_port", mockJenkinsPort)-          , ("jenkins", "jenkins_prefix", mockJenkinsPrefix)-          , ("postgresql", "postgresql_acls_to_resources_hash", pgAclsToHash)-          , ("postgresql", "postgresql_password", pgPassword)-          , ("puppetdb", "puppetdb_create_subsetting_resource_hash", puppetdbCreateSubsettingResourceHash)-          , ("extlib", "random_password", randomPassword)-          , ("extlib", "cache_data", mockCacheData)-          , ("kubernetes", "kubeadm_init_flags", mockKubernetesInitFlags)-          , ("kubernetes", "kubeadm_join_flags", mockKubernetesJoinFlags)-          ]+extFun =+  [ ("apache", "bool2httpd", apacheBool2httpd),+    ("docker", "docker_swarm_join_flags", mockDockerSwarmJoinFlags),+    ("docker", "docker_swarm_init_flags", mockDockerSwarmInitFlags),+    ("docker", "docker_run_flags", mockDockerRunFlags),+    ("docker", "docker_stack_flags", mockDockerStackFlags),+    ("docker", "docker_secrets_flags", mockDockerSecretsFlags),+    ("docker", "sanitised_name", dockerSanitisedName),+    ("jenkins", "jenkins_port", mockJenkinsPort),+    ("jenkins", "jenkins_prefix", mockJenkinsPrefix),+    ("postgresql", "postgresql_acls_to_resources_hash", pgAclsToHash),+    ("postgresql", "postgresql_password", pgPassword),+    ("puppetdb", "puppetdb_create_subsetting_resource_hash", puppetdbCreateSubsettingResourceHash),+    ("extlib", "random_password", randomPassword),+    ("extlib", "cache_data", mockCacheData),+    ("kubernetes", "kubeadm_init_flags", mockKubernetesInitFlags),+    ("kubernetes", "kubeadm_join_flags", mockKubernetesJoinFlags)+  ]  -- | Build the map of available external functions. -- -- If the ruby/puppet file is not found on the local filesystem the record is ignored. This is to avoid potential namespace conflict.-extFunctions :: FilePath -> IO (Container ( [PValue] -> InterpreterMonad PValue))+extFunctions :: FilePath -> IO (Container ([PValue] -> InterpreterMonad PValue)) extFunctions modpath = foldlM f Map.empty extFun   where     f acc (nsp, name, fn) = do       test <- testFile (toS nsp) name       if test-         then pure $ Map.insert name fn acc-         else pure acc+        then pure $ Map.insert name fn acc+        else pure acc     testFile nspath funcname =       let funcpath0 = modpath </> nspath           funcpath1 = funcpath0 </> "lib/puppet"           funcpath2 = funcpath1 </> "parser/functions"           funcpath3 = funcpath1 </> "functions"-      in-      isJust <$> Directory.findFile [ funcpath0 </> "functions"] (toS funcname <.> "pp")-      ||^-      isJust <$> Directory.findFile [ funcpath2-                                    , funcpath3-                                    , funcpath2 </> nspath-                                    , funcpath3 </> nspath-                                    ] (toS funcname <.> "rb")+       in (\a b -> isJust a || isJust b)+            <$> Directory.findFile [funcpath0 </> "functions"] (toS funcname <.> "pp")+            <*> Directory.findFile+              [ funcpath2,+                funcpath3,+                funcpath2 </> nspath,+                funcpath3 </> nspath+              ]+              (toS funcname <.> "rb") -apacheBool2httpd :: MonadThrowPos m => [PValue] -> m PValue-apacheBool2httpd [PBoolean True]  = pure $ PString "On"+apacheBool2httpd :: (MonadThrowPos m) => [PValue] -> m PValue+apacheBool2httpd [PBoolean True] = pure $ PString "On" apacheBool2httpd [PString "true"] = pure $ PString "On"-apacheBool2httpd [_]              = pure $ PString "Off"-apacheBool2httpd arg@_            = throwPosError $ "expect one single argument" <+> pretty arg+apacheBool2httpd [_] = pure $ PString "Off"+apacheBool2httpd arg = throwPosError $ "expect one single argument" <+> pretty arg -pgPassword :: MonadThrowPos m => [PValue] -> m PValue+pgPassword :: (MonadThrowPos m) => [PValue] -> m PValue pgPassword [PString username, PString pwd] =-    return $ PString $ "md5" <> md5 (pwd <> username)+  return $ PString $ "md5" <> md5 (pwd <> username) pgPassword _ = throwPosError "expects 2 string arguments"  -- | The function is pure and always return the same "random" password.-randomPassword :: MonadThrowPos m => [PValue] -> m PValue+randomPassword :: (MonadThrowPos m) => [PValue] -> m PValue randomPassword [PNumber s] =   PString . Text.pack . randomChars <$> scientificToInt s   where     randomChars n = take n $ randomRs ('a', 'z') (mkStdGen 1)- randomPassword _ = throwPosError "expect one single string arguments" - -- To be implemented if needed.-mockJenkinsPrefix :: MonadThrowPos m => [PValue] -> m PValue-mockJenkinsPrefix []    = return $ PString ""-mockJenkinsPrefix arg@_ = throwPosError $ "expect no argument" <+> pretty arg+mockJenkinsPrefix :: (MonadThrowPos m) => [PValue] -> m PValue+mockJenkinsPrefix [] = return $ PString ""+mockJenkinsPrefix arg = throwPosError $ "expect no argument" <+> pretty arg  -- To be implemented if needed.-mockJenkinsPort :: MonadThrowPos m => [PValue] -> m PValue-mockJenkinsPort []    = return $ PString "8080"-mockJenkinsPort arg@_ = throwPosError $ "expect no argument" <+> pretty arg+mockJenkinsPort :: (MonadThrowPos m) => [PValue] -> m PValue+mockJenkinsPort [] = return $ PString "8080"+mockJenkinsPort arg = throwPosError $ "expect no argument" <+> pretty arg -mockCacheData :: MonadThrowPos m => [PValue] -> m PValue+mockCacheData :: (MonadThrowPos m) => [PValue] -> m PValue mockCacheData [_, _, b] = return b-mockCacheData arg@_     = throwPosError $ "expect 3 string arguments" <+> pretty arg+mockCacheData arg = throwPosError $ "expect 3 string arguments" <+> pretty arg  -- | Simple implemenation that does not handle all cases. -- For instance 'auth_option' is currently not implemented. -- Please add cases as needed.-pgAclsToHash :: MonadThrowPos m => [PValue] -> m PValue+pgAclsToHash :: (MonadThrowPos m) => [PValue] -> m PValue pgAclsToHash [PArray as, PString ident, PNumber offset] = PHash <$> aclsToHash as ident offset pgAclsToHash _ = throwPosError "expects 3 arguments; one array one string and one number" -aclsToHash :: MonadThrowPos m  => Vector PValue -> Text -> Scientific -> m (Container PValue)+aclsToHash :: (MonadThrowPos m) => Vector PValue -> Text -> Scientific -> m (Container PValue) aclsToHash vec ident offset = ifoldlM f Map.empty vec   where-    f :: MonadThrowPos m => Int -> Container PValue -> PValue -> m (Container PValue)+    f :: (MonadThrowPos m) => Int -> Container PValue -> PValue -> m (Container PValue)     f idx acc (PString acl) = do       let order = offset + scientific (toInteger idx) 0           keymsg = sformat ("postgresql class generated rule " % FMT.stext % " " % FMT.int) ident idx@@ -124,81 +119,93 @@ aclToHash :: (MonadThrowPos m) => [Text] -> Scientific -> m PValue aclToHash acl@(typ : db : usr : remaining) order = analyze   where-    fin remn hs = return $ PHash $-        if null remn-          then hs-          else Map.insert "auth_option" (PString (Text.unwords remn)) hs+    fin remn hs =+      return $+        PHash $+          if null remn+            then hs+            else Map.insert "auth_option" (PString (Text.unwords remn)) hs     analyze = case remaining of-                method : remn | typ == "local" ->-                  fin remn $ baseHash & at "auth_method" ?~ PString method-                addr : msk : method : remn | Text.all isDigit msk ->-                  fin remn $ baseHash & at "address" ?~ PString (Text.unwords [addr,msk])-                                      & at "auth_method" ?~ PString method-                addr : method : remn ->-                  fin remn $ baseHash & at "address" ?~ PString addr-                                      & at "auth_method" ?~ PString method-                _ -> throwPosError $ "Unable to parse acl line" <+> squotes (ppline (Text.unwords acl))-    baseHash = [ ("type", PString "local")-               , ("database", PString db )-               , ("user", PString usr)-               , ("order", PString (sformat (FMT.left 3 '0' %. scifmt Sci.Fixed (Just 0))  order))-               ]+      method : remn+        | typ == "local" ->+            fin remn $ baseHash & at "auth_method" ?~ PString method+      addr : msk : method : remn+        | Text.all isDigit msk ->+            fin remn $+              baseHash+                & at "address" ?~ PString (Text.unwords [addr, msk])+                & at "auth_method" ?~ PString method+      addr : method : remn ->+        fin remn $+          baseHash+            & at "address" ?~ PString addr+            & at "auth_method" ?~ PString method+      _ -> throwPosError $ "Unable to parse acl line" <+> squotes (ppline (Text.unwords acl))+    baseHash =+      [ ("type", PString "local"),+        ("database", PString db),+        ("user", PString usr),+        ("order", PString (sformat (FMT.left 3 '0' %. scifmt Sci.Fixed (Just 0)) order))+      ] aclToHash acl _ = throwPosError $ "Unable to parse acl line" <+> squotes (ppline (Text.unwords acl))  -- faked implementation, replace by the correct one if you need so.-mockDockerRunFlags :: MonadThrowPos m => [PValue] -> m PValue-mockDockerRunFlags arg@[PHash _]= (pure . PString . show . head) arg-mockDockerRunFlags  arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg+mockDockerRunFlags :: (MonadThrowPos m) => [PValue] -> m PValue+mockDockerRunFlags arg@[PHash _] = (pure . PString . show . head) arg+mockDockerRunFlags arg = throwPosError $ "Expect an hash as argument but was" <+> pretty arg  -- faked implementation, replace by the correct one if you need so.-mockDockerStackFlags :: MonadThrowPos m => [PValue] -> m PValue-mockDockerStackFlags arg@[PHash _]= (pure . PString . show . head) arg-mockDockerStackFlags  arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg+mockDockerStackFlags :: (MonadThrowPos m) => [PValue] -> m PValue+mockDockerStackFlags arg@[PHash _] = (pure . PString . show . head) arg+mockDockerStackFlags arg = throwPosError $ "Expect an hash as argument but was" <+> pretty arg  -- faked implementation, replace by the correct one if you need so.-mockDockerSecretsFlags :: MonadThrowPos m => [PValue] -> m PValue-mockDockerSecretsFlags arg@[PHash _]= (pure . PString . show . head) arg-mockDockerSecretsFlags  arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg+mockDockerSecretsFlags :: (MonadThrowPos m) => [PValue] -> m PValue+mockDockerSecretsFlags arg@[PHash _] = (pure . PString . show . head) arg+mockDockerSecretsFlags arg = throwPosError $ "Expect an hash as argument but was" <+> pretty arg  -- faked implementation, replace by the correct one if you need so.-mockDockerSwarmJoinFlags :: MonadThrowPos m => [PValue] -> m PValue-mockDockerSwarmJoinFlags arg@[PHash _]= (pure . PString . show . head) arg-mockDockerSwarmJoinFlags  arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg+mockDockerSwarmJoinFlags :: (MonadThrowPos m) => [PValue] -> m PValue+mockDockerSwarmJoinFlags arg@[PHash _] = (pure . PString . show . head) arg+mockDockerSwarmJoinFlags arg = throwPosError $ "Expect an hash as argument but was" <+> pretty arg  -- faked implementation, replace by the correct one if you need so.-mockDockerSwarmInitFlags :: MonadThrowPos m => [PValue] -> m PValue-mockDockerSwarmInitFlags arg@[PHash _]= (pure . PString . show . head) arg-mockDockerSwarmInitFlags  arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg+mockDockerSwarmInitFlags :: (MonadThrowPos m) => [PValue] -> m PValue+mockDockerSwarmInitFlags arg@[PHash _] = (pure . PString . show . head) arg+mockDockerSwarmInitFlags arg = throwPosError $ "Expect an hash as argument but was" <+> pretty arg  -- faked implementation, replace by the correct one if you need so.-mockKubernetesInitFlags :: MonadThrowPos m => [PValue] -> m PValue-mockKubernetesInitFlags arg@[PHash _]= (pure . PString . show . head) arg-mockKubernetesInitFlags  arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg+mockKubernetesInitFlags :: (MonadThrowPos m) => [PValue] -> m PValue+mockKubernetesInitFlags arg@[PHash _] = (pure . PString . show . head) arg+mockKubernetesInitFlags arg = throwPosError $ "Expect an hash as argument but was" <+> pretty arg  -- faked implementation, replace by the correct one if you need so.-mockKubernetesJoinFlags :: MonadThrowPos m => [PValue] -> m PValue-mockKubernetesJoinFlags arg@[PHash _]= (pure . PString . show . head) arg-mockKubernetesJoinFlags  arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg+mockKubernetesJoinFlags :: (MonadThrowPos m) => [PValue] -> m PValue+mockKubernetesJoinFlags arg@[PHash _] = (pure . PString . show . head) arg+mockKubernetesJoinFlags arg = throwPosError $ "Expect an hash as argument but was" <+> pretty arg  -- utils-scientificToInt :: MonadThrowPos m => Scientific -> m Int-scientificToInt s = maybe (throwPosError $ "Unable to convert" <+> pretty s <+> "into an int.")-                          pure-                          (Sci.toBoundedInteger s)+scientificToInt :: (MonadThrowPos m) => Scientific -> m Int+scientificToInt s =+  maybe+    (throwPosError $ "Unable to convert" <+> pretty s <+> "into an int.")+    pure+    (Sci.toBoundedInteger s)  -- https://github.com/puppetlabs/puppetlabs-puppetdb/blob/master/lib/puppet/parser/functions/puppetdb_create_subsetting_resource_hash.rb-puppetdbCreateSubsettingResourceHash :: MonadThrowPos m => [PValue] -> m PValue+puppetdbCreateSubsettingResourceHash :: (MonadThrowPos m) => [PValue] -> m PValue puppetdbCreateSubsettingResourceHash [PHash s, PHash args] = do-  let res_hash = [ (k, PHash h)-                 | (k,v) <- itoList s-                 , let h = [ ( "subsetting", PString k) , ("value", v)] `Map.union` args-                 ]+  let res_hash =+        [ (k, PHash h)+          | (k, v) <- itoList s,+            let h = [("subsetting", PString k), ("value", v)] `Map.union` args+        ]   pure $ PHash (Map.fromList res_hash)-puppetdbCreateSubsettingResourceHash arg@_ = throwPosError $ "Expect 2 hashes as arguments but was" <+> pretty arg+puppetdbCreateSubsettingResourceHash arg = throwPosError $ "Expect 2 hashes as arguments but was" <+> pretty arg  -- To be implemented if needed.-dockerSanitisedName :: MonadThrowPos m => [PValue] -> m PValue+dockerSanitisedName :: (MonadThrowPos m) => [PValue] -> m PValue dockerSanitisedName [PString s] =   -- ruby implementation: regsubst($name, '[^0-9A-Za-z.\-_]', '-', 'G')   pure $ PString s-dockerSanitisedName arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg+dockerSanitisedName arg = throwPosError $ "Expect an hash as argument but was" <+> pretty arg
src/Puppet/Runner/Pure.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedLists #-}+ -- | Publicly exposed pure helpers to evaluate the 'InterpreterMonad' -- functions that can be found in "Puppet.Interpreter" and -- "Puppet.Interpreter.Resolve".@@ -7,43 +8,48 @@ -- -- >>> dummyEval (resolveExpression (Addition "1" "2")) -- Right (PString "3")-module Puppet.Runner.Pure (-    dummyEval-  , dummyFacts-  , dummyInitialState-  , pureEval-  , pureEval'-  , pureReader-) where--import           XPrelude--import qualified Data.Either.Strict    as S-import qualified Data.HashMap.Strict   as HM--import           Erb-import           Facter-import           Hiera.Server-import           Puppet.Interpreter-import           Puppet.Parser (Statement)-import           Puppet.Runner.Erb-import           PuppetDB              (dummyPuppetDB)+module Puppet.Runner.Pure+  ( dummyEval,+    dummyFacts,+    dummyInitialState,+    pureEval,+    pureEval',+    pureReader,+  )+where +import qualified Data.Either.Strict as S+import qualified Data.HashMap.Strict as HM+import Erb+import Facter+import Hiera.Server+import Puppet.Interpreter+import Puppet.Parser (Statement)+import Puppet.Runner.Erb+import PuppetDB (dummyPuppetDB)+import XPrelude  -- | Evaluates with a map of statements in a pure context. -- Unlike 'dummyEval', each hiera lookup is evaluated to return Nothing.-pureEval :: HM.HashMap (TopLevelType, Text) Statement -- ^ A top-level map-         -> InterpreterMonad a -- ^ The action to evaluate-         -> (Either PrettyError a, InterpreterState, InterpreterWriter)-pureEval stmap action =-  pureEval' stmap dummyInitialState Nothing action+pureEval ::+  -- | A top-level map+  HM.HashMap (TopLevelType, Text) Statement ->+  -- | The action to evaluate+  InterpreterMonad a ->+  (Either PrettyError a, InterpreterState, InterpreterWriter)+pureEval stmap = pureEval' stmap dummyInitialState Nothing  -- | More flexible version of 'pureEval'-pureEval' :: HM.HashMap (TopLevelType, Text) Statement -- ^ A top-level map-          -> InterpreterState -- ^ the initial state-          -> Maybe PValue -- ^ a value to be return by all hiera lookup-          -> InterpreterMonad a -- ^ The action to evaluate-          -> (Either PrettyError a, InterpreterState, InterpreterWriter)+pureEval' ::+  -- | A top-level map+  HM.HashMap (TopLevelType, Text) Statement ->+  -- | the initial state+  InterpreterState ->+  -- | a value to be return by all hiera lookup+  Maybe PValue ->+  -- | The action to evaluate+  InterpreterMonad a ->+  (Either PrettyError a, InterpreterState, InterpreterWriter) pureEval' stmap s0 hiera action =   runIdentity (interpretMonad (pureReader stmap hiera) s0 action) @@ -57,9 +63,12 @@  -- | A pure 'InterpreterReader', that can only evaluate a subset of the -- templates, and that can include only the supplied top level statements.-pureReader :: HM.HashMap (TopLevelType, Text) Statement -- ^ A top-level statement map-           -> Maybe PValue -- ^ What value a call to hiera should return-           -> InterpreterReader Identity+pureReader ::+  -- | A top-level statement map+  HM.HashMap (TopLevelType, Text) Statement ->+  -- | What value a call to hiera should return+  Maybe PValue ->+  InterpreterReader Identity pureReader sttmap hiera =   InterpreterReader     baseNativeTypes@@ -80,13 +89,13 @@     pure_hiera :: HieraQueryFunc Identity     pure_hiera _ _ _ = pure hiera     hieradummy = HieraQueryLayers pure_hiera (\_ _ _ -> pure Nothing) mempty-    getstatementdummy tlt n = return $ case HM.lookup (tlt,n) sttmap of-      Just x  -> S.Right x+    getstatementdummy tlt n = return $ case HM.lookup (tlt, n) sttmap of+      Just x -> S.Right x       Nothing -> S.Left "Can't get statement"     iomethods_purestubs :: IoMethods Identity     iomethods_purestubs = IoMethods (return []) (const (return (Left "Can't read file"))) (\_ -> return ()) -dummyTemplate :: Monad m => TemplateSource -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError Text)+dummyTemplate :: (Monad m) => TemplateSource -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError Text) dummyTemplate (Filename _) _ _ = return (S.Left "Can't interpret files") dummyTemplate (Inline cnt) s _ =   return $ case extractScope s of@@ -97,91 +106,101 @@         Right stmts ->           case rubyEvaluate scope ctx stmts of             Right x -> S.Right x-            Left e  -> S.Left (PrettyError e)+            Left e -> S.Left (PrettyError e)  -- | A bunch of facts that can be used for pure evaluation. dummyFacts :: Facts-dummyFacts = HM.fromList-        [ ("augeasversion", "0.10.0")-        , ("bios_release_date", "07/06/2010")-        , ("bios_vendor", "Dell Inc.")-        , ("bios_version", "2.2.0")-        , ("boardmanufacturer", "Dell Inc.")-        , ("domain", "dummy.domain")-        , ("facterversion", "1.7.5")-        , ("filesystems", "ext2,ext3,ext4,vfat")-        , ("fqdn", "dummy.dummy.domain")-        , ("hardwareisa", "x86_64")-        , ("hardwaremodel", "x86_64")-        , ("hostname", "dummy")-        , ("id", "root")-        , ("interfaces", "eth0,lo")-        , ("ipaddress", "172.17.42.1")-        , ("ipaddress_eth0", "172.17.42.1")-        , ("ipaddress_lo", "127.0.0.1")-        , ("is_virtual", "false")-        , ("kernel", "Linux")-        , ("kernelmajversion", "3.8")-        , ("kernelrelease", "3.8.0-37-generic")-        , ("kernelversion", "3.8.0")-        , ("lsbdistcodename", "precise")-        , ("lsbdistdescription", "Ubuntu 12.04.4 LTS")-        , ("lsbdistid", "Ubuntu")-        , ("lsbdistrelease", "12.04")-        , ("lsbmajdistrelease", "12")-        , ("macaddress", "a5:cb:10:b0:9a:4b")-        , ("macaddress_eth0", "72:53:10:c1:eb:70")-        , ("manufacturer", "Dell Inc.")-        , ("memoryfree", "12.57 GB")-        , ("memoryfree_mb", "12869.89")-        , ("memorysize", "15.63 GB")-        , ("memorysize_mb", "16009.07")-        , ("memorytotal", "15.63 GB")-        , ("mtu_eth0", "1500")-        , ("mtu_lo", "65536")-        , ("netmask", "255.255.0.0")-        , ("netmask_eth0", "255.255.255.0")-        , ("netmask_lo", "255.0.0.0")-        , ("network_eth0", "172.17.42.0")-        , ("network_lo", "127.0.0.0")-        , ("operatingsystem", "Ubuntu")-        , ("operatingsystemrelease", "12.04")-        , ("os", PHash [ ("architecture", "amd64")-                       , ("release", PHash [("major", "7")])-                       ])-        , ("osfamily", "Debian")-        , ("path", "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin")-        , ("processors", PHash [("models", PArray [ "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"-                                                  ])-                               , ("count", "8")-                               , ("physicalprocessorcount", "1")-                               ])-        , ("productname", "Vostro 430")-        , ("ps", "ps -ef")-        , ("puppetversion", "3.4.3")-        , ("rubysitedir", "/usr/local/lib/site_ruby/1.8")-        , ("rubyversion", "1.8.7")-        , ("selinux", "false")-        , ("serialnumber", "9L3FW4J")-        , ("swapfree", "15.96 GB")-        , ("swapfree_mb", "16340.00")-        , ("swapsize", "15.96 GB")-        , ("swapsize_mb", "16340.00")-        , ("timezone", "CEST")-        , ("type", "Desktop")-        , ("uniqueid", "007f0101")-        , ("uptime", "5:48 hours")-        , ("uptime_days", "0")-        , ("uptime_hours", "5")-        , ("uptime_seconds", "20932")-        , ("uuid", "97b75940-be55-11e3-b1b6-0800200c9a66")-        , ("virtual", "physical")-        ]+dummyFacts =+  HM.fromList+    [ ("augeasversion", "0.10.0"),+      ("bios_release_date", "07/06/2010"),+      ("bios_vendor", "Dell Inc."),+      ("bios_version", "2.2.0"),+      ("boardmanufacturer", "Dell Inc."),+      ("domain", "dummy.domain"),+      ("facterversion", "1.7.5"),+      ("filesystems", "ext2,ext3,ext4,vfat"),+      ("fqdn", "dummy.dummy.domain"),+      ("hardwareisa", "x86_64"),+      ("hardwaremodel", "x86_64"),+      ("hostname", "dummy"),+      ("id", "root"),+      ("interfaces", "eth0,lo"),+      ("ipaddress", "172.17.42.1"),+      ("ipaddress_eth0", "172.17.42.1"),+      ("ipaddress_lo", "127.0.0.1"),+      ("is_virtual", "false"),+      ("kernel", "Linux"),+      ("kernelmajversion", "3.8"),+      ("kernelrelease", "3.8.0-37-generic"),+      ("kernelversion", "3.8.0"),+      ("lsbdistcodename", "precise"),+      ("lsbdistdescription", "Ubuntu 12.04.4 LTS"),+      ("lsbdistid", "Ubuntu"),+      ("lsbdistrelease", "12.04"),+      ("lsbmajdistrelease", "12"),+      ("macaddress", "a5:cb:10:b0:9a:4b"),+      ("macaddress_eth0", "72:53:10:c1:eb:70"),+      ("manufacturer", "Dell Inc."),+      ("memoryfree", "12.57 GB"),+      ("memoryfree_mb", "12869.89"),+      ("memorysize", "15.63 GB"),+      ("memorysize_mb", "16009.07"),+      ("memorytotal", "15.63 GB"),+      ("mtu_eth0", "1500"),+      ("mtu_lo", "65536"),+      ("netmask", "255.255.0.0"),+      ("netmask_eth0", "255.255.255.0"),+      ("netmask_lo", "255.0.0.0"),+      ("network_eth0", "172.17.42.0"),+      ("network_lo", "127.0.0.0"),+      ("operatingsystem", "Ubuntu"),+      ("operatingsystemrelease", "12.04"),+      ( "os",+        PHash+          [ ("architecture", "amd64"),+            ("release", PHash [("major", "7")])+          ]+      ),+      ("osfamily", "Debian"),+      ("path", "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin"),+      ( "processors",+        PHash+          [ ( "models",+              PArray+                [ "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"+                ]+            ),+            ("count", "8"),+            ("physicalprocessorcount", "1")+          ]+      ),+      ("productname", "Vostro 430"),+      ("ps", "ps -ef"),+      ("puppetversion", "3.4.3"),+      ("rubysitedir", "/usr/local/lib/site_ruby/1.8"),+      ("rubyversion", "1.8.7"),+      ("selinux", "false"),+      ("serialnumber", "9L3FW4J"),+      ("swapfree", "15.96 GB"),+      ("swapfree_mb", "16340.00"),+      ("swapsize", "15.96 GB"),+      ("swapsize_mb", "16340.00"),+      ("timezone", "CEST"),+      ("type", "Desktop"),+      ("uniqueid", "007f0101"),+      ("uptime", "5:48 hours"),+      ("uptime_days", "0"),+      ("uptime_hours", "5"),+      ("uptime_seconds", "20932"),+      ("uuid", "97b75940-be55-11e3-b1b6-0800200c9a66"),+      ("virtual", "physical")+    ]
src/Puppet/Runner/Stats.hs view
@@ -1,33 +1,37 @@-{-| A quickly done module that exports utility functions used to collect various-statistics. All statistics are stored in a MVar holding a HashMap.--This is not accurate in the presence of lazy evaluation. Nothing is forced.--}+-- | A quickly done module that exports utility functions used to collect various+-- statistics. All statistics are stored in a MVar holding a HashMap.+--+-- This is not accurate in the presence of lazy evaluation. Nothing is forced. module Puppet.Runner.Stats-  ( measure-  , newStats-  , getStats-  , StatsPoint(..)-  , MStats-  ) where--import           XPrelude+  ( measure,+    newStats,+    getStats,+    StatsPoint (..),+    MStats,+  )+where -import Data.Time.Clock.POSIX (getPOSIXTime) import qualified Data.HashMap.Strict as Map+import Data.Time.Clock.POSIX (getPOSIXTime)+import XPrelude  data StatsPoint = StatsPoint-  { _statspointCount :: !Int -- ^ Total number of calls to a computation-  , _statspointTotal :: !Double -- ^ Total time spent during this computation-  , _statspointMin :: !Double -- ^ Minimum execution time-  , _statspointMax :: !Double -- ^ Maximum execution time-  } deriving (Show)+  { -- | Total number of calls to a computation+    _statspointCount :: !Int,+    -- | Total time spent during this computation+    _statspointTotal :: !Double,+    -- | Minimum execution time+    _statspointMin :: !Double,+    -- | Maximum execution time+    _statspointMax :: !Double+  }+  deriving (Show)  -- | A table where keys are the names of the computations, and values are -- 'StatsPoint's. type StatsTable = HashMap Text StatsPoint -newtype MStats = MStats { unMStats :: MVar StatsTable }+newtype MStats = MStats {unMStats :: MVar StatsTable}  -- | Returns the actual statistical values. getStats :: MStats -> IO StatsTable@@ -38,10 +42,14 @@ newStats = MStats `fmap` newMVar Map.empty  -- | Wraps a computation, and measures related execution statistics.-measure :: MStats -- ^ Statistics container-        -> Text -- ^ Action identifier-        -> IO a   -- ^ Computation-        -> IO a+measure ::+  -- | Statistics container+  MStats ->+  -- | Action identifier+  Text ->+  -- | Computation+  IO a ->+  IO a measure (MStats mtable) statsname action = do   (!tm, !out) <- time action   !stats <- takeMVar mtable@@ -49,13 +57,9 @@       !nstats = case stats ^. at statsname of         Nothing -> stats & at statsname ?~ StatsPoint 1 tm tm tm         Just (StatsPoint sc st smi sma) ->-            let !nmax = if tm > sma-                          then tm-                          else sma-                !nmin = if tm < smi-                          then tm-                          else smi-            in stats & at statsname ?~ StatsPoint (sc+1) (st+tm) nmin nmax+          let !nmax = max tm sma+              !nmin = min tm smi+           in stats & at statsname ?~ StatsPoint (sc + 1) (st + tm) nmin nmax   putMVar mtable nstats   return $! out
src/Puppet/Runner/Stdlib.hs view
@@ -1,162 +1,167 @@ {-# LANGUAGE PatternGuards #-}-{-# LANGUAGE RankNTypes    #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-}-module Puppet.Runner.Stdlib (stdlibFunctions) where -import           XPrelude                         hiding (sort)+module Puppet.Runner.Stdlib (stdlibFunctions) where -import qualified Data.Yaml            as Yaml-import qualified Data.ByteString.Base16           as B16-import qualified Data.Char                        as Char-import qualified Data.HashMap.Strict              as HM-import qualified Data.List                        as List-import qualified Data.List.Split                  as List (chunksOf)-import qualified Data.Scientific                  as Scientific-import qualified Data.Text                        as Text-import qualified Data.Text.Encoding               as Text-import           Data.Text.Lens                   (unpacked)-import qualified Data.Vector                      as V-import           Data.Vector.Lens                 (toVectorOf)+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Lazy as LByteString+import qualified Data.Char as Char+import qualified Data.HashMap.Strict as HM+import qualified Data.List as List+import qualified Data.List.Split as List (chunksOf)+import qualified Data.Scientific as Scientific+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Text.Lens (unpacked)+import qualified Data.Vector as V+import Data.Vector.Lens (toVectorOf)+import qualified Data.Yaml as Yaml+import Puppet.Interpreter+import Puppet.Interpreter.Helpers+import qualified System.FilePath as FilePath import qualified Text.Regex.PCRE.ByteString.Utils as Regex-import qualified System.FilePath                  as FilePath--import           Puppet.Interpreter-import           Puppet.Interpreter.Helpers+import XPrelude hiding (sort)  -- | Contains the implementation of the StdLib functions.-stdlibFunctions :: Container ( [PValue] -> InterpreterMonad PValue )-stdlibFunctions = HM.fromList [ singleArgument "abs" puppetAbs-                              , ("any2array", any2array)-                              , ("assert_private", assertPrivate)-                              , ("base64", base64)-                              -- basename-                              , singleArgument "bool2num" bool2num-                              -- bool2str-                              -- camelcase-                              , ("capitalize", stringArrayFunction (safeEmptyString (\t -> Text.cons (Char.toUpper (Text.head t)) (Text.tail t))))-                              -- ceiling-                              , ("chomp", stringArrayFunction (Text.dropWhileEnd (\c -> c == '\n' || c == '\r')))-                              , ("chop", stringArrayFunction (safeEmptyString Text.init))-                              -- clamp-                              , ("concat", puppetConcat)-                              -- convert_base-                              , ("count", puppetCount)-                              , ("deep_merge", deepMerge)-                              , ("defined_with_params", const (throwPosError "defined_with_params can't be implemented with language-puppet"))-                              , ("delete", delete)-                              , ("delete_at", deleteAt)-                              , singleArgument "delete_undef_values" deleteUndefValues-                              -- delete_values-                              -- difference-                              , singleArgument "dirname" dirname-                              -- dos2unix-                              , ("downcase", stringArrayFunction Text.toLower)-                              , singleArgument "empty" _empty-                              -- ensure_packages (in main interpreter module)-                              -- ensure_resource (in main interpreter module)-                              , singleArgument "fact" fact-                              , singleArgument "flatten" flatten-                              -- floor-                              -- fqdn_rand_string-                              -- fqdn_rotate-                              -- get_module_path-                              , ("getparam", const $ throwPosError "The getparam function is uncool and shall not be implemented in language-puppet")-                              , singleArgument "getvar"  getvar-                              , ("grep", _grep)-                              , ("hash", hash)-                              -- has_interface_with-                              -- has_ip_address-                              -- has_ip_network-                              , ("has_key", hasKey)-                              -- intersection-                              -- is_absolute_path-                              , singleArgument "is_array" isArray-                              , singleArgument "is_bool" isBool-                              , singleArgument "is_domain_name" isDomainName-                              -- is_float-                              -- is_function_available-                              , singleArgument "is_hash" isHash-                              , singleArgument "is_integer" isInteger-                              -- is_ip_address-                              -- is_mac_address-                              -- is_numeric-                              , singleArgument "is_string" isString-                              , ("join", puppetJoin)-                              , ("join_keys_to_values", joinKeysToValues)-                              , singleArgument "keys" keys-                              , singleArgument "length" size-                              -- load_module_metadata-                              -- loadyaml-                              , ("lstrip", stringArrayFunction Text.stripStart)-                              -- max-                              , ("member", member)-                              , ("merge", merge)-                              -- min-                              -- num2bool-                              -- parsejson-                              -- parseyaml-                              , ("pick", pick)-                              , ("pick_default", pickDefault)-                              , ("prefix", prefix)-                              -- private-                              , ("pw_hash", pwHash)-                              -- range-                              -- reject-                              -- reverse-                              , ("rstrip", stringArrayFunction Text.stripEnd)-                              -- seeded_rand-                              -- shuffle-                              , singleArgument "size" size-                              , singleArgument "sort" sort-                              -- squeeze-                              , singleArgument "str2bool" str2Bool-                              -- strtosaltedshar512-                              -- strftime-                              , ("strip", stringArrayFunction Text.strip)-                              , ("suffix", suffix )-                              -- swapcase-                              -- time-                              -- to_bytes-                              -- try_get_value-                              -- type3x-                              -- type-                              -- union-                              , singleArgument "unique" unique-                              -- from puppetlabs-translate-                              , singleArgument "to_yaml" toYaml-                              , ("translate", translate)-                              -- unix2dos-                              , ("upcase", stringArrayFunction Text.toUpper)-                              -- uriescape-                              , ("validate_absolute_path", validateAbsolutePath)-                              , ("validate_array", validateArray)-                              -- validate_augeas-                              , ("validate_bool", validateBool)-                              -- validate_cmd-                              , ("validate_hash", validateHash)-                              , ("validate_integer", validateInteger)-                              -- validate_ip_address-                              -- validate_ipv4_address-                              -- validate_ipv6_address-                              , ("validate_numeric", validateNumeric)-                              , ("validate_re", validateRe)-                              -- validate_slength-                              , ("validate_string", validateString)-                              -- validate_x509_rsa_key_pair-                              -- values_at-                              , singleArgument "values" pvalues-                              -- zip-                              ]+stdlibFunctions :: Container ([PValue] -> InterpreterMonad PValue)+stdlibFunctions =+  HM.fromList+    [ singleArgument "abs" puppetAbs,+      ("any2array", any2array),+      ("assert_private", assertPrivate),+      ("base64", base64),+      -- basename+      singleArgument "bool2num" bool2num,+      -- bool2str+      -- camelcase+      ("capitalize", stringArrayFunction (safeEmptyString (\t -> Text.cons (Char.toUpper (Text.head t)) (Text.tail t)))),+      -- ceiling+      ("chomp", stringArrayFunction (Text.dropWhileEnd (\c -> c == '\n' || c == '\r'))),+      ("chop", stringArrayFunction (safeEmptyString Text.init)),+      -- clamp+      ("concat", puppetConcat),+      -- convert_base+      ("count", puppetCount),+      ("deep_merge", deepMerge),+      ("defined_with_params", const (throwPosError "defined_with_params can't be implemented with language-puppet")),+      ("delete", delete),+      ("delete_at", deleteAt),+      singleArgument "delete_undef_values" deleteUndefValues,+      -- delete_values+      -- difference+      singleArgument "dirname" dirname,+      -- dos2unix+      ("downcase", stringArrayFunction Text.toLower),+      singleArgument "empty" _empty,+      -- ensure_packages (in main interpreter module)+      -- ensure_resource (in main interpreter module)+      singleArgument "fact" fact,+      singleArgument "flatten" flatten,+      -- floor+      -- fqdn_rand_string+      -- fqdn_rotate+      -- get_module_path+      ("getparam", const $ throwPosError "The getparam function is uncool and shall not be implemented in language-puppet"),+      singleArgument "getvar" getvar,+      ("grep", _grep),+      ("hash", hash),+      -- has_interface_with+      -- has_ip_address+      -- has_ip_network+      ("has_key", hasKey),+      -- intersection+      -- is_absolute_path+      singleArgument "is_array" isArray,+      singleArgument "is_bool" isBool,+      singleArgument "is_domain_name" isDomainName,+      -- is_float+      -- is_function_available+      singleArgument "is_hash" isHash,+      singleArgument "is_integer" isInteger,+      -- is_ip_address+      -- is_mac_address+      -- is_numeric+      singleArgument "is_string" isString,+      ("join", puppetJoin),+      ("join_keys_to_values", joinKeysToValues),+      singleArgument "keys" keys,+      singleArgument "length" size,+      -- load_module_metadata+      -- loadyaml+      ("lstrip", stringArrayFunction Text.stripStart),+      -- max+      ("member", member),+      ("merge", merge),+      -- min+      -- num2bool+      -- parsejson+      -- parseyaml+      ("pick", pick),+      ("pick_default", pickDefault),+      ("prefix", prefix),+      -- private+      ("pw_hash", pwHash),+      -- range+      -- reject+      -- reverse+      ("rstrip", stringArrayFunction Text.stripEnd),+      -- seeded_rand+      -- shuffle+      singleArgument "size" size,+      singleArgument "sort" sort,+      -- squeeze+      singleArgument "str2bool" str2Bool,+      -- strtosaltedshar512+      -- strftime+      ("strip", stringArrayFunction Text.strip),+      ("suffix", suffix),+      -- swapcase+      -- time+      -- to_bytes+      -- try_get_value+      -- type3x+      -- type+      -- union+      singleArgument "unique" unique,+      -- from puppetlabs-translate+      singleArgument "to_yaml" toYaml,+      singleArgument "to_json" toJson,+      singleArgument "to_json_pretty" toJson,+      ("translate", translate),+      -- unix2dos+      ("upcase", stringArrayFunction Text.toUpper),+      -- uriescape+      ("validate_absolute_path", validateAbsolutePath),+      ("validate_array", validateArray),+      -- validate_augeas+      ("validate_bool", validateBool),+      -- validate_cmd+      ("validate_hash", validateHash),+      ("validate_integer", validateInteger),+      -- validate_ip_address+      -- validate_ipv4_address+      -- validate_ipv6_address+      ("validate_numeric", validateNumeric),+      ("validate_re", validateRe),+      -- validate_slength+      ("validate_string", validateString),+      -- validate_x509_rsa_key_pair+      -- values_at+      singleArgument "values" pvalues+      -- zip+    ] -singleArgument :: Text -> (PValue -> InterpreterMonad PValue) -> (Text, [PValue] -> InterpreterMonad PValue )+singleArgument :: Text -> (PValue -> InterpreterMonad PValue) -> (Text, [PValue] -> InterpreterMonad PValue) singleArgument fname ifunc = (fname, ofunc)   where     ofunc [x] = ifunc x-    ofunc _   = throwPosError (ppline fname <> "(): Expects a single argument.")+    ofunc _ = throwPosError (ppline fname <> "(): Expects a single argument.")  safeEmptyString :: (Text -> Text) -> Text -> Text safeEmptyString _ "" = ""-safeEmptyString f x  = f x+safeEmptyString f x = f x  stringArrayFunction :: (Text -> Text) -> [PValue] -> InterpreterMonad PValue stringArrayFunction f [PString s] = return (PString (f s))@@ -178,8 +183,8 @@  puppetAbs :: PValue -> InterpreterMonad PValue puppetAbs y = case y ^? _PValueNumber of-                  Just x  -> return $ _PValueNumber # abs x-                  Nothing -> throwPosError ("abs(): Expects a number, not" <+> pretty y)+  Just x -> return $ _PValueNumber # abs x+  Nothing -> throwPosError ("abs(): Expects a number, not" <+> pretty y)  suffix :: [PValue] -> InterpreterMonad PValue suffix = foofix "suffix" (flip (<>))@@ -196,33 +201,33 @@  foofix :: Doc -> (Text -> Text -> Text) -> [PValue] -> InterpreterMonad PValue foofix nm f args =-    case args of-      [PHash h] -> pure (PHash h)-      [PArray r] -> pure (PArray r)-      [_] -> throwPosError (nm <> ": expects the first argument to be an array or a hash")-      [PHash h, PString s] -> pure (PHash . HM.fromList . map (_1 %~ f s) . HM.toList $ h)-      [PArray r, PString s] -> pure (PArray (r & traverse . _PString %~ f s))-      [PHash _, _] -> throwPosError (nm <> ": expects the second argument to be a string")-      [PArray _, _] -> throwPosError (nm <> ": expects the second argument to be a string")-      [_, _] -> throwPosError (nm <> ": expects the first argument to be an array or a hash")-      _ -> throwPosError (nm <> ": expects two arguments")+  case args of+    [PHash h] -> pure (PHash h)+    [PArray r] -> pure (PArray r)+    [_] -> throwPosError (nm <> ": expects the first argument to be an array or a hash")+    [PHash h, PString s] -> pure (PHash . HM.fromList . map (_1 %~ f s) . HM.toList $ h)+    [PArray r, PString s] -> pure (PArray (r & traverse . _PString %~ f s))+    [PHash _, _] -> throwPosError (nm <> ": expects the second argument to be a string")+    [PArray _, _] -> throwPosError (nm <> ": expects the second argument to be a string")+    [_, _] -> throwPosError (nm <> ": expects the first argument to be an array or a hash")+    _ -> throwPosError (nm <> ": expects two arguments")  assertPrivate :: [PValue] -> InterpreterMonad PValue assertPrivate args =   case args of-    []   -> go Nothing+    [] -> go Nothing     [pv] -> resolvePValueString pv >>= go . Just-    _    -> throwPosError "assert_private: expects no or a single string argument"+    _ -> throwPosError "assert_private: expects no or a single string argument"   where     go :: Maybe Text -> InterpreterMonad PValue     go msg = do       scp <- use curScope       case scp of-        funScope:callerScope:_ ->+        funScope : callerScope : _ ->           let takeModule = Text.takeWhile (/= ':') . containerModName-          in if takeModule funScope == takeModule callerScope-               then return PUndef-               else throwPosError $ maybe ("assert_private: failed: " <> pretty funScope <> " is private") ppline msg+           in if takeModule funScope == takeModule callerScope+                then return PUndef+                else throwPosError $ maybe ("assert_private: failed: " <> pretty funScope <> " is private") ppline msg         _ -> return PUndef  any2array :: [PValue] -> InterpreterMonad PValue@@ -230,19 +235,20 @@ any2array [PHash h] = return (PArray lst)   where     lst = V.fromList $ concatMap arraypair $ HM.toList h-    arraypair (a,b) = [PString a, b]+    arraypair (a, b) = [PString a, b] any2array [x] = return (PArray (V.singleton x)) any2array x = return (PArray (V.fromList x))  base64 :: [PValue] -> InterpreterMonad PValue-base64 [pa,pb] = do+base64 [pa, pb] = do   b <- encodeUtf8 <$> resolvePValueString pb-  r <- resolvePValueString pa >>= \case-        "encode" -> return (B16.encode b)-        "decode" -> case B16.decode b of-                      (x, "") -> return x-                      _       -> error ("base64(): could not decode" <+> pretty pb) *> pure mempty-        a        -> throwPosError ("base64(): the first argument must be either 'encode' or 'decode', not" <+> ppline a)+  r <-+    resolvePValueString pa >>= \case+      "encode" -> return (B16.encode b)+      "decode" -> case B16.decode b of+        Right x -> return x+        Left msg -> mempty <$ error ("base64(): could not decode" <+> pretty pb <+> ppstring msg)+      a -> throwPosError ("base64(): the first argument must be either 'encode' or 'decode', not" <+> ppline a)   pure $ PString (decodeUtf8 r) base64 _ = throwPosError "base64(): Expects 2 arguments" @@ -267,18 +273,19 @@ puppetConcat = return . PArray . V.concat . map toArr   where     toArr (PArray x) = x-    toArr x          = V.singleton x+    toArr x = V.singleton x  puppetCount :: [PValue] -> InterpreterMonad PValue puppetCount [PArray x] = return (_PValueInteger # V.foldl' cnt 0 x)   where     cnt cur (PString "") = cur-    cnt cur PUndef       = cur-    cnt cur _            = cur + 1+    cnt cur PUndef = cur+    cnt cur _ = cur + 1 puppetCount [PArray x, y] = return (_PValueInteger # V.foldl' cnt 0 x)   where-    cnt cur z | y == z = cur + 1-              | otherwise = cur+    cnt cur z+      | y == z = cur + 1+      | otherwise = cur puppetCount _ = throwPosError "count(): expects 1 or 2 arguments"  delete :: [PValue] -> InterpreterMonad PValue@@ -287,7 +294,7 @@ delete [PHash h, z] = do   tz <- resolvePValueString z   return $ PHash (h & at tz .~ Nothing)-delete [a,_] = throwPosError ("delete(): First argument must be an Array, String, or Hash. Given:" <+> pretty a)+delete [a, _] = throwPosError ("delete(): First argument must be an Array, String, or Hash. Given:" <+> pretty a) delete _ = throwPosError "delete(): expects 2 arguments"  deleteAt :: [PValue] -> InterpreterMonad PValue@@ -296,18 +303,18 @@     let n = fromInteger gn         lr = V.length r         s1 = V.slice 0 n r-        s2 = V.slice (n+1) (lr - n - 1) r-    in  if V.length r <= n+        s2 = V.slice (n + 1) (lr - n - 1) r+     in if V.length r <= n           then throwPosError ("delete_at(): Out of bounds access detected, tried to remove index" <+> pretty z <+> "wheras the array only has" <+> pplines (show lr) <+> "elements")           else return (PArray (s1 <> s2))   _ -> throwPosError ("delete_at(): The second argument must be an integer, not" <+> pretty z)-deleteAt [x,_] = throwPosError ("delete_at(): expects its first argument to be an array, not" <+> pretty x)+deleteAt [x, _] = throwPosError ("delete_at(): expects its first argument to be an array, not" <+> pretty x) deleteAt _ = throwPosError "delete_at(): expects 2 arguments"  deleteUndefValues :: PValue -> InterpreterMonad PValue deleteUndefValues (PArray r) = return $ PArray $ V.filter (/= PUndef) r deleteUndefValues (PHash h) = return $ PHash $ HM.filter (/= PUndef) h-deleteUndefValues x =  throwPosError ("delete_undef_values(): Expects an Array or a Hash, not" <+> pretty x)+deleteUndefValues x = throwPosError ("delete_undef_values(): Expects an Array or a Hash, not" <+> pretty x)  _empty :: PValue -> InterpreterMonad PValue _empty = return . PBoolean . flip elem [PUndef, PString "", PString "undef", PArray V.empty, PHash HM.empty]@@ -324,7 +331,7 @@   where     flatten' :: PValue -> V.Vector PValue     flatten' (PArray x) = V.concatMap flatten' x-    flatten' x          = V.singleton x+    flatten' x = V.singleton x flatten x = throwPosError ("flatten(): Expects an Array, not" <+> pretty x)  getvar :: PValue -> InterpreterMonad PValue@@ -334,19 +341,19 @@ _grep [PArray vls, rawre] = do   regexp <- resolvePValueString rawre >>= compileRE   rvls <- for vls $ \v -> do-     r <- resolvePValueString v-     ismatched <- matchRE regexp r-     return (r, ismatched)+    r <- resolvePValueString v+    ismatched <- matchRE regexp r+    return (r, ismatched)   return $ PArray $ V.map (PString . fst) (V.filter snd rvls)-_grep [x,_] = throwPosError ("grep(): The first argument must be an Array, not" <+> pretty x)+_grep [x, _] = throwPosError ("grep(): The first argument must be an Array, not" <+> pretty x) _grep _ = throwPosError "grep(): Expected two arguments."  hash :: [PValue] -> InterpreterMonad PValue hash [PArray elems] = do   let xs = mapMaybe assocPairs $ List.chunksOf 2 $ V.toList elems-      assocPairs [a,b] = Just (a,b)-      assocPairs _     = Nothing-  PHash . HM.fromList <$> mapM (\(k,v) -> (,v) <$> resolvePValueString k) xs+      assocPairs [a, b] = Just (a, b)+      assocPairs _ = Nothing+  PHash . HM.fromList <$> mapM (\(k, v) -> (,v) <$> resolvePValueString k) xs hash _ = throwPosError "hash(): Expected and array."  isArray :: PValue -> InterpreterMonad PValue@@ -355,15 +362,17 @@ isDomainName :: PValue -> InterpreterMonad PValue isDomainName s = do   rs <- resolvePValueString s-  let ndrs = if Text.last rs == '.'-               then Text.init rs-               else rs+  let ndrs =+        if Text.last rs == '.'+          then Text.init rs+          else rs       prts = Text.splitOn "." ndrs-      checkPart x = not (Text.null x)-                      && (Text.length x <= 63)-                      && (Text.head x /= '-')-                      && (Text.last x /= '-')-                      && Text.all (\y -> Char.isAlphaNum y || y == '-') x+      checkPart x =+        not (Text.null x)+          && (Text.length x <= 63)+          && (Text.head x /= '-')+          && (Text.last x /= '-')+          && Text.all (\y -> Char.isAlphaNum y || y == '-') x   return $ PBoolean $ not (Text.null rs) && Text.length rs <= 255 && all checkPart prts  isInteger :: PValue -> InterpreterMonad PValue@@ -374,42 +383,42 @@  isString :: PValue -> InterpreterMonad PValue isString pv = return $ PBoolean $ case (pv ^? _PString, pv ^? _PValueNumber) of-                                     (_, Just _) -> False-                                     (Just _, _) -> True-                                     _           -> False+  (_, Just _) -> False+  (Just _, _) -> True+  _ -> False  isBool :: PValue -> InterpreterMonad PValue isBool = return . PBoolean . has _PBoolean  puppetJoin :: [PValue] -> InterpreterMonad PValue puppetJoin [PArray rr, PString interc] = do-    rrt <- mapM resolvePValueString (V.toList rr)-    return (PString (Text.intercalate interc rrt))-puppetJoin [_,_] = throwPosError "join(): expected an array of strings, and a string"+  rrt <- mapM resolvePValueString (V.toList rr)+  return (PString (Text.intercalate interc rrt))+puppetJoin [_, _] = throwPosError "join(): expected an array of strings, and a string" puppetJoin _ = throwPosError "join(): expected two arguments"  joinKeysToValues :: [PValue] -> InterpreterMonad PValue joinKeysToValues [PHash h, separator] = do-    ssep <- resolvePValueString separator-    fmap (PArray . V.fromList) $ forM (itoList h) $ \(k,v) -> do-        sv <- case v of-                  PUndef -> return ""-                  _      -> resolvePValueString v-        return  (PString (k <> ssep <> sv))+  ssep <- resolvePValueString separator+  fmap (PArray . V.fromList) $ forM (itoList h) $ \(k, v) -> do+    sv <- case v of+      PUndef -> return ""+      _ -> resolvePValueString v+    return (PString (k <> ssep <> sv)) joinKeysToValues _ = throwPosError "join_keys_to_values(): expects 2 arguments, an hash and a string"  keys :: PValue -> InterpreterMonad PValue keys (PHash h) = return (PArray $ V.fromList $ map PString $ HM.keys h)-keys x         = throwPosError ("keys(): Expects a Hash, not" <+> pretty x)+keys x = throwPosError ("keys(): Expects a Hash, not" <+> pretty x)  member :: [PValue] -> InterpreterMonad PValue member [PArray v, x] = return $ PBoolean (x `V.elem` v)-member _             = throwPosError "member() expects 2 arguments"+member _ = throwPosError "member() expects 2 arguments"  hasKey :: [PValue] -> InterpreterMonad PValue hasKey [PHash h, k] = do-    k' <- resolvePValueString k-    return (PBoolean (has (ix k') h))+  k' <- resolvePValueString k+  return (PBoolean (has (ix k') h)) hasKey [a, _] = throwPosError ("has_key(): expected a Hash, not" <+> pretty a) hasKey _ = throwPosError "has_key(): expected two arguments." @@ -417,24 +426,22 @@ merge xs   | length xs < 2 = throwPosError "merge(): Expects at least two hashes"   | otherwise =-    let hashcontents = mapM (preview _PHash) xs-    in-      case hashcontents of-        Nothing     -> throwPosError "merge(): Expects hashes"-        Just hashes -> return $ PHash (getDual $ foldMap Dual hashes)+      let hashcontents = mapM (preview _PHash) xs+       in case hashcontents of+            Nothing -> throwPosError "merge(): Expects hashes"+            Just hashes -> return $ PHash (getDual $ foldMap Dual hashes)  deepMerge :: [PValue] -> InterpreterMonad PValue deepMerge xs   | length xs < 2 = throwPosError "deep_merge(): Expects at least two hashes"   | otherwise =-    let hashcontents = mapM (preview _PHash) xs-    in-      case hashcontents of-        Nothing     -> throwPosError "deep_merge(): Expects hashes"-        Just hashes -> pure $ PHash (List.foldr1 rec_merge hashes)+      let hashcontents = mapM (preview _PHash) xs+       in case hashcontents of+            Nothing -> throwPosError "deep_merge(): Expects hashes"+            Just hashes -> pure $ PHash (List.foldr1 rec_merge hashes)   where     rec_merge :: Container PValue -> Container PValue -> Container PValue-    rec_merge a b =  HM.unionWith f a b+    rec_merge = HM.unionWith f     f :: PValue -> PValue -> PValue     f (PHash a) (PHash b) = PHash $ rec_merge a b     f _ h = h@@ -443,15 +450,15 @@ pick [] = throwPosError "pick(): must receive at least one non empty value" pick xs =   case filter (`notElem` [PUndef, PString "", PString "undef"]) xs of-    []    -> throwPosError "pick(): no value suitable to be picked"-    (x:_) -> return x+    [] -> throwPosError "pick(): no value suitable to be picked"+    (x : _) -> return x  pickDefault :: [PValue] -> InterpreterMonad PValue pickDefault [] = throwPosError "pick_default(): must receive at least one non empty value" pickDefault xs =   case filter (`notElem` [PUndef, PString "", PString "undef"]) xs of-    []    -> return (List.last xs)-    (x:_) -> return x+    [] -> return (List.last xs)+    (x : _) -> return x  size :: PValue -> InterpreterMonad PValue size (PHash h) = return (_PValueInteger # fromIntegral (HM.size h))@@ -471,9 +478,9 @@ sort :: PValue -> InterpreterMonad PValue sort (PArray s) =   let lst = V.toList s-      msort :: Ord a => Prism' PValue a -> Maybe PValue+      msort :: (Ord a) => Prism' PValue a -> Maybe PValue       msort prsm = PArray . V.fromList . map (review prsm) . List.sort <$> mapM (preview prsm) lst-  in  case msort _PString <|> msort _PNumber of+   in case msort _PString <|> msort _PNumber of         Just x -> return x         _ -> throwPosError "sort(): only homogeneous arrays of numbers or strings are allowed" sort x = throwPosError ("sort(): Expect to sort an array, not" <+> pretty x)@@ -483,53 +490,55 @@ str2Bool a@(PBoolean _) = return a str2Bool a = do   s <- resolvePValueString a-  let b | s `elem` ["", "1", "t", "y", "true", "yes"] = Just True-        | s `elem` [    "0", "f", "n", "false", "no"] = Just False+  let b+        | s `elem` ["", "1", "t", "y", "true", "yes"] = Just True+        | s `elem` ["0", "f", "n", "false", "no"] = Just False         | otherwise = Nothing   case b of-    Just x  -> return (PBoolean x)+    Just x -> return (PBoolean x)     Nothing -> throwPosError "str2bool(): Unknown type of boolean given"  validateAbsolutePath :: [PValue] -> InterpreterMonad PValue validateAbsolutePath [] = throwPosError "validateAbsolutePath(): wrong number of arguments, must be > 0" validateAbsolutePath a = mapM_ (resolvePValueString >=> validate) a >> return PUndef   where-    validate x | Text.head x == '/' = return ()-               | otherwise = throwPosError (ppline x <+> "is not an absolute path")+    validate x+      | Text.head x == '/' = return ()+      | otherwise = throwPosError (ppline x <+> "is not an absolute path")  validateArray :: [PValue] -> InterpreterMonad PValue validateArray [] = throwPosError "validate_array(): wrong number of arguments, must be > 0" validateArray x = mapM_ vb x >> return PUndef   where     vb (PArray _) = return ()-    vb y          = throwPosError (pretty y <+> "is not an array.")+    vb y = throwPosError (pretty y <+> "is not an array.")  validateBool :: [PValue] -> InterpreterMonad PValue validateBool [] = throwPosError "validate_bool(): wrong number of arguments, must be > 0" validateBool x = mapM_ vb x >> return PUndef   where     vb (PBoolean _) = return ()-    vb y            = throwPosError (pretty y <+> "is not a boolean.")+    vb y = throwPosError (pretty y <+> "is not a boolean.")  validateHash :: [PValue] -> InterpreterMonad PValue validateHash [] = throwPosError "validate_hash(): wrong number of arguments, must be > 0" validateHash x = mapM_ vb x >> return PUndef   where     vb (PHash _) = return ()-    vb y         = throwPosError (pretty y <+> "is not a hash.")+    vb y = throwPosError (pretty y <+> "is not a hash.")  validateNumeric :: [PValue] -> InterpreterMonad PValue validateNumeric [] = throwPosError "validate_numeric: invalid arguments"-validateNumeric (arr:extra) = do+validateNumeric (arr : extra) = do   (mn, mx) <- case extra of-                  [mx'] -> (Nothing,) . Just <$> resolvePValueNumber mx'-                  [PUndef, mi'] -> (,Nothing) . Just <$> resolvePValueNumber mi'-                  [mx',mi'] -> (,) <$> (Just <$> resolvePValueNumber mi') <*> (Just <$> resolvePValueNumber mx')-                  [] -> pure (Nothing, Nothing)-                  _ -> throwPosError "validate_numeric: invalid arguments"+    [mx'] -> (Nothing,) . Just <$> resolvePValueNumber mx'+    [PUndef, mi'] -> (,Nothing) . Just <$> resolvePValueNumber mi'+    [mx', mi'] -> (,) <$> (Just <$> resolvePValueNumber mi') <*> (Just <$> resolvePValueNumber mx')+    [] -> pure (Nothing, Nothing)+    _ -> throwPosError "validate_numeric: invalid arguments"   numbers <- case arr of-      PArray lst -> mapM resolvePValueNumber (V.toList lst)-      _          -> pure <$> resolvePValueNumber arr+    PArray lst -> mapM resolvePValueNumber (V.toList lst)+    _ -> pure <$> resolvePValueNumber arr   forM_ mn $ \mn' -> unless (all (>= mn') numbers) $ throwPosError "validate_numeric: failure"   forM_ mx $ \mx' -> unless (all (<= mx') numbers) $ throwPosError "validate_numeric: failure"   return PUndef@@ -548,7 +557,7 @@  validateString :: [PValue] -> InterpreterMonad PValue validateString [] = throwPosError "validate_string(): wrong number of arguments, must be > 0"-validateString x  = mapM_ resolvePValueString x >> return PUndef+validateString x = mapM_ resolvePValueString x >> return PUndef  validateInteger :: [PValue] -> InterpreterMonad PValue validateInteger [] = throwPosError "validate_integer(): wrong number of arguments, must be > 0"@@ -558,11 +567,11 @@     check n = unless (Scientific.isInteger n) $ throwPosError (msg n)     vb (PNumber n) = check n     vb (PString s) | Just n <- text2Scientific s = check n-    vb a           = throwPosError (msg a)+    vb a = throwPosError (msg a)  pvalues :: PValue -> InterpreterMonad PValue pvalues (PHash h) = return $ PArray (toVectorOf traverse h)-pvalues x         = throwPosError ("values(): expected a hash, not" <+> pretty x)+pvalues x = throwPosError ("values(): expected a hash, not" <+> pretty x)  -- dummy translate method from puppetlabs-translate (used in puppetlabs-docker for instance) translate :: [PValue] -> InterpreterMonad PValue@@ -571,3 +580,6 @@  toYaml :: PValue -> InterpreterMonad PValue toYaml s = pure $ PString $ Text.decodeUtf8 (Yaml.encode s)++toJson :: PValue -> InterpreterMonad PValue+toJson s = pure $ PString $ Text.decodeUtf8 (LByteString.toStrict (Aeson.encode s))
src/PuppetDB.hs view
@@ -1,34 +1,31 @@ -- | Common data types for PuppetDB. module PuppetDB-  ( dummyPuppetDB-  , getDefaultDB-  , pdbConnect-  , loadTestDB-  , generateWireCatalog-  , puppetDBFacts-  , module PuppetDB.Core-  ) where--import           XPrelude--import qualified Data.HashMap.Strict    as Map-import           Control.Arrow ((***))-import qualified Data.Text              as Text-import           Data.Vector.Lens-import           Network.HTTP.Client-import           System.Environment--import           Facter-import           Puppet.Language-import           PuppetDB.Core-import           PuppetDB.Remote-import           PuppetDB.TestDB-+  ( dummyPuppetDB,+    getDefaultDB,+    pdbConnect,+    loadTestDB,+    generateWireCatalog,+    puppetDBFacts,+    module PuppetDB.Core,+  )+where +import Control.Arrow ((***))+import qualified Data.HashMap.Strict as Map+import qualified Data.Text as Text+import Data.Vector.Lens+import Facter+import Network.HTTP.Client+import Puppet.Language+import PuppetDB.Core+import PuppetDB.Remote+import PuppetDB.TestDB+import System.Environment+import XPrelude  -- | Given a 'PDBType', will try return a sane default implementation. getDefaultDB :: PDBType -> IO (Either PrettyError (PuppetDBAPI IO))-getDefaultDB PDBDummy  = return (Right dummyPuppetDB)+getDefaultDB PDBDummy = return (Right dummyPuppetDB) getDefaultDB PDBRemote = do   let url = "http://localhost:8080"   mgr <- newManager defaultManagerSettings@@ -38,9 +35,8 @@     Just h -> loadTestDB (h <> "/.testdb")     Nothing -> fmap Right initTestDB - -- | A dummy implementation of 'PuppetDBAPI', that will return empty responses.-dummyPuppetDB :: Monad m => PuppetDBAPI m+dummyPuppetDB :: (Monad m) => PuppetDBAPI m dummyPuppetDB =   PuppetDBAPI     (return "dummy")@@ -58,56 +54,63 @@ generateWireCatalog :: NodeName -> FinalCatalog -> EdgeMap -> WireCatalog generateWireCatalog node cat edgemap = WireCatalog node "version" edges resources "uiid"   where-    edges     = toVectorOf (folded . to (\li -> PuppetEdge (li ^. linksrc) (li ^. linkdst) (li ^. linkType))) (concatOf folded edgemap)+    edges = toVectorOf (folded . to (\li -> PuppetEdge (li ^. linksrc) (li ^. linkdst) (li ^. linkType))) (concatOf folded edgemap)     resources = toVectorOf folded cat  puppetDBFacts :: NodeName -> PuppetDBAPI IO -> IO (HashMap Text PValue) puppetDBFacts node pdbapi =   runExceptT (getPDBFacts pdbapi (QEqual FCertname node)) >>= \case-    Right facts@(_:_) -> return (Map.fromList (map (\f -> (f ^. factInfoName, f ^. factInfoVal)) facts))+    Right facts@(_ : _) -> return (Map.fromList (map (\f -> (f ^. factInfoName, f ^. factInfoVal)) facts))     _ -> do-        rawFacts <- fmap concat (sequence [factNET, factRAM, factOS, fversion, factMountPoints, factOS, factUser, factUName, fenv, factProcessor])-        let ofacts = genFacts $ map (Text.pack *** Text.pack) rawFacts-            (hostname, ddomainname) = Text.break (== '.') node-            domainname = if Text.null ddomainname-                           then ""-                           else Text.tail ddomainname-            nfacts = genFacts [ ("fqdn", node)-                              , ("hostname", hostname)-                              , ("domain", domainname)-                              , ("rootrsa", "xxx")-                              , ("operatingsystem", "Ubuntu")-                              , ("puppetversion", "language-puppet")-                              , ("virtual", "xenu")-                              , ("clientcert", node)-                              , ("is_virtual", "true")-                              , ("concat_basedir", "/var/lib/puppet/concat")-                              ]-            allfacts = nfacts `Map.union` ofacts-            genFacts = Map.fromList-        return (allfacts & traverse %~ PString & buildOSHash)+      rawFacts <- fmap concat (sequence [factNET, factRAM, factOS, fversion, factMountPoints, factOS, factUser, factUName, fenv, factProcessor])+      let ofacts = genFacts $ map (Text.pack *** Text.pack) rawFacts+          (hostname, ddomainname) = Text.break (== '.') node+          domainname =+            if Text.null ddomainname+              then ""+              else Text.tail ddomainname+          nfacts =+            genFacts+              [ ("fqdn", node),+                ("hostname", hostname),+                ("domain", domainname),+                ("rootrsa", "xxx"),+                ("operatingsystem", "Ubuntu"),+                ("puppetversion", "language-puppet"),+                ("virtual", "xenu"),+                ("clientcert", node),+                ("is_virtual", "true"),+                ("concat_basedir", "/var/lib/puppet/concat")+              ]+          allfacts = nfacts `Map.union` ofacts+          genFacts = Map.fromList+      return (allfacts & traverse %~ PString & buildOSHash)  buildOSHash :: Facts -> Facts buildOSHash facts = case buildObject topLevel of-                      Nothing -> facts-                      Just os -> facts & at "os" ?~ os+  Nothing -> facts+  Just os -> facts & at "os" ?~ os   where     buildObject keys =       let nobject = foldl' addKey mempty keys-      in  if nobject == mempty+       in if nobject == mempty             then Nothing             else Just (PHash nobject)     g k = facts ^? ix k-    topLevel = [ ("name", g "operatingsystem")-               , ("family", g "osfamily")-               , ("release", buildObject [("major", g "lsbdistrelease"), ("full", g "lsbdistrelease")])-               , ("lsb", buildObject [ ("distcodename", g "lsbdistcodename")-                                     , ("distid", g "lsbdistid")-                                     , ("distdescription", g "lsbdistdescription")-                                     , ("distrelease", g "lsbdistrelease")-                                     , ("majdistrelease", g "lsbmajdistrelease")-                                     ])-               ]+    topLevel =+      [ ("name", g "operatingsystem"),+        ("family", g "osfamily"),+        ("release", buildObject [("major", g "lsbdistrelease"), ("full", g "lsbdistrelease")]),+        ( "lsb",+          buildObject+            [ ("distcodename", g "lsbdistcodename"),+              ("distid", g "lsbdistid"),+              ("distdescription", g "lsbdistdescription"),+              ("distrelease", g "lsbdistrelease"),+              ("majdistrelease", g "lsbmajdistrelease")+            ]+        )+      ]     addKey hash (k, mv) = case mv of-                           Nothing -> hash-                           Just v -> hash & at k ?~ v+      Nothing -> hash+      Just v -> hash & at k ?~ v
src/PuppetDB/Core.hs view
@@ -1,69 +1,74 @@ {-# LANGUAGE TemplateHaskell #-}-module PuppetDB.Core -where--import           XPrelude          hiding (Read)+module PuppetDB.Core where -import           Control.Lens-import           Data.Aeson-import qualified Data.List         as List-import           Data.Maybe        (fromJust)+import Control.Lens+import Data.Aeson+import qualified Data.List as List+import Data.Maybe (fromJust) import qualified Data.Maybe.Strict as S-import           Data.Time.Clock-import           GHC.Read          (Read (..))-import           Web.HttpApiData   (ToHttpApiData (..))--import           Facter-import           Puppet.Language+import Data.Time.Clock+import Facter+import GHC.Read (Read (..))+import Puppet.Language+import Web.HttpApiData (ToHttpApiData (..))+import XPrelude hiding (Read)  -- | The supported PuppetDB implementations. data PDBType-  = PDBRemote -- ^ Your standard PuppetDB, queried through the HTTP interface.-  | PDBDummy -- ^ A stupid stub, this is the default choice.-  | PDBTest -- ^ A slow but handy PuppetDB implementation that is backed by a YAML file.+  = -- | Your standard PuppetDB, queried through the HTTP interface.+    PDBRemote+  | -- | A stupid stub, this is the default choice.+    PDBDummy+  | -- | A slow but handy PuppetDB implementation that is backed by a YAML file.+    PDBTest   deriving (Eq)  instance Read PDBType where-  readsPrec _ r | isJust reml = [(PDBRemote, fromJust reml)]-                | isJust rems = [(PDBRemote, fromJust rems)]-                | isJust duml = [(PDBDummy, fromJust duml)]-                | isJust dums = [(PDBDummy, fromJust dums)]-                | isJust tstl = [(PDBTest, fromJust tstl)]-                | isJust tsts = [(PDBTest, fromJust tsts)]-                | otherwise   = []+  readsPrec _ r+    | isJust reml = [(PDBRemote, fromJust reml)]+    | isJust rems = [(PDBRemote, fromJust rems)]+    | isJust duml = [(PDBDummy, fromJust duml)]+    | isJust dums = [(PDBDummy, fromJust dums)]+    | isJust tstl = [(PDBTest, fromJust tstl)]+    | isJust tsts = [(PDBTest, fromJust tsts)]+    | otherwise = []     where       reml = List.stripPrefix "PDBRemote" r-      rems = List.stripPrefix "remote"    r-      duml = List.stripPrefix "PDBDummy"  r-      dums = List.stripPrefix "dummy"     r-      tstl = List.stripPrefix "PDBTest"   r-      tsts = List.stripPrefix "test"      r+      rems = List.stripPrefix "remote" r+      duml = List.stripPrefix "PDBDummy" r+      dums = List.stripPrefix "dummy" r+      tstl = List.stripPrefix "PDBTest" r+      tsts = List.stripPrefix "test" r  data NodeInfo = NodeInfo-    { _nodeInfoName        :: !NodeName-    , _nodeInfoDeactivated :: !Bool-    , _nodeInfoCatalogT    :: !(S.Maybe UTCTime)-    , _nodeInfoFactsT      :: !(S.Maybe UTCTime)-    , _nodeInfoReportT     :: !(S.Maybe UTCTime)-    }+  { _nodeInfoName :: !NodeName,+    _nodeInfoDeactivated :: !Bool,+    _nodeInfoCatalogT :: !(S.Maybe UTCTime),+    _nodeInfoFactsT :: !(S.Maybe UTCTime),+    _nodeInfoReportT :: !(S.Maybe UTCTime)+  }  makeClassy ''NodeInfo  instance ToJSON NodeInfo where-  toJSON p = object [ ("name"             , toJSON (p ^. nodeInfoName))-                    , ("deactivated"      , toJSON (p ^. nodeInfoDeactivated))-                    , ("catalog_timestamp", toJSON (p ^. nodeInfoCatalogT))-                    , ("facts_timestamp"  , toJSON (p ^. nodeInfoFactsT))-                    , ("report_timestamp" , toJSON (p ^. nodeInfoReportT))-                    ]+  toJSON p =+    object+      [ ("name", toJSON (p ^. nodeInfoName)),+        ("deactivated", toJSON (p ^. nodeInfoDeactivated)),+        ("catalog_timestamp", toJSON (p ^. nodeInfoCatalogT)),+        ("facts_timestamp", toJSON (p ^. nodeInfoFactsT)),+        ("report_timestamp", toJSON (p ^. nodeInfoReportT))+      ]  instance FromJSON NodeInfo where-  parseJSON (Object v) = NodeInfo <$> v .:  "name"-                                  <*> v .:? "deactivated" .!= False-                                  <*> v .:  "catalog_timestamp"-                                  <*> v .:  "facts_timestamp"-                                  <*> v .:  "report_timestamp"+  parseJSON (Object v) =+    NodeInfo+      <$> v .: "name"+      <*> v .:? "deactivated" .!= False+      <*> v .: "catalog_timestamp"+      <*> v .: "facts_timestamp"+      <*> v .: "report_timestamp"   parseJSON _ = fail "invalide node info"  -- | Pretty straightforward way to define the various PuppetDB queries@@ -79,35 +84,35 @@   | QNot (Query a)   | QEmpty -instance ToJSON a => ToJSON (Query a) where-  toJSON (QOr qs)          = toJSON ("or" : map toJSON qs)-  toJSON (QAnd qs)         = toJSON ("and" : map toJSON qs)-  toJSON (QNot q)          = toJSON [ "not" , toJSON q ]-  toJSON (QEqual flds val) = toJSON [ "=",  toJSON flds, toJSON val ]-  toJSON (QMatch flds val) = toJSON [ "~",  toJSON flds, toJSON val ]-  toJSON (QL     flds val) = toJSON [ "<",  toJSON flds, toJSON val ]-  toJSON (QG     flds val) = toJSON [ ">",  toJSON flds, toJSON val ]-  toJSON (QLE    flds val) = toJSON [ "<=", toJSON flds, toJSON val ]-  toJSON (QGE    flds val) = toJSON [ ">=", toJSON flds, toJSON val ]-  toJSON  QEmpty           = Null+instance (ToJSON a) => ToJSON (Query a) where+  toJSON (QOr qs) = toJSON ("or" : map toJSON qs)+  toJSON (QAnd qs) = toJSON ("and" : map toJSON qs)+  toJSON (QNot q) = toJSON ["not", toJSON q]+  toJSON (QEqual flds val) = toJSON ["=", toJSON flds, toJSON val]+  toJSON (QMatch flds val) = toJSON ["~", toJSON flds, toJSON val]+  toJSON (QL flds val) = toJSON ["<", toJSON flds, toJSON val]+  toJSON (QG flds val) = toJSON [">", toJSON flds, toJSON val]+  toJSON (QLE flds val) = toJSON ["<=", toJSON flds, toJSON val]+  toJSON (QGE flds val) = toJSON [">=", toJSON flds, toJSON val]+  toJSON QEmpty = Null -instance ToJSON a => ToHttpApiData (Query a) where+instance (ToJSON a) => ToHttpApiData (Query a) where   toHeader = Control.Lens.view strict . encode   toUrlPiece = decodeUtf8 . toHeader -instance FromJSON a => FromJSON (Query a) where+instance (FromJSON a) => FromJSON (Query a) where   parseJSON Null = pure QEmpty   parseJSON (Array elems) = case toList elems of-    ("or":xs)          -> QOr    <$> mapM parseJSON xs-    ("and":xs)         -> QAnd   <$> mapM parseJSON xs-    ["not",x]          -> QNot   <$> parseJSON x-    [ "=", flds, val ] -> QEqual <$> parseJSON flds    <*> parseJSON val-    [ "~", flds, val ] -> QEqual <$> parseJSON flds    <*> parseJSON val-    [ ">", flds, val ] -> QG     <$> parseJSON flds    <*> parseJSON val-    [ "<", flds, val ] -> QL     <$> parseJSON flds    <*> parseJSON val-    [">=", flds, val ] -> QGE    <$> parseJSON flds    <*> parseJSON val-    ["<=", flds, val ] -> QLE    <$> parseJSON flds    <*> parseJSON val-    x                  -> fail ("unknown query" ++ show x)+    ("or" : xs) -> QOr <$> mapM parseJSON xs+    ("and" : xs) -> QAnd <$> mapM parseJSON xs+    ["not", x] -> QNot <$> parseJSON x+    ["=", flds, val] -> QEqual <$> parseJSON flds <*> parseJSON val+    ["~", flds, val] -> QEqual <$> parseJSON flds <*> parseJSON val+    [">", flds, val] -> QG <$> parseJSON flds <*> parseJSON val+    ["<", flds, val] -> QL <$> parseJSON flds <*> parseJSON val+    [">=", flds, val] -> QGE <$> parseJSON flds <*> parseJSON val+    ["<=", flds, val] -> QLE <$> parseJSON flds <*> parseJSON val+    x -> fail ("unknown query" ++ show x)   parseJSON _ = fail "Expected an array"  -- | Fields for the fact endpoint@@ -117,27 +122,27 @@   | FCertname  instance ToJSON FactField where-  toJSON FName     = "name"-  toJSON FValue    = "value"+  toJSON FName = "name"+  toJSON FValue = "value"   toJSON FCertname = "certname"  instance FromJSON FactField where-  parseJSON "name"     = pure FName-  parseJSON "value"    = pure FValue+  parseJSON "name" = pure FName+  parseJSON "value" = pure FValue   parseJSON "certname" = pure FCertname-  parseJSON _          = fail "Can't parse fact field"+  parseJSON _ = fail "Can't parse fact field"  -- | Fields for the node endpoint data NodeField = NName | NFact Text  instance ToJSON NodeField where-  toJSON NName     = "name"-  toJSON (NFact t) = toJSON [ "fact", t ]+  toJSON NName = "name"+  toJSON (NFact t) = toJSON ["fact", t]  instance FromJSON NodeField where   parseJSON (Array xs) = case toList xs of-                             ["fact", x] -> NFact <$> parseJSON x-                             _           -> fail "Invalid field syntax"+    ["fact", x] -> NFact <$> parseJSON x+    _ -> fail "Invalid field syntax"   parseJSON (String "name") = pure NName   parseJSON _ = fail "invalid field" @@ -153,37 +158,43 @@   | RLine  instance ToJSON ResourceField where-  toJSON RTag           = "tag"-  toJSON RCertname      = "certname"+  toJSON RTag = "tag"+  toJSON RCertname = "certname"   toJSON (RParameter t) = toJSON ["parameter", t]-  toJSON RType          = "type"-  toJSON RTitle         = "title"-  toJSON RExported      = "exported"-  toJSON RFile          = "file"-  toJSON RLine          = "line"+  toJSON RType = "type"+  toJSON RTitle = "title"+  toJSON RExported = "exported"+  toJSON RFile = "file"+  toJSON RLine = "line"  instance FromJSON ResourceField where   parseJSON (Array xs) =     case toList xs of       ["parameter", x] -> RParameter <$> parseJSON x-      _                -> fail "Invalid field syntax"-  parseJSON (String "tag"     ) = pure RTag+      _ -> fail "Invalid field syntax"+  parseJSON (String "tag") = pure RTag   parseJSON (String "certname") = pure RCertname-  parseJSON (String "type"    ) = pure RType-  parseJSON (String "title"   ) = pure RTitle+  parseJSON (String "type") = pure RType+  parseJSON (String "title") = pure RTitle   parseJSON (String "exported") = pure RExported-  parseJSON (String "file"    ) = pure RFile-  parseJSON (String "line"    ) = pure RLine+  parseJSON (String "file") = pure RFile+  parseJSON (String "line") = pure RLine   parseJSON _ = fail "invalid field"  data PuppetDBAPI m = PuppetDBAPI-  { pdbInformation     :: m Doc-  , replaceCatalog     :: WireCatalog         -> ExceptT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>-  , replaceFacts       :: [(NodeName, Facts)] -> ExceptT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>-  , deactivateNode     :: NodeName            -> ExceptT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>-  , getPDBFacts        :: Query FactField     -> ExceptT PrettyError m [FactInfo] -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>-  , getResources       :: Query ResourceField -> ExceptT PrettyError m [Resource] -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>-  , getNodes           :: Query NodeField     -> ExceptT PrettyError m [NodeInfo]-  , commitDB           ::                        ExceptT PrettyError m () -- ^ This is only here to tell the test PuppetDB to save its content to disk.-  , getResourcesOfNode :: NodeName -> Query ResourceField -> ExceptT PrettyError m [Resource]+  { pdbInformation :: m Doc,+    -- | <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>+    replaceCatalog :: WireCatalog -> ExceptT PrettyError m (),+    -- | <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>+    replaceFacts :: [(NodeName, Facts)] -> ExceptT PrettyError m (),+    -- | <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>+    deactivateNode :: NodeName -> ExceptT PrettyError m (),+    -- | <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>+    getPDBFacts :: Query FactField -> ExceptT PrettyError m [FactInfo],+    -- | <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>+    getResources :: Query ResourceField -> ExceptT PrettyError m [Resource],+    getNodes :: Query NodeField -> ExceptT PrettyError m [NodeInfo],+    -- | This is only here to tell the test PuppetDB to save its content to disk.+    commitDB :: ExceptT PrettyError m (),+    getResourcesOfNode :: NodeName -> Query ResourceField -> ExceptT PrettyError m [Resource]   }
src/PuppetDB/Remote.hs view
@@ -1,25 +1,25 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds         #-}-{-# LANGUAGE TypeFamilies      #-}-{-# LANGUAGE TypeOperators     #-}-module PuppetDB.Remote (pdbConnect) where--import           XPrelude+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} -import           Network.HTTP.Client (Manager)-import           Servant.API-import           Servant.Client+module PuppetDB.Remote (pdbConnect) where -import           Facter-import           Puppet.Language-import           PuppetDB.Core+import Facter+import Network.HTTP.Client (Manager)+import Puppet.Language+import PuppetDB.Core+import Servant.API+import Servant.Client+import XPrelude -type PDBAPIv3 =    "nodes"     :> QueryParam "query" (Query NodeField)       :> Get '[JSON] [NodeInfo]-              :<|> "nodes"     :> Capture "resourcename" Text :> "resources" :> QueryParam "query" (Query ResourceField) :> Get '[JSON] [Resource]-              :<|> "facts"     :> QueryParam "query" (Query FactField)       :> Get '[JSON] [FactInfo]-              :<|> "resources" :> QueryParam "query" (Query ResourceField)   :> Get '[JSON] [Resource]+type PDBAPIv3 =+  "nodes" :> QueryParam "query" (Query NodeField) :> Get '[JSON] [NodeInfo]+    :<|> "nodes" :> Capture "resourcename" Text :> "resources" :> QueryParam "query" (Query ResourceField) :> Get '[JSON] [Resource]+    :<|> "facts" :> QueryParam "query" (Query FactField) :> Get '[JSON] [FactInfo]+    :<|> "resources" :> QueryParam "query" (Query ResourceField) :> Get '[JSON] [Resource]  type PDBAPI = "v3" :> PDBAPIv3 @@ -40,22 +40,24 @@ pdbConnect mgr url = do   url' <- parseBaseUrl url   let env = mkClientEnv mgr url'-  pure $ Right $ PuppetDBAPI-    (return (ppline $ fromString url))-    (const (throwError "operation not supported"))-    (const (throwError "operation not supported"))-    (const (throwError "operation not supported"))-    (\q -> prettyError $ runClientM (sgetFacts (Just q)) env)-    (\q -> prettyError $ runClientM (sgetResources (Just q)) env)-    (\q -> prettyError $ runClientM (sgetNodes (Just q)) env)-    (throwError "operation not supported")-    (\node q -> prettyError $ runClientM (sgetNodeResources node (Just q)) env)+  pure $+    Right $+      PuppetDBAPI+        (return (ppline $ fromString url))+        (const (throwError "operation not supported"))+        (const (throwError "operation not supported"))+        (const (throwError "operation not supported"))+        (\q -> prettyError $ runClientM (sgetFacts (Just q)) env)+        (\q -> prettyError $ runClientM (sgetResources (Just q)) env)+        (\q -> prettyError $ runClientM (sgetNodes (Just q)) env)+        (throwError "operation not supported")+        (\node q -> prettyError $ runClientM (sgetNodeResources node (Just q)) env)   where-   sgetNodes :: Maybe (Query NodeField) -> ClientM [NodeInfo]-   sgetNodeResources :: Text -> Maybe (Query ResourceField) -> ClientM [Resource]-   sgetFacts :: Maybe (Query FactField) -> ClientM [FactInfo]-   sgetResources :: Maybe (Query ResourceField) -> ClientM [Resource]-   (sgetNodes :<|> sgetNodeResources :<|> sgetFacts :<|> sgetResources) = client api+    sgetNodes :: Maybe (Query NodeField) -> ClientM [NodeInfo]+    sgetNodeResources :: Text -> Maybe (Query ResourceField) -> ClientM [Resource]+    sgetFacts :: Maybe (Query FactField) -> ClientM [FactInfo]+    sgetResources :: Maybe (Query ResourceField) -> ClientM [Resource]+    (sgetNodes :<|> sgetNodeResources :<|> sgetFacts :<|> sgetResources) = client api -   prettyError :: IO (Either ClientError b)  -> ExceptT PrettyError IO b-   prettyError = ExceptT . fmap (_Left %~ PrettyError . pplines . show)+    prettyError :: IO (Either ClientError b) -> ExceptT PrettyError IO b+    prettyError = ExceptT . fmap (_Left %~ PrettyError . pplines . show)
src/PuppetDB/TestDB.hs view
@@ -1,35 +1,33 @@ {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE TemplateHaskell        #-}+{-# LANGUAGE TemplateHaskell #-}  -- | A stub implementation of PuppetDB, backed by a YAML file. module PuppetDB.TestDB-       ( loadTestDB-       , initTestDB-) where--import           XPrelude--import           Control.Concurrent.STM-import           Data.Aeson-import qualified Data.CaseInsensitive   as CaseInsensitive-import qualified Data.HashMap.Strict    as HM-import qualified Data.HashSet           as HS-import qualified Data.Maybe.Strict      as S-import qualified Data.Text              as Text-import qualified Data.Vector            as V-import           Data.Yaml              (ParseException (..), YamlException (..), YamlMark(..))-import qualified Data.Yaml              as Yaml-import           Text.Megaparsec.Pos+  ( loadTestDB,+    initTestDB,+  )+where -import           Facter-import           Puppet.Language-import           PuppetDB.Core+import Control.Concurrent.STM+import Data.Aeson hiding (AesonException)+import qualified Data.CaseInsensitive as CaseInsensitive+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.Maybe.Strict as S+import qualified Data.Text as Text+import qualified Data.Vector as V+import Data.Yaml (ParseException (..), YamlException (..), YamlMark (..))+import qualified Data.Yaml as Yaml+import Facter+import Puppet.Language+import PuppetDB.Core+import Text.Megaparsec.Pos+import XPrelude  data DBContent = DBContent-  { _dbcontentResources   :: Container WireCatalog-  , _dbcontentFacts       :: Container Facts-  , _dbcontentBackingFile :: Maybe FilePath+  { _dbcontentResources :: Container WireCatalog,+    _dbcontentFacts :: Container Facts,+    _dbcontentBackingFile :: Maybe FilePath   }  makeLensesWith abbreviatedFields ''DBContent@@ -38,7 +36,7 @@  instance FromJSON DBContent where   parseJSON (Object v) = DBContent <$> v .: "resources" <*> v .: "facts" <*> pure Nothing-  parseJSON _          = mempty+  parseJSON _ = mempty  instance ToJSON DBContent where   toJSON (DBContent r f _) = object [("resources", toJSON r), ("facts", toJSON f)]@@ -49,16 +47,17 @@   Yaml.decodeFileEither fp >>= \case     Left (OtherParseException rr) -> return (Left (PrettyError (pplines (show rr))))     Left (InvalidYaml Nothing) -> baseError "Unknown error"-    Left (InvalidYaml (Just (YamlException s))) -> if take 21 s == "Yaml file not found: "-                                                      then newFile-                                                      else baseError (ppstring s)+    Left (InvalidYaml (Just (YamlException s))) ->+      if take 21 s == "Yaml file not found: "+        then newFile+        else baseError (ppstring s)     Left (InvalidYaml (Just (YamlParseException pb ctx (YamlMark _ l c)))) -> baseError $ red (ppstring pb <+> ppstring ctx) <+> "at line" <+> pretty l <> ", column" <+> pretty c     Left (AesonException e) -> baseError (fromString e)     Left _ -> newFile-    Right x -> fmap Right (genDBAPI (x & backingFile ?~ fp ))+    Right x -> fmap Right (genDBAPI (x & backingFile ?~ fp))   where     baseError r = return $ Left $ PrettyError $ "Could not parse" <+> pptext fp <> ":" <+> r-    newFile = Right <$> genDBAPI (newDB & backingFile ?~ fp )+    newFile = Right <$> genDBAPI (newDB & backingFile ?~ fp)  -- | Starts a new PuppetDB, without any backing file. initTestDB :: IO (PuppetDBAPI IO)@@ -70,16 +69,17 @@ genDBAPI :: DBContent -> IO (PuppetDBAPI IO) genDBAPI db = do   d <- newTVarIO db-  return $! PuppetDBAPI (dbapiInfo d)-                        (replCat d)-                        (replFacts d)-                        (deactivate d)-                        (getFcts d)-                        (getRes d)-                        (getNds d)-                        (commit d)-                        (getResNode d)-+  return $!+    PuppetDBAPI+      (dbapiInfo d)+      (replCat d)+      (replFacts d)+      (deactivate d)+      (getFcts d)+      (getRes d)+      (getNds d)+      (commit d)+      (getResNode d)  data Extracted   = EText Text@@ -91,101 +91,105 @@ resolveQuery f (QEqual a t) =   \v -> case f a v of     EText tt -> CaseInsensitive.mk tt == CaseInsensitive.mk t-    ESet ss  -> ss ^. contains t-    _        -> False-resolveQuery f (QNot q)  = not . resolveQuery f q-resolveQuery f (QG a i)  = ncompare (>) f a i-resolveQuery f (QL a i)  = ncompare (<) f a i+    ESet ss -> ss ^. contains t+    _ -> False+resolveQuery f (QNot q) = not . resolveQuery f q+resolveQuery f (QG a i) = ncompare (>) f a i+resolveQuery f (QL a i) = ncompare (<) f a i resolveQuery f (QGE a i) = ncompare (>=) f a i resolveQuery f (QLE a i) = ncompare (<=) f a i resolveQuery _ (QMatch _ _) = const False resolveQuery f (QAnd qs) = \v -> all (\q -> resolveQuery f q v) qs-resolveQuery f (QOr qs)  = \v -> any (\q -> resolveQuery f q v) qs+resolveQuery f (QOr qs) = \v -> any (\q -> resolveQuery f q v) qs  dbapiInfo :: DB -> IO Doc dbapiInfo db = do   c <- readTVarIO db   case c ^. backingFile of     Nothing -> return "TestDB"-    Just v  -> return ("TestDB" <+> ppstring v)+    Just v -> return ("TestDB" <+> ppstring v) -ncompare :: (Integer -> Integer -> Bool) ->  (a -> b -> Extracted) -> a -> Integer -> b -> Bool+ncompare :: (Integer -> Integer -> Bool) -> (a -> b -> Extracted) -> a -> Integer -> b -> Bool ncompare operation f a i v =   case f a v of     EText tt -> case PString tt ^? _PValueInteger of-                    Just ii -> operation i ii-                    _       -> False+      Just ii -> operation i ii+      _ -> False     _ -> False  replCat :: DB -> WireCatalog -> ExceptT PrettyError IO () replCat db wc = liftIO $ atomically $ modifyTVar db (resources . at (wc ^. wireCatalogNodename) ?~ wc)  replFacts :: DB -> [(NodeName, Facts)] -> ExceptT PrettyError IO ()-replFacts db lst = liftIO $ atomically $ modifyTVar db $-                    facts %~ (\r -> foldl' (\curr (n,f) -> curr & at n ?~ f) r lst)+replFacts db lst =+  liftIO $+    atomically $+      modifyTVar db $+        facts %~ (\r -> foldl' (\curr (n, f) -> curr & at n ?~ f) r lst)  deactivate :: DB -> NodeName -> ExceptT PrettyError IO ()-deactivate db n = liftIO $ atomically $ modifyTVar db $-                    (resources . at n .~ Nothing) . (facts . at n .~ Nothing)+deactivate db n =+  liftIO $+    atomically $+      modifyTVar db $+        (resources . at n .~ Nothing) . (facts . at n .~ Nothing)  getFcts :: DB -> Query FactField -> ExceptT PrettyError IO [FactInfo] getFcts db f = fmap (filter (resolveQuery factQuery f) . toFactInfo) (liftIO $ readTVarIO db)-    where-        toFactInfo :: DBContent -> [FactInfo]-        toFactInfo = concatMap gf .  HM.toList . _dbcontentFacts-            where-                gf (k,n) = do-                    (fn,fv) <- HM.toList n-                    return $ FactInfo k fn fv-        factQuery :: FactField -> FactInfo -> Extracted-        factQuery t = EText . view l-            where-                l = case t of-                        FName     -> factInfoName-                        FValue    -> factInfoVal . _PString-                        FCertname -> factInfoNodename+  where+    toFactInfo :: DBContent -> [FactInfo]+    toFactInfo = concatMap gf . HM.toList . _dbcontentFacts+      where+        gf (k, n) = do+          (fn, fv) <- HM.toList n+          return $ FactInfo k fn fv+    factQuery :: FactField -> FactInfo -> Extracted+    factQuery t = EText . view l+      where+        l = case t of+          FName -> factInfoName+          FValue -> factInfoVal . _PString+          FCertname -> factInfoNodename  resourceQuery :: ResourceField -> Resource -> Extracted resourceQuery RTag r = r ^. rtags . to ESet resourceQuery RCertname r = r ^. rnode . to EText-resourceQuery (RParameter p) r = case r ^? rattributes . ix p . _PString of-                                     Just s  -> EText s-                                     Nothing -> ENil+resourceQuery (RParameter p) r = maybe ENil EText (r ^? rattributes . ix p . _PString) resourceQuery RType r = r ^. rid . itype . to EText resourceQuery RTitle r = r ^. rid . iname . to EText-resourceQuery RExported r = if r ^. rvirtuality == Exported-                                then EText "true"-                                else EText "false"+resourceQuery RExported r =+  if r ^. rvirtuality == Exported+    then EText "true"+    else EText "false" resourceQuery RFile r = r ^. rpos . _1 . to sourceName . to Text.pack . to EText resourceQuery RLine r = r ^. rpos . _1 . to sourceLine . to show . to Text.pack . to EText  getRes :: DB -> Query ResourceField -> ExceptT PrettyError IO [Resource] getRes db f = fmap (filter (resolveQuery resourceQuery f) . toResources) (liftIO $ readTVarIO db)-    where-        toResources :: DBContent -> [Resource]-        toResources = concatMap (V.toList . view wireCatalogResources) .  HM.elems . view resources+  where+    toResources :: DBContent -> [Resource]+    toResources = concatMap (V.toList . view wireCatalogResources) . HM.elems . view resources  getResNode :: DB -> NodeName -> Query ResourceField -> ExceptT PrettyError IO [Resource] getResNode db nn f = do-    c <- liftIO $ readTVarIO db-    case c ^. resources . at nn of-        Just cnt -> return $ filter (resolveQuery resourceQuery f) $ V.toList $ cnt ^. wireCatalogResources-        Nothing -> throwError "Unknown node"+  c <- liftIO $ readTVarIO db+  case c ^. resources . at nn of+    Just cnt -> return $ filter (resolveQuery resourceQuery f) $ V.toList $ cnt ^. wireCatalogResources+    Nothing -> throwError "Unknown node"  commit :: DB -> ExceptT PrettyError IO () commit db = do-    dbc <- liftIO $ atomically $ readTVar db-    case dbc ^. backingFile of-        Nothing -> throwError "No backing file defined"-        Just bf -> liftIO (Yaml.encodeFile bf dbc `catches` [ ])+  dbc <- liftIO $ readTVarIO db+  case dbc ^. backingFile of+    Nothing -> throwError "No backing file defined"+    Just bf -> liftIO (Yaml.encodeFile bf dbc `catches` [])  getNds :: DB -> Query NodeField -> ExceptT PrettyError IO [NodeInfo] getNds db QEmpty = fmap toNodeInfo (liftIO $ readTVarIO db)-    where-        toNodeInfo :: DBContent -> [NodeInfo]-        toNodeInfo = fmap g . HM.keys . _dbcontentFacts-             where-                g :: NodeName -> NodeInfo-                g = \n -> NodeInfo n False S.Nothing S.Nothing S.Nothing-+  where+    toNodeInfo :: DBContent -> [NodeInfo]+    toNodeInfo = fmap g . HM.keys . _dbcontentFacts+      where+        g :: NodeName -> NodeInfo+        g n = NodeInfo n False S.Nothing S.Nothing S.Nothing getNds _ _ = throwError "getNds with query not implemented"
src/XPrelude.hs view
@@ -1,11 +1,11 @@-{-|-General specific prelude for language-puppet.-Customization of the <https://hackage.haskell.org/package/protolude Protolude> with extra specific utilities.--}+-- |+-- General specific prelude for language-puppet.+-- Customization of the <https://hackage.haskell.org/package/protolude Protolude> with extra specific utilities. module XPrelude-  ( module XPrelude.Extra-  , module XPrelude.PP-  ) where+  ( module XPrelude.Extra,+    module XPrelude.PP,+  )+where  import XPrelude.Extra import XPrelude.PP hiding (width, (</>))
src/XPrelude/Extra.hs view
@@ -1,72 +1,101 @@-{-# OPTIONS_HADDOCK ignore-exports #-} {-# LANGUAGE RankNTypes #-}-module XPrelude.Extra (-      module Exports-    , String-    , Container-    , unwrapError-    , dropInitialColons-    , strictifyEither-    , scientific2text-    , text2Scientific-    , ifromList, ikeys, ifromListWith, iunionWith, iinsertWith-    -- * Logger-    , loggerName-    , logDebug-    , logDebugStr-    , logInfo-    , logInfoStr-    , logWarning-    , logWarningStr-    , logError-    , logErrorStr-    , logCritical-    , logCriticalStr-    -- * Lenses for json-    , key-    , _String-    , avalues-    , nth-) where+{-# OPTIONS_HADDOCK ignore-exports #-} -import           Protolude                        as Exports hiding (Down, Infix, Prefix, Selector,-                                                              State, StateT, Strict, break, check,-                                                              evalState, evalStateT, execState,-                                                              execStateT, from, hash, list,-                                                              moduleName, runState, runStateT,-                                                              sourceColumn, sourceLine, to, typeOf,-                                                              uncons, unsnoc, withState, (%), (<&>),-                                                              (<.>))+module XPrelude.Extra+  ( module Exports,+    String,+    Container,+    unwrapError,+    dropInitialColons,+    strictifyEither,+    scientific2text,+    text2Scientific,+    ifromList,+    ikeys,+    ifromListWith,+    iunionWith,+    iinsertWith, -import           Control.Exception.Lens           as Exports (catching)-import           Control.Lens                     as Exports hiding (Strict, argument, noneOf, op,-                                                              (<.>))-import           Control.Monad                    as Exports (fail)-import           Control.Monad.Trans.Except       as Exports (catchE, except, throwE)-import           Control.Monad.Trans.Maybe        as Exports (runMaybeT)-import           Data.Aeson                       as Exports (FromJSON, ToJSON, fromJSON, toJSON)-import           Data.Aeson                       (Value (..))-import           Data.HashMap.Strict              as Exports (HashMap)-import           Data.HashSet                     as Exports (HashSet)-import           Data.Scientific                  as Exports (Scientific)-import           Data.Set                         as Exports (Set)-import           Data.String                      as Exports (IsString (..))-import           Data.Tuple.Strict                as Exports (Pair (..))-import           Data.Vector                      as Exports (Vector)-import           Text.Regex.PCRE.ByteString.Utils as Exports (Regex)+    -- * Logger+    loggerName,+    logDebug,+    logDebugStr,+    logInfo,+    logInfoStr,+    logWarning,+    logWarningStr,+    logError,+    logErrorStr,+    logCritical,+    logCriticalStr, -import           Data.Attoparsec.Text             (parseOnly, rational)-import qualified Data.Either.Strict               as S-import qualified Data.HashMap.Strict              as Map-import qualified Data.HashMap.Strict              as HM-import qualified Data.HashSet                     as HS-import qualified Data.Scientific                  as Scientific-import           Data.String                      (String)-import qualified Data.Text                        as Text-import qualified Data.Vector                      as V-import qualified System.Log.Logger                as Log-import           XPrelude.PP+    -- * Lenses for json+    avalues,+    nth,+  )+where +import Control.Exception.Lens as Exports (catching)+import Control.Lens as Exports hiding+  ( Strict,+    argument,+    noneOf,+    op,+    (<.>),+  )+import Control.Monad as Exports (fail)+import Control.Monad.Trans.Except as Exports (except)+import Control.Monad.Trans.Maybe as Exports (runMaybeT)+import Data.Aeson (Value (..))+import Data.Aeson as Exports (FromJSON, ToJSON, fromJSON, toJSON)+import Data.Aeson.Lens as Exports (key, _Array, _Object, _String)+import Data.Attoparsec.Text (parseOnly, rational)+import qualified Data.Either.Strict as S+import Data.HashMap.Strict as Exports (HashMap)+import qualified Data.HashMap.Strict as Map+import Data.HashSet as Exports (HashSet)+import qualified Data.HashSet as HS+import Data.Scientific as Exports (Scientific)+import qualified Data.Scientific as Scientific+import Data.String (String)+import Data.String as Exports (IsString (..))+import qualified Data.Text as Text+import Data.Tuple.Strict as Exports (Pair (..))+import Data.Vector as Exports (Vector)+import Protolude as Exports hiding+  ( Down,+    Infix,+    Prefix,+    Selector,+    State,+    StateT,+    break,+    check,+    evalState,+    evalStateT,+    execState,+    execStateT,+    from,+    hash,+    list,+    moduleName,+    runState,+    runStateT,+    sourceColumn,+    sourceLine,+    to,+    typeOf,+    uncons,+    unsnoc,+    withState,+    (%),+    (<&>),+    (<.>),+  )+import qualified System.Log.Logger as Log+import Text.Regex.PCRE.ByteString.Utils as Exports (Regex)+import XPrelude.PP+ type Container = Map.HashMap Text  text2Scientific :: Text -> Maybe Scientific@@ -75,37 +104,37 @@ scientific2text :: Scientific -> Text scientific2text n =   case Scientific.floatingOrInteger n of-    Left r  -> show (r :: Double)+    Left r -> show (r :: Double)     Right i -> show (i :: Integer)  strictifyEither :: Either a b -> S.Either a b-strictifyEither (Left x)  = S.Left x+strictifyEither (Left x) = S.Left x strictifyEither (Right x) = S.Right x  -- | Helper for hashmap, in case we want another kind of map. ifromList :: (Monoid m, At m, Foldable f) => f (Index m, IxValue m) -> m-{-# INLINABLE ifromList #-}-ifromList = foldl' (\curm (k,v) -> curm & at k ?~ v) mempty+{-# INLINEABLE ifromList #-}+ifromList = foldl' (\curm (k, v) -> curm & at k ?~ v) mempty  -- | Return all the keys of a map in a set. ikeys :: (Eq k, Hashable k) => HashMap k v -> HS.HashSet k-{-# INLINABLE ikeys #-}+{-# INLINEABLE ikeys #-} ikeys = HS.fromList . Map.keys  ifromListWith :: (Monoid m, At m, Foldable f) => (IxValue m -> IxValue m -> IxValue m) -> f (Index m, IxValue m) -> m-{-# INLINABLE ifromListWith #-}-ifromListWith f = foldl' (\curmap (k,v) -> iinsertWith f k v curmap) mempty+{-# INLINEABLE ifromListWith #-}+ifromListWith f = foldl' (\curmap (k, v) -> iinsertWith f k v curmap) mempty -iinsertWith :: At m => (IxValue m -> IxValue m -> IxValue m) -> Index m -> IxValue m -> m -> m-{-# INLINABLE iinsertWith #-}+iinsertWith :: (At m) => (IxValue m -> IxValue m -> IxValue m) -> Index m -> IxValue m -> m -> m+{-# INLINEABLE iinsertWith #-} iinsertWith f k v m =   m & at k %~ mightreplace   where-    mightreplace Nothing  = Just v+    mightreplace Nothing = Just v     mightreplace (Just x) = Just (f v x)  iunionWith :: (Hashable k, Eq k) => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v-{-# INLINABLE iunionWith #-}+{-# INLINEABLE iunionWith #-} iunionWith = Map.unionWith  -- | Remove the '::' token from a text if any.@@ -148,28 +177,9 @@ -- | In case of a Left error, print and exit immediately. unwrapError :: Doc -> Either PrettyError a -> IO a unwrapError desc = either exit pure-    where-      exit = \err -> putDoc (display err) >> exitFailure-      display err = red desc <> ":" <+> getError err--key :: Text -> Traversal' Value Value-key k f v =-    case v of-      Object o ->-        fmap Object (HM.alterF (traverse f) k o)-      _ -> pure v--_String :: Prism' Value Text-_String = prism String $-  \v -> case v of-          String x -> Right x-          _ -> Left v--_Array :: Prism' Value (V.Vector Value)-_Array = prism Array $-  \v -> case v of-          Array x -> Right x-          _ -> Left v+  where+    exit err = putDoc (display err) >> exitFailure+    display err = red desc <> ":" <+> getError err  avalues :: IndexedTraversal' Int Value Value avalues = _Array . traversed
src/XPrelude/PP.hs view
@@ -1,33 +1,43 @@-{-# OPTIONS_HADDOCK ignore-exports #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-}-module XPrelude.PP (-  module Exports-  , PrettyError (..)-  , ppline-  , pplines-  , pptext-  , ppstring-)-where--import           Protolude+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK ignore-exports #-} -import           Data.Scientific-import           Data.Semigroup as Sem-import           Data.String-import qualified Data.Text                    as Text-import           Text.PrettyPrint.ANSI.Leijen as Exports hiding (bool, cat,-                                                          char, double, empty,-                                                          float, group, int,-                                                          integer, rational,-                                                          string, text, (<$>))+module XPrelude.PP+  ( module Exports,+    PrettyError (..),+    ppline,+    pplines,+    pptext,+    ppstring,+  )+where -import           Text.PrettyPrint.ANSI.Leijen (string, text)+import Data.Scientific+import Data.Semigroup as Sem+import Data.String+import qualified Data.Text as Text+import Protolude+import Text.PrettyPrint.ANSI.Leijen (string, text)+import Text.PrettyPrint.ANSI.Leijen as Exports hiding+  ( bool,+    cat,+    char,+    double,+    empty,+    float,+    group,+    int,+    integer,+    rational,+    string,+    text,+    (<$>),+  )  newtype PrettyError = PrettyError   { getError :: Doc-  } deriving Show+  }+  deriving (Show)  instance Sem.Semigroup PrettyError where   a <> b = PrettyError $ align (vsep [getError a, getError b])@@ -46,7 +56,6 @@  instance Pretty Scientific where   pretty = text . show-  -- | pretty print multiple lines of text. pplines :: Text -> Doc
tests/ErbSpec.hs view
@@ -1,75 +1,96 @@-module ErbSpec(spec) where--import           XPrelude--import           Test.Hspec+module ErbSpec (spec) where -import           Erb-import           Puppet.Runner+import Erb+import GHC.Base (error)+import Puppet.Runner+import Test.Hspec+import XPrelude  parsingtests :: [(String, [RubyStatement])] parsingtests =-  [ ("port = 5432", [ Puts (Value (Literal "port = 5432" ))])-  , ("mode = host=<%= @var %>", [ Puts (Value (Literal "mode = host="))-                               , Puts (Object (Value (Literal "@var")))-                               , Puts (Value (Literal ""))])-  , ("mode = host=<%= var %>", [ Puts (Value (Literal "mode = host="))-                              , Puts (Object (Value (Literal "var")))-                              , Puts (Value (Literal ""))])-  , ("<%= @os['architecture'] %>", [ Puts (Value (Literal ""))-                                   , Puts (LookupOperation (Object (Value (Literal "@os"))) (Value (Literal "architecture")))-                                   , Puts (Value (Literal ""))])-  , ("<%= @os['release']['major'] %>", [ Puts (Value (Literal ""))-                                       , Puts (LookupOperation (LookupOperation (Object (Value (Literal "@os"))) (Value (Literal "release"))) (Value (Literal "major")))-                                       , Puts (Value (Literal ""))])-  , ("<%= @processors['models'] %>", [ Puts (Value (Literal ""))-                                     , Puts (LookupOperation (Object (Value (Literal "@processors"))) (Value (Literal "models")))-                                     , Puts (Value (Literal ""))])-  , ("<%= scope.lookupvar('::fqdn') %>", [ Puts (Value (Literal ""))-                                         , Puts (ScopeObject (Value (Literal "::fqdn")))-                                         , Puts(Value (Literal ""))])-  , ("<%= scope.lookupvar(\"::fqdn\") %>", [ Puts (Value (Literal ""))-                                           , Puts (ScopeObject (Value (Literal "::fqdn")))-                                           , Puts(Value (Literal ""))])+  [ ("port = 5432", [Puts (Value (Literal "port = 5432"))]),+    ( "mode = host=<%= @var %>",+      [ Puts (Value (Literal "mode = host=")),+        Puts (Object (Value (Literal "@var"))),+        Puts (Value (Literal ""))+      ]+    ),+    ( "mode = host=<%= var %>",+      [ Puts (Value (Literal "mode = host=")),+        Puts (Object (Value (Literal "var"))),+        Puts (Value (Literal ""))+      ]+    ),+    ( "<%= @os['architecture'] %>",+      [ Puts (Value (Literal "")),+        Puts (LookupOperation (Object (Value (Literal "@os"))) (Value (Literal "architecture"))),+        Puts (Value (Literal ""))+      ]+    ),+    ( "<%= @os['release']['major'] %>",+      [ Puts (Value (Literal "")),+        Puts (LookupOperation (LookupOperation (Object (Value (Literal "@os"))) (Value (Literal "release"))) (Value (Literal "major"))),+        Puts (Value (Literal ""))+      ]+    ),+    ( "<%= @processors['models'] %>",+      [ Puts (Value (Literal "")),+        Puts (LookupOperation (Object (Value (Literal "@processors"))) (Value (Literal "models"))),+        Puts (Value (Literal ""))+      ]+    ),+    ( "<%= scope.lookupvar('::fqdn') %>",+      [ Puts (Value (Literal "")),+        Puts (ScopeObject (Value (Literal "::fqdn"))),+        Puts (Value (Literal ""))+      ]+    ),+    ( "<%= scope.lookupvar(\"::fqdn\") %>",+      [ Puts (Value (Literal "")),+        Puts (ScopeObject (Value (Literal "::fqdn"))),+        Puts (Value (Literal ""))+      ]+    )   ]  resolvetests :: [([RubyStatement], Text)] resolvetests =-  [ ([ Puts (Object (Value (Literal "@hostname")))]-    , "dummy"-    )-  , ([ Puts (LookupOperation (Object (Value (Literal "@os"))) (Value (Literal "architecture")))]-    , "amd64"-    )-  , ([ Puts (LookupOperation (LookupOperation (Object (Value (Literal "@os"))) (Value (Literal "release"))) (Value (Literal "major")))]-    , "7"-    )-  , ([ Puts (LookupOperation (Object (Value (Literal "@processors"))) (Value (Literal "models")))]-    , expectedmodels-    )-  , ([ Puts (ScopeObject (Value (Literal "::fqdn")))]-    , "dummy.dummy.domain"+  [ ( [Puts (Object (Value (Literal "@hostname")))],+      "dummy"+    ),+    ( [Puts (LookupOperation (Object (Value (Literal "@os"))) (Value (Literal "architecture")))],+      "amd64"+    ),+    ( [Puts (LookupOperation (LookupOperation (Object (Value (Literal "@os"))) (Value (Literal "release"))) (Value (Literal "major")))],+      "7"+    ),+    ( [Puts (LookupOperation (Object (Value (Literal "@processors"))) (Value (Literal "models")))],+      expectedmodels+    ),+    ( [Puts (ScopeObject (Value (Literal "::fqdn")))],+      "dummy.dummy.domain"     )   ]- where-   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\"]"+  where+    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\"]"  parsingspec =   for_ parsingtests $ \(s, e) ->-    let item = it ("should parse " <> s) in-    case parseErbString s of-      Left err -> item $ expectationFailure (show err)-      Right r -> item $ r `shouldBe` e+    let item = it ("should parse " <> s)+     in case parseErbString s of+          Left err -> item $ expectationFailure (show err)+          Right r -> item $ r `shouldBe` e  resolvespec =   let state0 = initialState dummyFacts mempty-      Just (scope_name, scope) = extractScope state0-  in-  for_ resolvetests $ \(s, e) ->-    let item = it ("should resolve " <> show s) in-    case rubyEvaluate scope scope_name s of-      Left err -> item $ expectationFailure (show err)-      Right r -> item $ r `shouldBe` e+      (scope_name, scope) = case extractScope state0 of+        Just p -> p+        Nothing -> error "should not happen"+   in for_ resolvetests $ \(s, e) ->+        let item = it ("should resolve " <> show s)+         in case rubyEvaluate scope scope_name s of+              Left err -> item $ expectationFailure (show err)+              Right r -> item $ r `shouldBe` e  spec = describe "Erb" $ do   parsingspec
tests/Helpers.hs view
@@ -1,64 +1,63 @@ {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedLists       #-}--module Helpers ( module Exports-               , checkExprsSuccess-               , checkExprsError-               , pureCatalog-               , getResource-               , getAttribute-               , renderToString-               , withStdlibFunction-               ) where+{-# LANGUAGE OverloadedLists #-} -import           XPrelude            as Exports+module Helpers+  ( module Exports,+    checkExprsSuccess,+    checkExprsError,+    pureCatalog,+    getResource,+    getAttribute,+    renderToString,+    withStdlibFunction,+  )+where -import           Control.Monad.Fail  as Exports (MonadFail) import qualified Data.HashMap.Strict as HM-import qualified Data.Maybe.Strict   as S-import qualified Data.Vector         as Vector-import           Test.Hspec          as Exports--import           Puppet.Interpreter  as Exports-import           Puppet.Parser       as Exports-import           Puppet.Runner       as Exports hiding (getCatalog)+import qualified Data.Maybe.Strict as S+import qualified Data.Vector as Vector+import Puppet.Interpreter as Exports+import Puppet.Parser as Exports+import Puppet.Runner as Exports hiding (getCatalog)+import Test.Hspec as Exports+import XPrelude as Exports  -- | Given a raw text input to be parsed, compute the manifest in a pure setting. -- The 'InterpreterWriter' might be useful for debugging purpose.-pureCatalog ::  Text -> Either String (FinalCatalog, InterpreterWriter)-pureCatalog = runExcept . fmap (\s -> (s^._1,s^._6)) . compileCatalog+pureCatalog :: Text -> Either String (FinalCatalog, InterpreterWriter)+pureCatalog = runExcept . fmap (\s -> (s ^. _1, s ^. _6)) . compileCatalog   where-  compileCatalog :: Text -> Except String (FinalCatalog, EdgeMap, FinalCatalog, [Resource], InterpreterState, InterpreterWriter)-  compileCatalog input = do-    statements <- either (throwError . show) pure (runPuppetParser mempty input)-    let nodename = "pure"-        top_node = [((TopNode, nodename), NodeDeclaration (NodeDecl (NodeName nodename) statements S.Nothing (initialPPos mempty)))]-        (res, finalState, logs) = pureEval top_node (computeCatalog nodename)-    (catalog, em, exported, defResources) <- either (throwError . show) pure res-    pure (catalog, em, exported, defResources, finalState, logs)+    compileCatalog :: Text -> Except String (FinalCatalog, EdgeMap, FinalCatalog, [Resource], InterpreterState, InterpreterWriter)+    compileCatalog input = do+      statements <- either (throwError . show) pure (runPuppetParser mempty input)+      let nodename = "pure"+          top_node = [((TopNode, nodename), NodeDeclaration (NodeDecl (NodeName nodename) statements S.Nothing (initialPPos mempty)))]+          (res, finalState, logs) = pureEval top_node (computeCatalog nodename)+      (catalog, em, exported, defResources) <- either (throwError . show) pure res+      pure (catalog, em, exported, defResources, finalState, logs)  getResource :: (MonadFail m) => RIdentifier -> FinalCatalog -> m Resource getResource resid catalog = maybe (fail ("Unknown resource " <> renderToString resid)) pure (HM.lookup resid catalog) -getAttribute :: MonadFail m => Text -> Resource -> m PValue+getAttribute :: (MonadFail m) => Text -> Resource -> m PValue getAttribute att res =   case res ^? rattributes . ix att of     Nothing -> fail ("Unknown attribute: " <> toS att)-    Just x  -> return x+    Just x -> return x -withStdlibFunction :: Text -> ( ([PValue] -> InterpreterMonad PValue) -> Spec ) -> Spec+withStdlibFunction :: Text -> (([PValue] -> InterpreterMonad PValue) -> Spec) -> Spec withStdlibFunction fname testsuite =   case stdlibFunctions ^? ix fname of-    Just f  -> testsuite f+    Just f -> testsuite f     Nothing -> panic ("Don't know this function: " <> fname) -checkExprsSuccess :: Text ->  [Expression] -> Text -> Expectation+checkExprsSuccess :: Text -> [Expression] -> Text -> Expectation checkExprsSuccess fname args res =   case evalExprs fname args of-    Left rr    -> expectationFailure (show rr)+    Left rr -> expectationFailure (show rr)     Right res' -> res' `shouldBe` res -checkExprsError :: Text ->  [Expression] -> String -> Expectation+checkExprsError :: Text -> [Expression] -> String -> Expectation checkExprsError fname args msg =   case evalExprs fname args of     Left rr -> show rr `shouldContain` msg@@ -68,7 +67,7 @@ evalExprs fname =   dummyEval . resolveValue . UFunctionCall fname . Vector.fromList >=> \case     PString s -> return s-    v         -> Left ("Expected a string, not " <> PrettyError (pretty v))+    v -> Left ("Expected a string, not " <> PrettyError (pretty v)) -renderToString :: Pretty a => a -> String+renderToString :: (Pretty a) => a -> String renderToString d = displayS (renderCompact (pretty d)) ""
tests/HieraSpec.hs view
@@ -1,14 +1,12 @@-module HieraSpec(spec) where--import           XPrelude+module HieraSpec (spec) where  import qualified Data.HashMap.Strict as HM-import qualified Data.Vector         as Vector-import qualified System.Log.Logger   as Log-import           Test.Hspec--import           Hiera.Server-import           Puppet.Language+import qualified Data.Vector as Vector+import Hiera.Server+import Puppet.Language+import qualified System.Log.Logger as Log+import Test.Hspec+import XPrelude  checkOutput :: (Eq a, Show rr, Show a) => a -> Either rr a -> Expectation checkOutput v (Right x) = x `shouldBe` v@@ -16,7 +14,7 @@  checkFail :: (Show a) => Either rr a -> Expectation checkFail (Right v) = expectationFailure ("Should have failed, but returned: " ++ show v)-checkFail _         = return ()+checkFail _ = return ()  fqdn :: Text fqdn = "node.com"@@ -34,19 +32,25 @@ configInterpolate = "./tests/hiera/interpolate/config/hiera.yaml"  vars :: HM.HashMap Text PValue-vars = HM.fromList [ ("::environment", "production")-                   , ("::fqdn"       , PString fqdn)-                   ]+vars =+  HM.fromList+    [ ("::environment", "production"),+      ("::fqdn", PString fqdn)+    ]  users :: HM.HashMap Text PValue-users = HM.fromList [ ("pete", PHash (HM.singleton "uid" (PNumber 2000)))-                    , ("tom" , PHash (HM.singleton "uid" (PNumber 2001)))-                    ]+users =+  HM.fromList+    [ ("pete", PHash (HM.singleton "uid" (PNumber 2000))),+      ("tom", PHash (HM.singleton "uid" (PNumber 2001)))+    ]  pusers :: HM.HashMap Text PValue-pusers = HM.fromList [ ("bob", PHash (HM.singleton "uid" (PNumber 100)))-                     , ("tom" , PHash (HM.singleton "uid" (PNumber 12)))-                     ]+pusers =+  HM.fromList+    [ ("bob", PHash (HM.singleton "uid" (PNumber 100))),+      ("tom", PHash (HM.singleton "uid" (PNumber 12)))+    ]  hash :: [(Text, PValue)] -> PValue hash = PHash . HM.fromList@@ -65,11 +69,11 @@     interpolationSpec     miscSpec     describe "v5 lookup hierarchy" $-      it "should override some values"  $ do+      it "should override some values" $ do         q5 vars "http_port" QFirst >>= checkOutput (Just (PNumber 9090))         q5 vars "global" QFirst >>= checkOutput (Just "glob")     describe "v5 ~" $-      it "should read '~' as a Null/Nothing value"  $+      it "should read '~' as a Null/Nothing value" $         q5 vars "optional_value" QFirst >>= checkOutput (Just PUndef)     describe "v3 lookup with no context variables" $ do       it "should return nothing when called with an empty string" $@@ -83,7 +87,7 @@       it "should return common data" $         q3 mempty "http_port" QFirst >>= checkOutput (Just (PNumber 8080))       it "should return arrays" $-        q3 mempty "ntp_servers" QFirst >>= checkOutput (Just (array ["0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"]))+        q3 mempty "ntp_servers" QFirst >>= checkOutput (Just (array ["0.ntp.puppetlabs.com", "1.ntp.puppetlabs.com"]))       it "should return hashes" $         q3 mempty "users" QFirst >>= checkOutput (Just (PHash users))     describe "v3 lookup hierarchy" $ do@@ -98,7 +102,7 @@       it "resolves in strings" $         q3 vars "interp1" QFirst >>= checkOutput (Just (PString ("**" <> fqdn <> "**")))       it "resolves in objects" $-        q3 vars "testnode" QFirst >>= checkOutput (Just (hash [("1",PString ("**" <> fqdn <> "**")),("2",PString "nothing special")]))+        q3 vars "testnode" QFirst >>= checkOutput (Just (hash [("1", PString ("**" <> fqdn <> "**")), ("2", PString "nothing special")]))       it "resolves in arrays" $         q3 vars "arraytest" QFirst >>= checkOutput (Just (array [PString "a", PString fqdn, PString "c"]))       it "resolves aliases" $@@ -109,7 +113,7 @@         q3 vars "aliased_lookup" QFirst >>= checkOutput (Just (PNumber 100))     describe "v3 other merge modes" $ do       it "catenates arrays" $-        q3 vars "ntp_servers" QUnique >>= checkOutput (Just (array ["2.ntp.puppetlabs.com","3.ntp.puppetlabs.com","0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"]))+        q3 vars "ntp_servers" QUnique >>= checkOutput (Just (array ["2.ntp.puppetlabs.com", "3.ntp.puppetlabs.com", "0.ntp.puppetlabs.com", "1.ntp.puppetlabs.com"]))       it "puts single values in arrays" $         q3 vars "http_port" QUnique >>= checkOutput (Just (array [PNumber 9090, PNumber 8080]))       it "merges hashes" $@@ -142,7 +146,6 @@     describe "when not finding value for interpolated key" $       it "should resolve the interpolation to an empty string" $         q mempty "niltest" QFirst >>= checkFail -- puppet behavior: checkOutput (Just "Missing key ##. Key with nil ##")-     describe "when there are empty interpolations %{} in data" $ do       it "should should produce an empty string for the interpolation" $ do         pendingWith "Support empty interpolation"@@ -190,21 +193,27 @@       it "split dq" $ varSplitter "\"ab\"" `shouldBe` HieraVar ("ab" :| [])       it "split dq 2" $ varSplitter "\"ab.cd\"" `shouldBe` HieraVar ("ab.cd" :| [])       it "split dq 2 mixed" $ varSplitter "\"ab.cd\".ef" `shouldBe` HieraVar ("ab.cd" :| ["ef"])-      it "split dq 2 mixed 4" $ varSplitter "\"ab.cd\".ef.\"lol.cat\".bar" `shouldBe`-            HieraVar ("ab.cd" :| ["ef", "lol.cat", "bar"])+      it "split dq 2 mixed 4" $+        varSplitter "\"ab.cd\".ef.\"lol.cat\".bar"+          `shouldBe` HieraVar ("ab.cd" :| ["ef", "lol.cat", "bar"])       it "split sq" $ varSplitter "'ab'" `shouldBe` HieraVar ("ab" :| [])       it "split sq 2" $ varSplitter "'ab.cd'" `shouldBe` HieraVar ("ab.cd" :| [])       it "split sq 2 mixed" $ varSplitter "'ab.cd'.ef" `shouldBe` HieraVar ("ab.cd" :| ["ef"])-      it "split sq 2 mixed 4" $ varSplitter "'ab.cd'.ef.'lol.cat'.bar" `shouldBe`-            HieraVar ("ab.cd" :| ["ef", "lol.cat", "bar"])-      it "split all mixed" $ varSplitter "'a.b'.\"c.d\".e.f" `shouldBe`-            HieraVar ("a.b" :| ["c.d", "e", "f"])-      it "function f()" $ varSplitter "f()" `shouldBe`-            HieraFunction ("f" :| []) []-      it "function f('a')" $ varSplitter "f('a')" `shouldBe`-            HieraFunction ("f" :| []) ["a"]-      it "function f('a', 'b', 'c')" $ varSplitter "f('a', 'b', 'c')" `shouldBe`-            HieraFunction ("f" :| []) ["a", "b", "c"]+      it "split sq 2 mixed 4" $+        varSplitter "'ab.cd'.ef.'lol.cat'.bar"+          `shouldBe` HieraVar ("ab.cd" :| ["ef", "lol.cat", "bar"])+      it "split all mixed" $+        varSplitter "'a.b'.\"c.d\".e.f"+          `shouldBe` HieraVar ("a.b" :| ["c.d", "e", "f"])+      it "function f()" $+        varSplitter "f()"+          `shouldBe` HieraFunction ("f" :| []) []+      it "function f('a')" $+        varSplitter "f('a')"+          `shouldBe` HieraFunction ("f" :| []) ["a"]+      it "function f('a', 'b', 'c')" $+        varSplitter "f('a', 'b', 'c')"+          `shouldBe` HieraFunction ("f" :| []) ["a", "b", "c"]      describe "when using dotted keys" $ do       it "should find an entry using a quoted interpolation" $
tests/Interpreter/ClassSpec.hs view
@@ -2,31 +2,29 @@  module Interpreter.ClassSpec (spec) where -import           Test.Hspec--import           Control.Lens-import qualified Data.Text         as Text--import           Helpers+import Control.Lens+import qualified Data.Text as Text+import Helpers+import Test.Hspec  spec = do   describe "Class" $ do     it "should work when using several include statements" $-      pureCatalog (Text.unlines ["class foo {}", "include foo", "include foo"]) `shouldSatisfy` (has _Right)+      pureCatalog (Text.unlines ["class foo {}", "include foo", "include foo"]) `shouldSatisfy` has _Right     it "should work when using class before include" $-      pureCatalog (Text.unlines ["class foo {}", "class { 'foo': }", "include foo"]) `shouldSatisfy` (has _Right)+      pureCatalog (Text.unlines ["class foo {}", "class { 'foo': }", "include foo"]) `shouldSatisfy` has _Right     it "should fail when using include before class" $-      pureCatalog (Text.unlines ["class foo {}", "include foo", "class { 'foo': }" ]) `shouldSatisfy` (has _Left)+      pureCatalog (Text.unlines ["class foo {}", "include foo", "class { 'foo': }"]) `shouldSatisfy` has _Left     it "should fail if the class is not defined" $-      pureCatalog (Text.unlines ["include foo"]) `shouldSatisfy` (has _Left)+      pureCatalog (Text.unlines ["include foo"]) `shouldSatisfy` has _Left   describe "Parameters" $ do     it "should fail when declaring a class with an unknown params" $-      pureCatalog (Text.unlines ["class foo ($param0){}", "class {'foo': param1 => 1 }"]) `shouldSatisfy` (has _Left)+      pureCatalog (Text.unlines ["class foo ($param0){}", "class {'foo': param1 => 1 }"]) `shouldSatisfy` has _Left     it "should succeed when declaring a class with a correct param" $-      pureCatalog (Text.unlines ["class foo ($param0){}", "class {'foo': param0 => 1 }"]) `shouldSatisfy` (has _Right)-    it "should fail when the type of the attribute is wrong"  $ do-      pureCatalog (Text.unlines ["class foo (String $param0){}", "class {'foo': param0 => 1 }"]) `shouldSatisfy` (has _Left)-    it "should fail when declaring with a missing param" $ do-      pureCatalog (Text.unlines ["class foo ($param0){}", "class {'foo': }"]) `shouldSatisfy` (has _Left)-    it "should succeed with missing param and an optional type" $ do-      pureCatalog (Text.unlines ["class foo (Optional[String] $param0){}", "class {'foo': }"]) `shouldSatisfy` (has _Right)+      pureCatalog (Text.unlines ["class foo ($param0){}", "class {'foo': param0 => 1 }"]) `shouldSatisfy` has _Right+    it "should fail when the type of the attribute is wrong" $+      pureCatalog (Text.unlines ["class foo (String $param0){}", "class {'foo': param0 => 1 }"]) `shouldSatisfy` has _Left+    it "should fail when declaring with a missing param" $+      pureCatalog (Text.unlines ["class foo ($param0){}", "class {'foo': }"]) `shouldSatisfy` has _Left+    it "should succeed with missing param and an optional type" $+      pureCatalog (Text.unlines ["class foo (Optional[String] $param0){}", "class {'foo': }"]) `shouldSatisfy` has _Right
tests/Interpreter/CollectorSpec.hs view
@@ -1,26 +1,25 @@-{-# LANGUAGE OverloadedLists #-}--- | Directly ported from puppet specs-module Interpreter.CollectorSpec (spec) where+{-# LANGUAGE OverloadedLists #-} -import           Test.Hspec+-- |  Directly ported from puppet specs+module Interpreter.CollectorSpec (spec) where -import           Control.Lens+import Control.Lens import qualified Data.Text as Text--import           Helpers-+import Helpers+import Test.Hspec  shouldNotify :: [Text] -> [PValue] -> Expectation shouldNotify content expectedMessages = do-    catalog <- case pureCatalog (Text.unlines content) of-      Left rr -> fail rr-      Right (x,_) -> pure x-    let messages = itoList catalog ^.. folded . filtered (\rp -> rp ^. _1 . itype == "notify") . _2 . rattributes . ix "message"-    messages `shouldMatchList` expectedMessages+  catalog <- case pureCatalog (Text.unlines content) of+    Left rr -> fail rr+    Right (x, _) -> pure x+  let messages = itoList catalog ^.. folded . filtered (\rp -> rp ^. _1 . itype == "notify") . _2 . rattributes . ix "message"+  messages `shouldMatchList` expectedMessages  shouldFail :: [Text] -> Expectation-shouldFail content = let catalog = pureCatalog (Text.unlines content)-                     in  catalog `shouldSatisfy` has _Left+shouldFail content =+  let catalog = pureCatalog (Text.unlines content)+   in catalog `shouldSatisfy` has _Left  spec =   describe "Collectors" $ do@@ -29,130 +28,154 @@  spec0 :: Spec spec0 = do-    it "matches everything when no query given" $-        [ "@notify { 'testing': message => 'the message' }"-        , "@notify { 'other': message => 'the other message' }"-        , "Notify <| |>"-        ] `shouldNotify` ["the other message", "the message"]-    it "matches regular resources" $-        [ "notify { \"testing\": message => \"the message\" }"-        , "notify { \"other\": message => \"the other message\" }"-        , "Notify <| |> { message => \"changed\" }"-        ] `shouldNotify` ["changed", "changed"]-    it "matches on tags" $-        [ "@notify { \"testing\": tag => [\"one\"], message => \"wanted\" }"-        , "@notify { \"other\": tag => [\"two\"], message => \"unwanted\" }"-        , "Notify <| tag == one |>"-        ] `shouldNotify` ["wanted"]-    it "matches on title" $-        [ "@notify { \"testing\": message => \"the message\" }"-        , "Notify <| title == \"testing\" |>"-        ] `shouldNotify` ["the message"]-    it "matches on other parameters" $-        [ "@notify { \"testing\": message => \"the message\" }"-        , "@notify { \"other testing\": message => \"the wrong message\" }"-        , "Notify <| message == \"the message\" |>"-        ] `shouldNotify` ["the message"]-    it "matches against elements of an array valued parameter" $-        [ "@notify { \"testing\": message => [\"the\", \"message\"] }"-        , "@notify { \"other testing\": message => [\"not\", \"here\"] }"-        , "Notify <| message == \"message\" |>"-        ] `shouldNotify` [PArray ["the", "message"]]-    it "matches with bare word" $-        [ "@notify { \"testing\": tag => [\"one\"], message => \"wanted\" }"-        , "Notify <| tag == one |>"-        ] `shouldNotify` ["wanted"]-    it "matches with single quoted string" $-        [ "@notify { \"testing\": tag => [\"one\"], message => \"wanted\" }"-        , "Notify <| tag == 'one' |>"-        ] `shouldNotify` ["wanted"]-    it "matches with double quoted string" $-        [ "@notify { \"testing\": tag => [\"one\"], message => \"wanted\" }"-        , "Notify <| tag == \"one\" |>"-        ] `shouldNotify` ["wanted"]-    it "matches with double quoted string with interpolated expression" $-        [ "@notify { \"testing\": tag => [\"one\"], message => \"wanted\" }"-        , "$x = 'one'"-        , "Notify <| tag == \"$x\" |>"-        ] `shouldNotify` ["wanted"]-    it "matches with resource references" $ do-        pending-        shouldNotify [ "@notify { \"foobar\": }"-                     , "@notify { \"testing\": require => Notify[\"foobar\"], message => \"wanted\" }"-                     , "Notify <| require == Notify[\"foobar\"] |>"-                     ]-                     ["wanted"]-    it "allows criteria to be combined with 'and'" $-        [ "@notify { \"testing\": message => \"the message\" }"-        , "@notify { \"other\": message => \"the message\" }"-        , "Notify <| title == \"testing\" and message == \"the message\" |>"-        ] `shouldNotify` ["the message"]-    it "allows criteria to be combined with 'or'" $-        [ "@notify { \"testing\": message => \"the message\" }"-        , "@notify { \"other\": message => \"other message\" }"-        , "@notify { \"yet another\": message => \"different message\" }"-        , "Notify <| title == \"testing\" or message == \"other message\" |>"-        ] `shouldNotify` ["the message", "other message"]-    it "allows criteria to be grouped with parens" $-        [ "@notify { \"testing\":     message => \"different message\", withpath => true }"-        , "@notify { \"other\":       message => \"the message\" }"-        , "@notify { \"yet another\": message => \"the message\",       withpath => true }"-        , "Notify <| (title == \"testing\" or message == \"the message\") and withpath == true |>"-        ] `shouldNotify` ["the message", "different message"]-    it "does not do anything if nothing matches" $-        [ "@notify { \"testing\": message => \"different message\" }"-        , "Notify <| title == \"does not exist\" |>"-        ] `shouldNotify` []-    it "excludes items with inequalities" $-        [ "@notify { \"testing\": message => \"good message\" }"-        , "@notify { \"the wrong one\": message => \"bad message\" }"-        , "Notify <| title != \"the wrong one\" |>"-        ] `shouldNotify` ["good message"]-    it "does not exclude resources with unequal arrays" $-        [ "@notify { \"testing\": message => \"message\" }"-        , "@notify { \"the wrong one\": message => [\"not this message\", \"or this one\"] }"-        , "Notify <| message != \"not this message\" |>"-        ] `shouldNotify` ["message", PArray ["not this message", "or this one"]]-    it "does not exclude tags with inequalities" $-        [ "@notify { \"testing\": tag => [\"wanted\"], message => \"wanted message\" }"-        , "@notify { \"other\": tag => [\"why\"], message => \"the way it works\" }"-        , "Notify <| tag != \"why\" |>"-        ] `shouldNotify` ["wanted message", "the way it works"]-    it "does not collect classes" $ shouldFail $-        [ "class theclass {"-        , "    @notify { \"testing\": message => \"good message\" }"-        , "}"-        , "Class <|  |>"-        ]-    it "does not collect resources that don't exist" $ do-        pending-        shouldFail $-            [ "class theclass {"-            , "    @notify { \"testing\": message => \"good message\" }"-            , "}"-            , "SomeResource <|  |>"-            ]-    it "modifies an existing array" $-        [ "@notify { \"testing\": message => [\"original message\"] }"-        , "Notify <| |> {"-        , "    message +> \"extra message\""-        , "}"] `shouldNotify` [PArray ["original message", "extra message"]]-    it "converts a scalar to an array" $-        [ "@notify { \"testing\": message => \"original message\" }"-        , "Notify <| |> {"-        , "    message +> \"extra message\""-        , "}"] `shouldNotify` [PArray ["original message", "extra message"]]-    it "collects and overrides virtual resources multiple times using multiple collects" $-        [ "@notify { \"testing\": message => \"original\" }"-        , "Notify <|  |> { message => 'overridden1' }"-        , "Notify <|  |> { message => 'overridden2' }"-        ] `shouldNotify` ["overridden2"]-    it "collects and overrides non virtual resources multiple times using multiple collects" $-        [ "notify { \"testing\": message => \"original\" }"-        , "Notify <|  |> { message => 'overridden1' }"-        , "Notify <|  |> { message => 'overridden2' }"-        ] `shouldNotify` ["overridden2"]-+  it "matches everything when no query given" $+    [ "@notify { 'testing': message => 'the message' }",+      "@notify { 'other': message => 'the other message' }",+      "Notify <| |>"+    ]+      `shouldNotify` ["the other message", "the message"]+  it "matches regular resources" $+    [ "notify { \"testing\": message => \"the message\" }",+      "notify { \"other\": message => \"the other message\" }",+      "Notify <| |> { message => \"changed\" }"+    ]+      `shouldNotify` ["changed", "changed"]+  it "matches on tags" $+    [ "@notify { \"testing\": tag => [\"one\"], message => \"wanted\" }",+      "@notify { \"other\": tag => [\"two\"], message => \"unwanted\" }",+      "Notify <| tag == one |>"+    ]+      `shouldNotify` ["wanted"]+  it "matches on title" $+    [ "@notify { \"testing\": message => \"the message\" }",+      "Notify <| title == \"testing\" |>"+    ]+      `shouldNotify` ["the message"]+  it "matches on other parameters" $+    [ "@notify { \"testing\": message => \"the message\" }",+      "@notify { \"other testing\": message => \"the wrong message\" }",+      "Notify <| message == \"the message\" |>"+    ]+      `shouldNotify` ["the message"]+  it "matches against elements of an array valued parameter" $+    [ "@notify { \"testing\": message => [\"the\", \"message\"] }",+      "@notify { \"other testing\": message => [\"not\", \"here\"] }",+      "Notify <| message == \"message\" |>"+    ]+      `shouldNotify` [PArray ["the", "message"]]+  it "matches with bare word" $+    [ "@notify { \"testing\": tag => [\"one\"], message => \"wanted\" }",+      "Notify <| tag == one |>"+    ]+      `shouldNotify` ["wanted"]+  it "matches with single quoted string" $+    [ "@notify { \"testing\": tag => [\"one\"], message => \"wanted\" }",+      "Notify <| tag == 'one' |>"+    ]+      `shouldNotify` ["wanted"]+  it "matches with double quoted string" $+    [ "@notify { \"testing\": tag => [\"one\"], message => \"wanted\" }",+      "Notify <| tag == \"one\" |>"+    ]+      `shouldNotify` ["wanted"]+  it "matches with double quoted string with interpolated expression" $+    [ "@notify { \"testing\": tag => [\"one\"], message => \"wanted\" }",+      "$x = 'one'",+      "Notify <| tag == \"$x\" |>"+    ]+      `shouldNotify` ["wanted"]+  it "matches with resource references" $ do+    pending+    shouldNotify+      [ "@notify { \"foobar\": }",+        "@notify { \"testing\": require => Notify[\"foobar\"], message => \"wanted\" }",+        "Notify <| require == Notify[\"foobar\"] |>"+      ]+      ["wanted"]+  it "allows criteria to be combined with 'and'" $+    [ "@notify { \"testing\": message => \"the message\" }",+      "@notify { \"other\": message => \"the message\" }",+      "Notify <| title == \"testing\" and message == \"the message\" |>"+    ]+      `shouldNotify` ["the message"]+  it "allows criteria to be combined with 'or'" $+    [ "@notify { \"testing\": message => \"the message\" }",+      "@notify { \"other\": message => \"other message\" }",+      "@notify { \"yet another\": message => \"different message\" }",+      "Notify <| title == \"testing\" or message == \"other message\" |>"+    ]+      `shouldNotify` ["the message", "other message"]+  it "allows criteria to be grouped with parens" $+    [ "@notify { \"testing\":     message => \"different message\", withpath => true }",+      "@notify { \"other\":       message => \"the message\" }",+      "@notify { \"yet another\": message => \"the message\",       withpath => true }",+      "Notify <| (title == \"testing\" or message == \"the message\") and withpath == true |>"+    ]+      `shouldNotify` ["the message", "different message"]+  it "does not do anything if nothing matches" $+    [ "@notify { \"testing\": message => \"different message\" }",+      "Notify <| title == \"does not exist\" |>"+    ]+      `shouldNotify` []+  it "excludes items with inequalities" $+    [ "@notify { \"testing\": message => \"good message\" }",+      "@notify { \"the wrong one\": message => \"bad message\" }",+      "Notify <| title != \"the wrong one\" |>"+    ]+      `shouldNotify` ["good message"]+  it "does not exclude resources with unequal arrays" $+    [ "@notify { \"testing\": message => \"message\" }",+      "@notify { \"the wrong one\": message => [\"not this message\", \"or this one\"] }",+      "Notify <| message != \"not this message\" |>"+    ]+      `shouldNotify` ["message", PArray ["not this message", "or this one"]]+  it "does not exclude tags with inequalities" $+    [ "@notify { \"testing\": tag => [\"wanted\"], message => \"wanted message\" }",+      "@notify { \"other\": tag => [\"why\"], message => \"the way it works\" }",+      "Notify <| tag != \"why\" |>"+    ]+      `shouldNotify` ["wanted message", "the way it works"]+  it "does not collect classes" $+    shouldFail+      [ "class theclass {",+        "    @notify { \"testing\": message => \"good message\" }",+        "}",+        "Class <|  |>"+      ]+  it "does not collect resources that don't exist" $ do+    pending+    shouldFail+      [ "class theclass {",+        "    @notify { \"testing\": message => \"good message\" }",+        "}",+        "SomeResource <|  |>"+      ]+  it "modifies an existing array" $+    [ "@notify { \"testing\": message => [\"original message\"] }",+      "Notify <| |> {",+      "    message +> \"extra message\"",+      "}"+    ]+      `shouldNotify` [PArray ["original message", "extra message"]]+  it "converts a scalar to an array" $+    [ "@notify { \"testing\": message => \"original message\" }",+      "Notify <| |> {",+      "    message +> \"extra message\"",+      "}"+    ]+      `shouldNotify` [PArray ["original message", "extra message"]]+  it "collects and overrides virtual resources multiple times using multiple collects" $+    [ "@notify { \"testing\": message => \"original\" }",+      "Notify <|  |> { message => 'overridden1' }",+      "Notify <|  |> { message => 'overridden2' }"+    ]+      `shouldNotify` ["overridden2"]+  it "collects and overrides non virtual resources multiple times using multiple collects" $+    [ "notify { \"testing\": message => \"original\" }",+      "Notify <|  |> { message => 'overridden1' }",+      "Notify <|  |> { message => 'overridden2' }"+    ]+      `shouldNotify` ["overridden2"]  spec1 :: Spec spec1 = do@@ -162,21 +185,22 @@       getResAttr (computeWith "=>") ^. at "uid" `shouldBe` Just (PNumber 1000)   describe "AppendArrow in AttributeDecl" $     it "should add 'docker' to the 'groups' attribute of the user resource" $ do-      getResAttr (computeWith "+>") ^. at "groups" `shouldBe` Just (PArray $ ["ci", "docker"])+      getResAttr (computeWith "+>") ^. at "groups" `shouldBe` Just (PArray ["ci", "docker"])   describe "AssignArrow in AttributeDecl" $     it "should override the 'groups' attributes from the user resource" $-      getResAttr (computeWith "=>") ^. at "groups" `shouldBe` Just (PArray $ ["docker"])+      getResAttr (computeWith "=>") ^. at "groups" `shouldBe` Just (PArray ["docker"])   where     getResAttr :: Either String (FinalCatalog, InterpreterWriter) -> Container PValue-    getResAttr s = s ^. _Right . _1 . at (RIdentifier "user" "jenkins")._Just.rattributes+    getResAttr s = s ^. _Right . _1 . at (RIdentifier "user" "jenkins") . _Just . rattributes      arrowOperationInput :: Text -> Text     arrowOperationInput arr =-      Text.unlines [ "user { 'jenkins':"-                   , "  groups => 'ci'"-                   , "}"-                   , "User <| title == 'jenkins' |> {"-                   , "groups " <> arr <> " 'docker',"-                   , "uid => 1000}"-                   , "}"-                   ]+      Text.unlines+        [ "user { 'jenkins':",+          "  groups => 'ci'",+          "}",+          "User <| title == 'jenkins' |> {",+          "groups " <> arr <> " 'docker',",+          "uid => 1000}",+          "}"+        ]
tests/Interpreter/EvalSpec.hs view
@@ -1,44 +1,43 @@ module Interpreter.EvalSpec (spec) where --import           Test.Hspec-import           Text.Megaparsec       (errorBundlePretty, eof, parse)--import           Puppet.Interpreter-import           Puppet.Parser.Internal-import           Puppet.Runner-import           XPrelude+import Puppet.Interpreter+import Puppet.Parser.Internal+import Puppet.Runner+import Test.Hspec+import Text.Megaparsec (eof, errorBundlePretty, parse)+import XPrelude -evaluations = [ "4 + 2 == 6"-            , "[1,2][1] == 2"-            , "[1,[1,2]][1][0] == 1"-            , "[1,2,3] + [4,5,6] == [1,2,3,4,5,6]"-            , "{a => 1} + {b => 2} == {a=>1, b=>2 }"-            , "[1,2,3] << 10 == [1,2,3,10]"-            , "[1,2,3] << [4,5] == [1,2,3,[4,5]]"-            , "4 / 2.0 == 2"-            , "$kernel == 'Linux'"-            , "$facts['os']['architecture'] == 'amd64'"-            -- string interpolation-            , "\"$kernel\" == 'Linux'"-            , "\"${kernel} box\" == 'Linux box'"-            , "\"${os['architecture']}\" == 'amd64'"-            , "\"${os['release']['major']}\" == '7'"-            , "\"${facts['kernel']}\" == 'Linux'"-            , "\"${facts['os']['architecture']}\" == 'amd64'"-            ---            , "$settings::confdir == '/etc/puppet'"-            , "regsubst('127', '([0-9]+)', '<\\1>', 'G') == '<127>'"-            , "regsubst(['1','2','3'], '([0-9]+)', '<\\1>', 'G') == ['<1>','<2>','<3>']"-            , "versioncmp('2.1','2.2') == -1"-            , "inline_template('a','b') == 'ab'"-            ]+evaluations =+  [ "4 + 2 == 6",+    "[1,2][1] == 2",+    "[1,[1,2]][1][0] == 1",+    "[1,2,3] + [4,5,6] == [1,2,3,4,5,6]",+    "{a => 1} + {b => 2} == {a=>1, b=>2 }",+    "[1,2,3] << 10 == [1,2,3,10]",+    "[1,2,3] << [4,5] == [1,2,3,[4,5]]",+    "4 / 2.0 == 2",+    "$kernel == 'Linux'",+    "$facts['os']['architecture'] == 'amd64'",+    -- string interpolation+    "\"$kernel\" == 'Linux'",+    "\"${kernel} box\" == 'Linux box'",+    "\"${os['architecture']}\" == 'amd64'",+    "\"${os['release']['major']}\" == '7'",+    "\"${facts['kernel']}\" == 'Linux'",+    "\"${facts['os']['architecture']}\" == 'amd64'",+    --+    "$settings::confdir == '/etc/puppet'",+    "regsubst('127', '([0-9]+)', '<\\1>', 'G') == '<127>'",+    "regsubst(['1','2','3'], '([0-9]+)', '<\\1>', 'G') == ['<1>','<2>','<3>']",+    "versioncmp('2.1','2.2') == -1",+    "inline_template('a','b') == 'ab'"+  ]  testEvaluation t =-  let item = it ("should evaluate " <> t) in-  case check (toS t) of-    Left ctx -> context ctx $ item False-    Right b  -> item b+  let item = it ("should evaluate " <> t)+   in case check (toS t) of+        Left ctx -> context ctx $ item False+        Right b -> item b  check :: Text -> Either String Bool check t =@@ -46,7 +45,7 @@     Left err -> Left $ "Parsing error. Are you sure the input is correct ?\n" <> errorBundlePretty err     Right e -> case dummyEval (resolveExpression e) of       Right (PBoolean True) -> Right True-      _                     -> Right False+      _ -> Right False  spec = do   describe "Evaluation of expressions" $ mapM_ testEvaluation evaluations
tests/Interpreter/EvaluateStatementSpec.hs view
@@ -1,25 +1,25 @@ {-# LANGUAGE OverloadedLists #-}+ module Interpreter.EvaluateStatementSpec where -import           Helpers import qualified Data.Text as Text+import Helpers  main :: IO () main = hspec spec  shouldNotify :: [Text] -> PValue -> Expectation shouldNotify s expected = do-    catalog <- case pureCatalog (Text.unlines s) of-      Left rr -> fail rr-      Right (x,_) -> pure x-    let msg  = catalog ^? at (RIdentifier "notify" "test")._Just.rattributes. ix "message"-    msg `shouldBe` (Just expected)-+  catalog <- case pureCatalog (Text.unlines s) of+    Left rr -> fail rr+    Right (x, _) -> pure x+  let msg = catalog ^? at (RIdentifier "notify" "test") . _Just . rattributes . ix "message"+  msg `shouldBe` Just expected  spec :: Spec spec = do   describe "evaluate statement" $ do     it "should evaluate simple variable assignment" $-      [ "$a = 0" , "notify { 'test': message => \"a is ${a}\"}"] `shouldNotify` "a is 0"+      ["$a = 0", "notify { 'test': message => \"a is ${a}\"}"] `shouldNotify` "a is 0"     it "should evaluate chained variables assignment" $-      [ "$a = $b = 0" , "notify { 'test': message => \"b is ${b}\"}"] `shouldNotify` "b is 0"+      ["$a = $b = 0", "notify { 'test': message => \"b is ${b}\"}"] `shouldNotify` "b is 0"
tests/Interpreter/Function/AssertPrivateSpec.hs view
@@ -1,27 +1,32 @@-{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedLists #-}+ module Interpreter.Function.AssertPrivateSpec where -import           Helpers+import Helpers  main :: IO () main = hspec spec -evalWithScope :: ([PValue] -> InterpreterMonad PValue)-              -> Text -- ^ caller scope-              -> Text -- ^ module scope-              -> [Expression]         -- ^ function args-              -> Either String PValue+evalWithScope ::+  ([PValue] -> InterpreterMonad PValue) ->+  -- | caller scope+  Text ->+  -- | module scope+  Text ->+  -- | function args+  [Expression] ->+  Either String PValue evalWithScope apFunc callerScope moduleScope =   (_Left %~ show) . view _1 . ctxEval . (mapM resolveExpression >=> apFunc)   where-      ctxEval = pureEval' mempty state0 Nothing-      state0 = dummyInitialState & curScope .~ [ContClass moduleScope, ContClass callerScope]+    ctxEval = pureEval' mempty state0 Nothing+    state0 = dummyInitialState & curScope .~ [ContClass moduleScope, ContClass callerScope]  spec :: Spec spec = withStdlibFunction "assert_private" $ \apFunc -> do-    let errorWith a b = case a of-                            Right x -> fail ("Should have failed, got this instead: " ++ show x)-                            Left rr -> rr `shouldContain` b-    it "should work when called from inside module" (evalWithScope apFunc "bar" "bar" [] `shouldBe` Right PUndef)-    it "should fail with the default message" (evalWithScope apFunc "bar" "baz" [] `errorWith` "is private")-    it "should fail with an explicit failure message" (evalWithScope apFunc "bar" "baz" ["lalala"] `errorWith` "lalala")+  let errorWith a b = case a of+        Right x -> fail ("Should have failed, got this instead: " ++ show x)+        Left rr -> rr `shouldContain` b+  it "should work when called from inside module" (evalWithScope apFunc "bar" "bar" [] `shouldBe` Right PUndef)+  it "should fail with the default message" (evalWithScope apFunc "bar" "baz" [] `errorWith` "is private")+  it "should fail with an explicit failure message" (evalWithScope apFunc "bar" "baz" ["lalala"] `errorWith` "lalala")
tests/Interpreter/Function/DeleteAtSpec.hs view
@@ -2,29 +2,29 @@  module Interpreter.Function.DeleteAtSpec (spec, main) where -import           Helpers+import Helpers  main :: IO () main = hspec spec  spec :: Spec spec = withStdlibFunction "delete_at" $ \deleteAtFunc -> do-    let evalArgs' = dummyEval . deleteAtFunc-        narray = PArray . fmap PNumber-        check a b res = case evalArgs' [narray a, PNumber b] of-                             Left rr -> expectationFailure (show rr)-                             Right res' -> res' `shouldBe` narray res-        checkError args ins = case evalArgs' args of-                                  Left rr -> show rr `shouldContain` ins-                                  Right r -> expectationFailure ("Should have errored, received this instead: " <> show r)-    it "should error with invalid arguments" $ do-        checkError [] "expects 2 arguments"-        checkError [PNumber 1] "expects 2 arguments"-        checkError ["foo", "bar"] "expects its first argument to be an array"-        checkError [ narray [0,1,2], PNumber 3 ] "Out of bounds access"-    it "should work otherwise" $ do-        check [0,1,2] 1 [0,2]-    it "should work for negative positions" $ do-        pending-        check [0,1,2] (-1) [0,1]-        check [0,1,2] (-4) [0,1,2]+  let evalArgs' = dummyEval . deleteAtFunc+      narray = PArray . fmap PNumber+      check a b res = case evalArgs' [narray a, PNumber b] of+        Left rr -> expectationFailure (show rr)+        Right res' -> res' `shouldBe` narray res+      checkError args ins = case evalArgs' args of+        Left rr -> show rr `shouldContain` ins+        Right r -> expectationFailure ("Should have errored, received this instead: " <> show r)+  it "should error with invalid arguments" $ do+    checkError [] "expects 2 arguments"+    checkError [PNumber 1] "expects 2 arguments"+    checkError ["foo", "bar"] "expects its first argument to be an array"+    checkError [narray [0, 1, 2], PNumber 3] "Out of bounds access"+  it "should work otherwise" $ do+    check [0, 1, 2] 1 [0, 2]+  it "should work for negative positions" $ do+    pending+    check [0, 1, 2] (-1) [0, 1]+    check [0, 1, 2] (-4) [0, 1, 2]
tests/Interpreter/Function/EachSpec.hs view
@@ -1,60 +1,67 @@ {-# LANGUAGE OverloadedLists #-}+ module Interpreter.Function.EachSpec (spec, main) where -import           Helpers+import Helpers  main :: IO () main = hspec spec  spec :: Spec spec = do-    let getCatalog x = case pureCatalog x of-          Left rr -> fail rr-          Right (y,_) -> pure y-    describe "should be callable as" $ do-      let checkEnsure f v c =-            getResource (RIdentifier "file" f) c >>= getAttribute "ensure" >>= \a -> a `shouldBe` v-          checks :: [(Text, PValue)] -> FinalCatalog -> IO ()-          checks lst c = mapM_ (\(f,v) -> checkEnsure f v c) lst-      it "each on an array selecting each value" $-        getCatalog "$a = [1,2,3]\n $a.each |$v| {\n file { \"/file_$v\": ensure => present } \n } "-          >>= checks [ ("/file_1", "present")-                     , ("/file_2", "present")-                     , ("/file_3", "present")-                     ]-      it "each on an array selecting each value - function call style" $-        getCatalog "$a = [1,2,3]\n each ($a) |$index, $v| {\n file { \"/file_$v\": ensure => present }\n }"-          >>= checks [ ("/file_1", "present")-                     , ("/file_2", "present")-                     , ("/file_3", "present")-                     ]-      it "each on an array with index" $-        getCatalog "$a = [present, absent, present]\n $a.each |$k,$v| {\n file { \"/file_$k\": ensure => $v }\n }"-          >>= checks [ ("/file_0", "present")-                     , ("/file_1", "absent")-                     , ("/file_2", "present")-                     ]-      it "each on a hash selecting entries" $-        getCatalog "$a = {'a'=>'present','b'=>'absent','c'=>'present'}\n $a.each |$e| {\n $num = $e[0]\n file { \"/file_${num}\": ensure => $e[1] }\n }"-          >>= checks [ ("/file_a", "present")-                     , ("/file_b", "absent")-                     , ("/file_c", "present")-                     ]-      it "each on a hash selecting key and value" $-        getCatalog "$a = {'a'=>present,'b'=>absent,'c'=>present}\n $a.each |$k, $v| {\n file { \"/file_$k\": ensure => $v }\n }"-          >>= checks [ ("/file_a", "present")-                     , ("/file_b", "absent")-                     , ("/file_c", "present")-                     ]-      it "each on a hash selecting key and value (using captures-last parameter)" $ do-        pending-        getCatalog "$a = {'a'=>present,'b'=>absent,'c'=>present}\n $a.each |*$kv| {\n file { \"/file_${kv[0]}\": ensure => $kv[1] }\n }"-          >>= checks [ ("/file_a", "present")-                     , ("/file_b", "absent")-                     , ("/file_c", "present")-                     ]-    describe "should produce receiver" $-      it "each checking produced value using single expression" $ do-        pending-        c <- getCatalog "$a = [1, 3, 2]\n $b = $a.each |$x| { \"unwanted\" }\n $u = $b[1]\n file { \"/file_${u}\":\n ensure => present\n }"-        getResource (RIdentifier "file" "/file_3") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"+  let getCatalog x = case pureCatalog x of+        Left rr -> fail rr+        Right (y, _) -> pure y+  describe "should be callable as" $ do+    let checkEnsure f v c =+          getResource (RIdentifier "file" f) c >>= getAttribute "ensure" >>= \a -> a `shouldBe` v+        checks :: [(Text, PValue)] -> FinalCatalog -> IO ()+        checks lst c = mapM_ (\(f, v) -> checkEnsure f v c) lst+    it "each on an array selecting each value" $+      getCatalog "$a = [1,2,3]\n $a.each |$v| {\n file { \"/file_$v\": ensure => present } \n } "+        >>= checks+          [ ("/file_1", "present"),+            ("/file_2", "present"),+            ("/file_3", "present")+          ]+    it "each on an array selecting each value - function call style" $+      getCatalog "$a = [1,2,3]\n each ($a) |$index, $v| {\n file { \"/file_$v\": ensure => present }\n }"+        >>= checks+          [ ("/file_1", "present"),+            ("/file_2", "present"),+            ("/file_3", "present")+          ]+    it "each on an array with index" $+      getCatalog "$a = [present, absent, present]\n $a.each |$k,$v| {\n file { \"/file_$k\": ensure => $v }\n }"+        >>= checks+          [ ("/file_0", "present"),+            ("/file_1", "absent"),+            ("/file_2", "present")+          ]+    it "each on a hash selecting entries" $+      getCatalog "$a = {'a'=>'present','b'=>'absent','c'=>'present'}\n $a.each |$e| {\n $num = $e[0]\n file { \"/file_${num}\": ensure => $e[1] }\n }"+        >>= checks+          [ ("/file_a", "present"),+            ("/file_b", "absent"),+            ("/file_c", "present")+          ]+    it "each on a hash selecting key and value" $+      getCatalog "$a = {'a'=>present,'b'=>absent,'c'=>present}\n $a.each |$k, $v| {\n file { \"/file_$k\": ensure => $v }\n }"+        >>= checks+          [ ("/file_a", "present"),+            ("/file_b", "absent"),+            ("/file_c", "present")+          ]+    it "each on a hash selecting key and value (using captures-last parameter)" $ do+      pending+      getCatalog "$a = {'a'=>present,'b'=>absent,'c'=>present}\n $a.each |*$kv| {\n file { \"/file_${kv[0]}\": ensure => $kv[1] }\n }"+        >>= checks+          [ ("/file_a", "present"),+            ("/file_b", "absent"),+            ("/file_c", "present")+          ]+  describe "should produce receiver" $+    it "each checking produced value using single expression" $ do+      pending+      c <- getCatalog "$a = [1, 3, 2]\n $b = $a.each |$x| { \"unwanted\" }\n $u = $b[1]\n file { \"/file_${u}\":\n ensure => present\n }"+      getResource (RIdentifier "file" "/file_3") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"
tests/Interpreter/Function/JoinKeysToValuesSpec.hs view
@@ -1,26 +1,24 @@-{-# LANGUAGE OverloadedLists #-}-module Interpreter.Function.JoinKeysToValuesSpec (spec) where+{-# LANGUAGE OverloadedLists #-} -import           Test.Hspec+module Interpreter.Function.JoinKeysToValuesSpec (spec) where  import qualified Data.Foldable as F-import           Data.Monoid--import           Puppet.Interpreter--import           Helpers+import Data.Monoid+import Helpers+import Puppet.Interpreter+import Test.Hspec  spec :: Spec spec = withStdlibFunction "join_keys_to_values" $ \jkvFunc -> it "Should work as expected" $ do-    let eval h s = case dummyEval (jkvFunc [PHash h, PString s]) of-                      Left rr -> Left (renderToString (getError rr))-                      Right (PArray vals) -> Right (F.toList vals)-                      Right v -> Left ("Expected an array, not: " <> renderToString v)-    eval [] "" `shouldBe` Right []-    eval [] ":" `shouldBe` Right []-    eval [("key","value")] "" `shouldBe` Right ["keyvalue"]-    eval [("key","value")] ":" `shouldBe` Right ["key:value"]-    eval [("key",PUndef)] ":" `shouldBe` Right ["key:"]-    case eval [("key1","value1"),("key2","value2")] ":" of-        Left rr -> fail rr-        Right lst -> lst `shouldMatchList` ["key1:value1", "key2:value2"]+  let eval h s = case dummyEval (jkvFunc [PHash h, PString s]) of+        Left rr -> Left (renderToString (getError rr))+        Right (PArray vals) -> Right (F.toList vals)+        Right v -> Left ("Expected an array, not: " <> renderToString v)+  eval [] "" `shouldBe` Right []+  eval [] ":" `shouldBe` Right []+  eval [("key", "value")] "" `shouldBe` Right ["keyvalue"]+  eval [("key", "value")] ":" `shouldBe` Right ["key:value"]+  eval [("key", PUndef)] ":" `shouldBe` Right ["key:"]+  case eval [("key1", "value1"), ("key2", "value2")] ":" of+    Left rr -> fail rr+    Right lst -> lst `shouldMatchList` ["key1:value1", "key2:value2"]
tests/Interpreter/Function/LookupSpec.hs view
@@ -1,18 +1,20 @@ module Interpreter.Function.LookupSpec (spec, main) where -import           Helpers+import Helpers  main :: IO () main = hspec spec  fname :: Text fname = "lookup"+ expectedErrMsg :: String expectedErrMsg = "Wrong set of arguments"  -- See dummyFacts defined in Pure.hs testkey :: Expression testkey = "foo"+ expectedValue :: Text expectedValue = "dummy" @@ -28,10 +30,10 @@  spec :: Spec spec = do-    it "should fail with no argument" (checkError [] expectedErrMsg)-    it "should succeed with one argument" (checkSuccess [testkey] expectedValue)-    it "should succeed with 4 arguments" (checkSuccess [testkey, stringDatatype, "unique", "default"] expectedValue)-    it "should fail with an unknown merge strategy" (checkError [testkey, stringDatatype, "joe", "default"] "Unknown merge strategy")-    it "should succeed with two arguments, the second one being a datatype" (checkSuccess [testkey, stringDatatype] expectedValue)-    it "should fail when the type mismatched" (checkError [testkey, boolDatatype] "Datatype mismatched")-    it "should fail with two arguments both strings" (checkError [testkey, "default"] expectedErrMsg)+  it "should fail with no argument" (checkError [] expectedErrMsg)+  it "should succeed with one argument" (checkSuccess [testkey] expectedValue)+  it "should succeed with 4 arguments" (checkSuccess [testkey, stringDatatype, "unique", "default"] expectedValue)+  it "should fail with an unknown merge strategy" (checkError [testkey, stringDatatype, "joe", "default"] "Unknown merge strategy")+  it "should succeed with two arguments, the second one being a datatype" (checkSuccess [testkey, stringDatatype] expectedValue)+  it "should fail when the type mismatched" (checkError [testkey, boolDatatype] "Datatype mismatched")+  it "should fail with two arguments both strings" (checkError [testkey, "default"] expectedErrMsg)
tests/Interpreter/Function/MergeSpec.hs view
@@ -1,11 +1,9 @@ {-# LANGUAGE OverloadedLists #-}-module Interpreter.Function.MergeSpec (spec, main) where --import           Helpers+module Interpreter.Function.MergeSpec (spec, main) where  import qualified Data.HashMap.Strict as HM-+import Helpers  main :: IO () main = hspec spec@@ -15,68 +13,77 @@   spec1  evalArgs :: InterpreterMonad PValue -> Either PrettyError (HM.HashMap Text PValue)-evalArgs = dummyEval-        >=> \pv -> case pv of-                      PHash s -> return s-                      _ -> Left ("Expected a string, not " <> PrettyError (pretty pv))+evalArgs =+  dummyEval+    >=> \pv -> case pv of+      PHash s -> return s+      _ -> Left ("Expected a string, not " <> PrettyError (pretty pv))  spec0 :: Spec spec0 = do   withStdlibFunction "merge" $ \mergeFunc -> do     let evalArgs' = evalArgs . mergeFunc     let check args res = case evalArgs' (map PHash args) of-                             Left rr -> expectationFailure (show rr)-                             Right res' -> res' `shouldBe` res+          Left rr -> expectationFailure (show rr)+          Right res' -> res' `shouldBe` res         checkError args ins = case evalArgs' args of-                                  Left rr -> show rr `shouldContain` ins-                                  Right r -> expectationFailure ("Should have errored, received this instead: " <> show r)+          Left rr -> show rr `shouldContain` ins+          Right r -> expectationFailure ("Should have errored, received this instead: " <> show r)     it "should error with invalid arguments" $ do-        checkError [] "Expects at least two hashes"-        checkError [PNumber 1] "Expects at least two hashes"-        checkError [PBoolean True] "Expects at least two hashes"-        checkError ["foo"] "Expects at least two hashes"+      checkError [] "Expects at least two hashes"+      checkError [PNumber 1] "Expects at least two hashes"+      checkError [PBoolean True] "Expects at least two hashes"+      checkError ["foo"] "Expects at least two hashes"     it "should handle empty hashes" $ do-        check [[],[]] []-        check [[],[],[]] []+      check [[], []] []+      check [[], [], []] []     it "should merge hashes" $ do-        check [ [("key", "value")], [] ] [("key","value")]-        check [ [], [("key", "value")] ] [("key","value")]-        check [ [("key1", "value1")], [("key2", "value2")], [("key3", "value3")] ] [("key1", "value1"), ("key2", "value2"), ("key3", "value3")]-        check [ [("key", "value1")], [("key", "value2")] ] [("key","value2")]+      check [[("key", "value")], []] [("key", "value")]+      check [[], [("key", "value")]] [("key", "value")]+      check [[("key1", "value1")], [("key2", "value2")], [("key3", "value3")]] [("key1", "value1"), ("key2", "value2"), ("key3", "value3")]+      check [[("key", "value1")], [("key", "value2")]] [("key", "value2")]  spec1 :: Spec spec1 =- describe "deep_merge" $-  withStdlibFunction "deep_merge" $ \mergeFunc -> do-    let evalArgs' = evalArgs . mergeFunc-    let check args res = case evalArgs' (map PHash args) of-                             Left rr -> expectationFailure (show rr)-                             Right res' -> res' `shouldBe` res-        checkError args ins = case evalArgs' args of-                                  Left rr -> show rr `shouldContain` ins-                                  Right r -> expectationFailure ("Should have errored, received this instead: " <> show r)+  describe "deep_merge" $+    withStdlibFunction "deep_merge" $ \mergeFunc -> do+      let evalArgs' = evalArgs . mergeFunc+      let check args res = case evalArgs' (map PHash args) of+            Left rr -> expectationFailure (show rr)+            Right res' -> res' `shouldBe` res+          checkError args ins = case evalArgs' args of+            Left rr -> show rr `shouldContain` ins+            Right r -> expectationFailure ("Should have errored, received this instead: " <> show r) -    it "should error with invalid arguments" $ do+      it "should error with invalid arguments" $ do         checkError [] "Expects at least two hashes"         checkError [PNumber 1] "Expects at least two hashes"         checkError [PBoolean True] "Expects at least two hashes"         checkError ["foo"] "Expects at least two hashes"-    it "should handle empty hashes" $ do-        check [[],[]] []-        check [[],[],[]] []-    it "should deeply merge hashes" $ do-        check [ [("key", "value")], [] ] [("key","value")]-        check [ [], [("key", "value")] ] [("key","value")]-        check [ [("key1", "value1")]-              , [("key2", "value2")]-              , [("key3", "value3")]-              ] [("key1", "value1"), ("key2", "value2"), ("key3", "value3")]-        check [ [("key", "value1")]-              , [("key", "value2")]-              ] [("key","value2")]-        check [ [("key", PHash [("key00", "value00")])]-              , [("key", PHash [("key01", "value01")])]-              ] [("key", PHash [("key01", PString "value01"), ("key00", PString "value00")])]-        check [ [("key", PHash [("key01", "value00")])]-              , [("key", PHash [("key01", "value01")])]-              ] [("key", PHash [("key01", PString "value01")])]+      it "should handle empty hashes" $ do+        check [[], []] []+        check [[], [], []] []+      it "should deeply merge hashes" $ do+        check [[("key", "value")], []] [("key", "value")]+        check [[], [("key", "value")]] [("key", "value")]+        check+          [ [("key1", "value1")],+            [("key2", "value2")],+            [("key3", "value3")]+          ]+          [("key1", "value1"), ("key2", "value2"), ("key3", "value3")]+        check+          [ [("key", "value1")],+            [("key", "value2")]+          ]+          [("key", "value2")]+        check+          [ [("key", PHash [("key00", "value00")])],+            [("key", PHash [("key01", "value01")])]+          ]+          [("key", PHash [("key01", PString "value01"), ("key00", PString "value00")])]+        check+          [ [("key", PHash [("key01", "value00")])],+            [("key", PHash [("key01", "value01")])]+          ]+          [("key", PHash [("key01", PString "value01")])]
tests/Interpreter/Function/PrefixSpec.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE OverloadedLists #-}+ module Interpreter.Function.PrefixSpec (spec, main) where  import qualified Data.Text as T--import           Helpers+import Helpers  main :: IO () main = hspec spec@@ -13,27 +13,26 @@  spec :: Spec spec = withStdlibFunction fname $ \tester -> do-    let checkError input expectederror =-           case dummyEval (tester input) of-             Left rr -> show (getError rr) `shouldStartWith` (T.unpack fname ++ ": " ++ expectederror)-             Right _ -> expectationFailure "should have failed"-        checkSuccess input expected =-           case dummyEval (tester input) of-             Left rr -> expectationFailure (show rr)-             Right r -> r `shouldBe` expected-    it "should fail with no argument" (checkError [] "expects two arguments")-    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")-    it "should fail if the second argument isn't a string" $ do-      checkError [PArray [], PNumber 1] "expects the second argument to be a string"-      checkError [PArray [], PArray []] "expects the second argument to be a string"-    it "should work with arrays" $ do-      checkSuccess [ PArray []] (PArray [])-      checkSuccess [ PArray [], ""] (PArray [])-      checkSuccess [ PArray ["one"], "pre" ] (PArray ["preone"])-      checkSuccess [ PArray ["one","two","three"], "pre" ] (PArray ["preone","pretwo","prethree"])-    it "should work with hashes" $ do-      checkSuccess [(PHash mempty)] (PHash mempty)-      checkSuccess [(PHash mempty), ""] (PHash mempty)-      checkSuccess [(PHash [("one", PNumber 5)] ), "pre" ] (PHash [("preone", PNumber 5)])-      checkSuccess [(PHash [("one", PNumber 5), ("two", "lol"), ("three", PNumber 7)]), "pre" ] (PHash [("preone", PNumber 5), ("pretwo", "lol"), ("prethree", PNumber 7)])-+  let checkError input expectederror =+        case dummyEval (tester input) of+          Left rr -> show (getError rr) `shouldStartWith` (T.unpack fname ++ ": " ++ expectederror)+          Right _ -> expectationFailure "should have failed"+      checkSuccess input expected =+        case dummyEval (tester input) of+          Left rr -> expectationFailure (show rr)+          Right r -> r `shouldBe` expected+  it "should fail with no argument" (checkError [] "expects two arguments")+  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")+  it "should fail if the second argument isn't a string" $ do+    checkError [PArray [], PNumber 1] "expects the second argument to be a string"+    checkError [PArray [], PArray []] "expects the second argument to be a string"+  it "should work with arrays" $ do+    checkSuccess [PArray []] (PArray [])+    checkSuccess [PArray [], ""] (PArray [])+    checkSuccess [PArray ["one"], "pre"] (PArray ["preone"])+    checkSuccess [PArray ["one", "two", "three"], "pre"] (PArray ["preone", "pretwo", "prethree"])+  it "should work with hashes" $ do+    checkSuccess [PHash mempty] (PHash mempty)+    checkSuccess [PHash mempty, ""] (PHash mempty)+    checkSuccess [PHash [("one", PNumber 5)], "pre"] (PHash [("preone", PNumber 5)])+    checkSuccess [PHash [("one", PNumber 5), ("two", "lol"), ("three", PNumber 7)], "pre"] (PHash [("preone", PNumber 5), ("pretwo", "lol"), ("prethree", PNumber 7)])
tests/Interpreter/Function/ShellquoteSpec.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedLists #-}+ module Interpreter.Function.ShellquoteSpec (spec, main) where -import           Helpers+import Helpers  main :: IO () main = hspec spec@@ -11,31 +12,40 @@  spec :: Spec spec = do-    it "should handle no arguments" (check [] "")-    it "should handle array arguments" $-        check ["foo", ["bar@example.com", "localhost:/dev/null"], "xyzzy+-4711,23"]-              "foo bar@example.com localhost:/dev/null xyzzy+-4711,23"-    it "should quote unsafe characters" $-        check ["/etc/passwd ", "(ls)", "*", "[?]", "'&'"]-              "\"/etc/passwd \" \"(ls)\" \"*\" \"[?]\" \"'&'\""-    it "should deal with double quotes" $-        check ["\"foo\"bar\""]-              "'\"foo\"bar\"'"-    it "should cope with dollar signs" $-        check ["$PATH", "foo$bar", "\"x$\""]-              "'$PATH' 'foo$bar' '\"x$\"'"-    it "should deal with apostrophes (single quotes)" $-        check ["'foo'bar'", "`$'EDITOR'`"]-              "\"'foo'bar'\" \"\\`\\$'EDITOR'\\`\""-    it "should cope with grave accents (backquotes)" $-        check ["`echo *`", "`ls \"$MAILPATH\"`"]-              "'`echo *`' '`ls \"$MAILPATH\"`'"-    it "should deal with both single and double quotes" $-        check ["'foo\"bar\"xyzzy'", "\"foo'bar'xyzzy\""]-              "\"'foo\\\"bar\\\"xyzzy'\" \"\\\"foo'bar'xyzzy\\\"\""-    it "should handle multiple quotes *and* dollars and backquotes" $-        check ["'foo\"$x`bar`\"xyzzy'"]-              "\"'foo\\\"\\$x\\`bar\\`\\\"xyzzy'\""-    it "should handle linefeeds" $-        check ["foo \n bar"]-              "\"foo \n bar\""+  it "should handle no arguments" (check [] "")+  it "should handle array arguments" $+    check+      ["foo", ["bar@example.com", "localhost:/dev/null"], "xyzzy+-4711,23"]+      "foo bar@example.com localhost:/dev/null xyzzy+-4711,23"+  it "should quote unsafe characters" $+    check+      ["/etc/passwd ", "(ls)", "*", "[?]", "'&'"]+      "\"/etc/passwd \" \"(ls)\" \"*\" \"[?]\" \"'&'\""+  it "should deal with double quotes" $+    check+      ["\"foo\"bar\""]+      "'\"foo\"bar\"'"+  it "should cope with dollar signs" $+    check+      ["$PATH", "foo$bar", "\"x$\""]+      "'$PATH' 'foo$bar' '\"x$\"'"+  it "should deal with apostrophes (single quotes)" $+    check+      ["'foo'bar'", "`$'EDITOR'`"]+      "\"'foo'bar'\" \"\\`\\$'EDITOR'\\`\""+  it "should cope with grave accents (backquotes)" $+    check+      ["`echo *`", "`ls \"$MAILPATH\"`"]+      "'`echo *`' '`ls \"$MAILPATH\"`'"+  it "should deal with both single and double quotes" $+    check+      ["'foo\"bar\"xyzzy'", "\"foo'bar'xyzzy\""]+      "\"'foo\\\"bar\\\"xyzzy'\" \"\\\"foo'bar'xyzzy\\\"\""+  it "should handle multiple quotes *and* dollars and backquotes" $+    check+      ["'foo\"$x`bar`\"xyzzy'"]+      "\"'foo\\\"\\$x\\`bar\\`\\\"xyzzy'\""+  it "should handle linefeeds" $+    check+      ["foo \n bar"]+      "\"foo \n bar\""
tests/Interpreter/Function/SizeSpec.hs view
@@ -1,42 +1,44 @@ {-# LANGUAGE OverloadedLists #-}+ module Interpreter.Function.SizeSpec (spec, main) where -import           Helpers+import Helpers  main :: IO () main = hspec spec  evalArgs :: InterpreterMonad PValue -> Either PrettyError Scientific-evalArgs = dummyEval-        >=> \pv -> case pv of-                      PNumber s -> return s-                      _ -> Left ("Expected a string, not " <> PrettyError (pretty pv))+evalArgs =+  dummyEval+    >=> \pv -> case pv of+      PNumber s -> return s+      _ -> Left ("Expected a string, not " <> PrettyError (pretty pv))  spec :: Spec spec = withStdlibFunction "size" $ \sizeFunc -> do-    let evalArgs' = evalArgs . sizeFunc-    let check args res = case evalArgs' args of-                             Left rr -> expectationFailure (show rr)-                             Right res' -> res' `shouldBe` res-        checkError args ins = case evalArgs' args of-                                  Left rr -> show rr `shouldContain` ins-                                  Right r -> expectationFailure ("Should have errored, received this instead: " <> show r)-    it "should error with no arguments" (checkError [] "a single argument")-    it "should error with numerical arguments" (checkError [PNumber 1] "size(): Expects ")-    it "should error with boolean arguments" (checkError [PBoolean True] "size(): Expects ")-    -- Not conformant:-    -- it "should error with numerical arguments" (checkError ["1"] "size(): Expects ")-    it "should handle arrays" $ do-        check [PArray []] 0-        check [PArray ["a"]] 1-        check [PArray ["one","two","three"]] 3-        check [PArray ["one","two","three","four"]] 4-    it "should handle hashes" $ do-        check [PHash []] 0-        check [PHash [("1","2")]] 1-        check [PHash [("1","2"),("3","4")]] 2-    it "should handle strings" $ do-        check [""] 0-        check ["a"] 1-        check ["ab"] 2-        check ["abcd"] 4+  let evalArgs' = evalArgs . sizeFunc+  let check args res = case evalArgs' args of+        Left rr -> expectationFailure (show rr)+        Right res' -> res' `shouldBe` res+      checkError args ins = case evalArgs' args of+        Left rr -> show rr `shouldContain` ins+        Right r -> expectationFailure ("Should have errored, received this instead: " <> show r)+  it "should error with no arguments" (checkError [] "a single argument")+  it "should error with numerical arguments" (checkError [PNumber 1] "size(): Expects ")+  it "should error with boolean arguments" (checkError [PBoolean True] "size(): Expects ")+  -- Not conformant:+  -- it "should error with numerical arguments" (checkError ["1"] "size(): Expects ")+  it "should handle arrays" $ do+    check [PArray []] 0+    check [PArray ["a"]] 1+    check [PArray ["one", "two", "three"]] 3+    check [PArray ["one", "two", "three", "four"]] 4+  it "should handle hashes" $ do+    check [PHash []] 0+    check [PHash [("1", "2")]] 1+    check [PHash [("1", "2"), ("3", "4")]] 2+  it "should handle strings" $ do+    check [""] 0+    check ["a"] 1+    check ["ab"] 2+    check ["abcd"] 4
tests/Interpreter/Function/SprintfSpec.hs view
@@ -1,6 +1,6 @@ module Interpreter.Function.SprintfSpec (spec, main) where -import           Helpers+import Helpers  main :: IO () main = hspec spec@@ -15,27 +15,27 @@  spec :: Spec spec = do-    it "should fail with no argument" (checkError [] "Expects a string as its first argument")-    it "should succeed with one argument" (checkSuccess ["hello"] "hello") -- puppet sprintf accepts one arg-    it "should work with multiple arguments" (checkSuccess ["hello %s %s", "world", "!"] "hello world !")-    it "should work with one string argument" (checkSuccess ["hello %s", "world"] "hello world" )-    it "should work with one int argument" (checkSuccess ["hello %d", 10] "hello 10" )-    it "should fail if arg is not provided" (checkError ["hello %s"] "not enough arguments")-    it "should fail when a wrong format instruction is used" (checkError ["hello %d", "world"] "Don't know how to convert this to a number" )-    it "should fail when a wrong format instruction is used" (checkError ["hello %f", "world"] "Don't know how to convert this to a number" )-    it "should work with one int argument" (checkSuccess ["hello %f", 1.0] "hello 1.0" )-    it "should work with one int argument" (checkSuccess ["hello %.1f", 1.23] "hello 1.2" )-    it "should pad with zeroes" (checkSuccess ["hello %03d", 10] "hello 010")-    it "should pad with spaces" (checkSuccess ["hello % 3d", 10] "hello  10")-    it "should format integers" (checkSuccess ["%+05d", 23] "+0023")-    it "should format floats" (checkSuccess ["%+.2f", 2.7182818284590451] "+2.72")-    it "should format large floats" (pendingWith "Minor formatting difference" >> checkSuccess ["%+.2e", 27182818284590451] "+2.72e+16")-    it "should work with    " (checkSuccess ["%5d"   , 5] "    5")-    it "should work with   0" (checkSuccess ["%05d"  , 5] "00005")-    it "should work with  - " (checkSuccess ["%-5d"  , 5] "5    ")-    it "should work with  -0" (checkSuccess ["%-05d" , 5] "5    ")-    it "should work with +  " (checkSuccess ["%+5d"  , 5] "   +5")-    it "should work with + 0" (checkSuccess ["%+05d" , 5] "+0005")-    it "should work with +- " (checkSuccess ["%+-5d" , 5] "+5   ")-    it "should work with +-0" (checkSuccess ["%+-05d", 5] "+5   ")-    it "should perform more complex formatting" (pendingWith "# is not yet supported" >> checkSuccess [ "<%.8s:%#5o %#8X (%-8s)>", "overlongstring", 23, 48879, "foo" ] "<overlong:  027   0XBEEF (foo     )>")+  it "should fail with no argument" (checkError [] "Expects a string as its first argument")+  it "should succeed with one argument" (checkSuccess ["hello"] "hello") -- puppet sprintf accepts one arg+  it "should work with multiple arguments" (checkSuccess ["hello %s %s", "world", "!"] "hello world !")+  it "should work with one string argument" (checkSuccess ["hello %s", "world"] "hello world")+  it "should work with one int argument" (checkSuccess ["hello %d", 10] "hello 10")+  it "should fail if arg is not provided" (checkError ["hello %s"] "not enough arguments")+  it "should fail when a wrong format instruction is used" (checkError ["hello %d", "world"] "Don't know how to convert this to a number")+  it "should fail when a wrong format instruction is used" (checkError ["hello %f", "world"] "Don't know how to convert this to a number")+  it "should work with one int argument" (checkSuccess ["hello %f", 1.0] "hello 1.0")+  it "should work with one int argument" (checkSuccess ["hello %.1f", 1.23] "hello 1.2")+  it "should pad with zeroes" (checkSuccess ["hello %03d", 10] "hello 010")+  it "should pad with spaces" (checkSuccess ["hello % 3d", 10] "hello  10")+  it "should format integers" (checkSuccess ["%+05d", 23] "+0023")+  it "should format floats" (checkSuccess ["%+.2f", 2.7182818284590451] "+2.72")+  it "should format large floats" (pendingWith "Minor formatting difference" >> checkSuccess ["%+.2e", 27182818284590451] "+2.72e+16")+  it "should work with    " (checkSuccess ["%5d", 5] "    5")+  it "should work with   0" (checkSuccess ["%05d", 5] "00005")+  it "should work with  - " (checkSuccess ["%-5d", 5] "5    ")+  it "should work with  -0" (checkSuccess ["%-05d", 5] "5    ")+  it "should work with +  " (checkSuccess ["%+5d", 5] "   +5")+  it "should work with + 0" (checkSuccess ["%+05d", 5] "+0005")+  it "should work with +- " (checkSuccess ["%+-5d", 5] "+5   ")+  it "should work with +-0" (checkSuccess ["%+-05d", 5] "+5   ")+  it "should perform more complex formatting" (pendingWith "# is not yet supported" >> checkSuccess ["<%.8s:%#5o %#8X (%-8s)>", "overlongstring", 23, 48879, "foo"] "<overlong:  027   0XBEEF (foo     )>")
tests/Interpreter/Function/SuffixSpec.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE OverloadedLists #-}+ module Interpreter.Function.SuffixSpec (spec, main) where  import qualified Data.Text as T--import           Helpers+import Helpers  main :: IO () main = hspec spec@@ -13,27 +13,26 @@  spec :: Spec spec = withStdlibFunction fname $ \tester -> do-    let checkError input expectederror =-           case dummyEval (tester input) of-             Left rr -> show (getError rr) `shouldStartWith` (T.unpack fname ++ ": " ++ expectederror)-             Right _ -> expectationFailure "should have failed"-        checkSuccess input expected =-           case dummyEval (tester input) of-             Left rr -> expectationFailure (show rr)-             Right r -> r `shouldBe` expected-    it "should fail with no argument" (checkError [] "expects two arguments")-    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")-    it "should fail if the second argument isn't a string" $ do-      checkError [PArray [], PNumber 1] "expects the second argument to be a string"-      checkError [PArray [], PArray []] "expects the second argument to be a string"-    it "should work with arrays" $ do-      checkSuccess [ PArray []] (PArray [])-      checkSuccess [ PArray [], ""] (PArray [])-      checkSuccess [ PArray ["one"], "post" ] (PArray ["onepost"])-      checkSuccess [ PArray ["one","two","three"], "post" ] (PArray ["onepost","twopost","threepost"])-    it "should work with hashes" $ do-      checkSuccess [(PHash mempty)] (PHash mempty)-      checkSuccess [(PHash mempty), ""] (PHash mempty)-      checkSuccess [(PHash [("one", PNumber 5)] ), "post" ] (PHash [("onepost", PNumber 5)])-      checkSuccess [(PHash [("one", PNumber 5), ("two", "lol"), ("three", PNumber 7)]), "post" ] (PHash [("onepost", PNumber 5), ("twopost", "lol"), ("threepost", PNumber 7)])-+  let checkError input expectederror =+        case dummyEval (tester input) of+          Left rr -> show (getError rr) `shouldStartWith` (T.unpack fname ++ ": " ++ expectederror)+          Right _ -> expectationFailure "should have failed"+      checkSuccess input expected =+        case dummyEval (tester input) of+          Left rr -> expectationFailure (show rr)+          Right r -> r `shouldBe` expected+  it "should fail with no argument" (checkError [] "expects two arguments")+  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")+  it "should fail if the second argument isn't a string" $ do+    checkError [PArray [], PNumber 1] "expects the second argument to be a string"+    checkError [PArray [], PArray []] "expects the second argument to be a string"+  it "should work with arrays" $ do+    checkSuccess [PArray []] (PArray [])+    checkSuccess [PArray [], ""] (PArray [])+    checkSuccess [PArray ["one"], "post"] (PArray ["onepost"])+    checkSuccess [PArray ["one", "two", "three"], "post"] (PArray ["onepost", "twopost", "threepost"])+  it "should work with hashes" $ do+    checkSuccess [PHash mempty] (PHash mempty)+    checkSuccess [PHash mempty, ""] (PHash mempty)+    checkSuccess [PHash [("one", PNumber 5)], "post"] (PHash [("onepost", PNumber 5)])+    checkSuccess [PHash [("one", PNumber 5), ("two", "lol"), ("three", PNumber 7)], "post"] (PHash [("onepost", PNumber 5), ("twopost", "lol"), ("threepost", PNumber 7)])
tests/Interpreter/Function/WithSpec.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE OverloadedLists #-} module Interpreter.Function.WithSpec where -import           Helpers+import Helpers  main :: IO () main = hspec spec@@ -9,30 +8,30 @@ spec :: Spec spec = do   let getCatalog x = case pureCatalog x of-                        Left rr -> fail rr-                        Right (y,_) -> pure y+        Left rr -> fail rr+        Right (y, _) -> pure y   describe "should run as" $ do     it "should be callable with an argument" $       getCatalog "with ( 12 ) |$x| { file {'/f': content => $x; } }"-       >>= getResource (RIdentifier "file" "/f")-       >>= getAttribute "content"-       >>= (`shouldBe` "12")+        >>= getResource (RIdentifier "file" "/f")+        >>= getAttribute "content"+        >>= (`shouldBe` "12")     it "should be callable with two arguments" $       getCatalog "with ( '/tmp/lal', 12 ) |$f, $x| { file {$f: content => $x; } }"-       >>= getResource (RIdentifier "file" "/tmp/lal")-       >>= getAttribute "content"-       >>= (`shouldBe` "12")+        >>= getResource (RIdentifier "file" "/tmp/lal")+        >>= getAttribute "content"+        >>= (`shouldBe` "12")     it "should separate scopes scope" $ do       getCatalog "$x='lol' \n with ( 12 ) |$x| { file {'/f': content => $x; } } \n file {'/g': content => $x; }"-       >>= getResource (RIdentifier "file" "/f")-       >>= getAttribute "content"-       >>= (`shouldBe` "12")+        >>= getResource (RIdentifier "file" "/f")+        >>= getAttribute "content"+        >>= (`shouldBe` "12")       getCatalog "$x='lol' \n with ( 12 ) |$x| { file {'/f': content => $x; } } \n file {'/g': content => $x; }"-       >>= getResource (RIdentifier "file" "/g")-       >>= getAttribute "content"-       >>= (`shouldBe` "lol")+        >>= getResource (RIdentifier "file" "/g")+        >>= getAttribute "content"+        >>= (`shouldBe` "lol")     it "should work in value mode" $       getCatalog "$x= with ('a', 'b' ) |$x, $y| { \"${x} and ${y}\" } \n file {'/g': content => $x; }"-       >>= getResource (RIdentifier "file" "/g")-       >>= getAttribute "content"-       >>= (`shouldBe` "a and b")+        >>= getResource (RIdentifier "file" "/g")+        >>= getAttribute "content"+        >>= (`shouldBe` "a and b")
tests/Interpreter/IfSpec.hs view
@@ -1,30 +1,35 @@-{-# LANGUAGE OverloadedLists #-}--- | Directly ported from puppet specs-module Interpreter.IfSpec (spec) where+{-# LANGUAGE OverloadedLists #-} -import           Test.Hspec+-- |  Directly ported from puppet specs+module Interpreter.IfSpec (spec) where -import           Control.Lens+import Control.Lens import qualified Data.Text as Text--import           Helpers+import Helpers+import Test.Hspec  shouldFail :: [Text] -> Expectation-shouldFail content = let cat = pureCatalog (Text.unlines content)-                     in  cat `shouldSatisfy` has _Left+shouldFail content =+  let cat = pureCatalog (Text.unlines content)+   in cat `shouldSatisfy` has _Left  shouldNotFail :: [Text] -> Expectation-shouldNotFail content = let cat = pureCatalog (Text.unlines content)-                        in  cat `shouldSatisfy` has _Right+shouldNotFail content =+  let cat = pureCatalog (Text.unlines content)+   in cat `shouldSatisfy` has _Right  spec :: Spec spec = do   describe "If" $ do-    it "doesn't enter false conditions" $ shouldNotFail-        [ "if (false) { fail ':(' }" ]-    it "enters true conditions" $ shouldFail-        [ "if (true) { fail ':(' }" ]-    it "enters empty string conditions" $ shouldFail-        [ "if '' { fail ':(' }" ]-    it "not (unknown variable) is true" $ shouldFail-        [ "if (!$::unknown123) { fail ':(' }" ]+    it "doesn't enter false conditions" $+      shouldNotFail+        ["if (false) { fail ':(' }"]+    it "enters true conditions" $+      shouldFail+        ["if (true) { fail ':(' }"]+    it "enters empty string conditions" $+      shouldFail+        ["if '' { fail ':(' }"]+    it "not (unknown variable) is true" $+      shouldFail+        ["if (!$::unknown123) { fail ':(' }"]
tests/Parser/DT.hs view
@@ -1,13 +1,12 @@ module Parser.DT (spec) where -import           Helpers--import           Test.Hspec.Megaparsec-import           Text.Megaparsec (parse)+import GHC.Base (error)+import Helpers+import Puppet.Parser.Internal+import Test.Hspec.Megaparsec+import Text.Megaparsec (parse) import qualified Text.Regex.PCRE.ByteString.Utils as Regex -import           Puppet.Parser.Internal- spec :: Spec spec = do   let parsed s r = it ("accepts " <> toS s) $ parse datatype "?" s `shouldParse` r@@ -19,7 +18,9 @@     "String[5]" `parsed` UDTString (Just 5) Nothing     "String[5,8]" `parsed` UDTString (Just 5) (Just 8)     "Regexp" `parsed` UDTRegexp Nothing-    let Right foore = Regex.compile' Regex.compBlank Regex.execBlank "foo"+    let foore = case Regex.compile' Regex.compBlank Regex.execBlank "foo" of+          Right ok -> ok+          Left rr -> error (show rr)     "Regexp[/foo/]" `parsed` UDTRegexp (Just (CompRegex "foo" foore))     it "accepts variables" $ pendingWith "to be fixed" *> parse datatype "?" "String[$var]" `shouldParse` UDTString (Just 5) Nothing   describe "Stdlib::" $ do
tests/Parser/ExprSpec.hs view
@@ -1,55 +1,67 @@ {-# LANGUAGE OverloadedLists #-}-module Parser.ExprSpec (spec) where -import           Test.Hspec-import           Test.Hspec.Megaparsec-import           Text.Megaparsec+module Parser.ExprSpec (spec) where -import           Puppet.Parser-import           Puppet.Parser.Internal-import           XPrelude+import Puppet.Parser+import Puppet.Parser.Internal+import Test.Hspec+import Test.Hspec.Megaparsec+import Text.Megaparsec+import XPrelude  expressions :: [(Text, Expression)] expressions =-    [ ("5 + 3 * 2", 5 + 3 * 2)-    , ("5+2 == 7", Equal (5 + 2) 7)-    , ("include(foo::bar)",  Terminal (UFunctionCall "include" ["foo::bar"] ))-    , ("fail(('foo'))",  Terminal (UFunctionCall "fail" ["foo"] ))-    , ("test(foo,bar)",  Terminal (UFunctionCall "test" ["foo", "bar"] ))-    , ("extlib::test()",  Terminal (UFunctionCall "extlib::test" [] ))-    , ("extlib::test(fail('foo'))",  Terminal (UFunctionCall "extlib::test" [Terminal (UFunctionCall "fail" [Terminal (UString "foo")])]))-    , ("test(extlib::test())",  Terminal (UFunctionCall "test" [Terminal (UFunctionCall "extlib::test" [])] ))-    , ("test ( foo , bar )",  Terminal (UFunctionCall "test" ["foo", "bar"] ))-    , ("$y ? {\-     \ undef   => 'undef',\-     \ default => 'default',\-    \ }",  ConditionalValue (Terminal (UVariableReference "y"))-           [ SelectorValue UUndef :!: Terminal (UString "undef")-           , SelectorDefault :!: Terminal (UString "default")])-    , ("$x", Terminal (UVariableReference "x"))-    , ("x($y)", Terminal (UFunctionCall "x" [ Terminal (UVariableReference "y") ]))-    , ("\"$\"", Terminal (UInterpolable [Terminal (UString "$")]))-    , ("\"${x}\"", Terminal (UInterpolable [Terminal (UVariableReference "x")]))-    , ("$x[ 3 ]",  Lookup (Terminal (UVariableReference "x")) (Terminal (UNumber 3)))-    , ("\"${ os[ 'architecture' ]}\"", Terminal (UInterpolable [Lookup (Terminal (UVariableReference "os")) (Terminal (UString "architecture"))]))-    , ("\"${facts['os']['architecture']}\"", Terminal (UInterpolable [Lookup (Lookup (Terminal (UVariableReference "facts")) (Terminal (UString "os"))) (Terminal (UString "architecture"))]))-    , ("\"${x[$y]}\"", Terminal (UInterpolable [Lookup (Terminal (UVariableReference "x")) (Terminal (UVariableReference "y")) ]))-    , ("\"${x($y)}\"", Terminal (UInterpolable [ Terminal (UFunctionCall "x" [ Terminal (UVariableReference "y") ] ) ] ))-    , ("\"${x($y)}$'\"", Terminal (UInterpolable [ Terminal (UFunctionCall "x" [ Terminal (UVariableReference "y") ])-                                                 , Terminal (UString "$"),Terminal (UString "'")]))-    ]+  [ ("5 + 3 * 2", 5 + 3 * 2),+    ("5+2 == 7", Equal (5 + 2) 7),+    ("include(foo::bar)", Terminal (UFunctionCall "include" ["foo::bar"])),+    ("fail(('foo'))", Terminal (UFunctionCall "fail" ["foo"])),+    ("test(foo,bar)", Terminal (UFunctionCall "test" ["foo", "bar"])),+    ("extlib::test()", Terminal (UFunctionCall "extlib::test" [])),+    ("extlib::test(fail('foo'))", Terminal (UFunctionCall "extlib::test" [Terminal (UFunctionCall "fail" [Terminal (UString "foo")])])),+    ("test(extlib::test())", Terminal (UFunctionCall "test" [Terminal (UFunctionCall "extlib::test" [])])),+    ("test ( foo , bar )", Terminal (UFunctionCall "test" ["foo", "bar"])),+    ( "$y ? {\+      \ undef   => 'undef',\+      \ default => 'default',\+      \ }",+      ConditionalValue+        (Terminal (UVariableReference "y"))+        [ SelectorValue UUndef :!: Terminal (UString "undef"),+          SelectorDefault :!: Terminal (UString "default")+        ]+    ),+    ("$x", Terminal (UVariableReference "x")),+    ("x($y)", Terminal (UFunctionCall "x" [Terminal (UVariableReference "y")])),+    ("\"$\"", Terminal (UInterpolable [Terminal (UString "$")])),+    ("\"${x}\"", Terminal (UInterpolable [Terminal (UVariableReference "x")])),+    ("$x[ 3 ]", Lookup (Terminal (UVariableReference "x")) (Terminal (UNumber 3))),+    ("\"${ os[ 'architecture' ]}\"", Terminal (UInterpolable [Lookup (Terminal (UVariableReference "os")) (Terminal (UString "architecture"))])),+    ("\"${facts['os']['architecture']}\"", Terminal (UInterpolable [Lookup (Lookup (Terminal (UVariableReference "facts")) (Terminal (UString "os"))) (Terminal (UString "architecture"))])),+    ("\"${x[$y]}\"", Terminal (UInterpolable [Lookup (Terminal (UVariableReference "x")) (Terminal (UVariableReference "y"))])),+    ("\"${x($y)}\"", Terminal (UInterpolable [Terminal (UFunctionCall "x" [Terminal (UVariableReference "y")])])),+    ( "\"${x($y)}$'\"",+      Terminal+        ( UInterpolable+            [ Terminal (UFunctionCall "x" [Terminal (UVariableReference "y")]),+              Terminal (UString "$"),+              Terminal (UString "'")+            ]+        )+    )+  ]  invalid :: [Text]-invalid = [ "$os['name]"-          -- pending-          -- , "$os ['name']"-           -- interpolation-          , "\"${os['name]}\""-          , "\"${os[name}\""-          , "\"${os[name]\""-          ]+invalid =+  [ "$os['name]",+    -- pending+    -- , "$os ['name']"+    -- interpolation+    "\"${os['name]}\"",+    "\"${os[name}\"",+    "\"${os[name]\""+  ] -testExpression (t,e) = it ("should parse " <> toS t) $ parse (expression <* eof) "" t `shouldParse` e+testExpression (t, e) = it ("should parse " <> toS t) $ parse (expression <* eof) "" t `shouldParse` e  testInvalid s = it ("rejects " <> toS s) $ shouldFailOn (parse (expression <* eof) "") s
tests/Parser/LexerSpec.hs view
@@ -1,30 +1,27 @@-module Parser.LexerSpec(spec) where--import           XPrelude--import           System.FilePath.Glob-import           Test.Hspec-import           Text.Megaparsec      (eof, parse)-import           Test.Hspec.Megaparsec+module Parser.LexerSpec (spec) where -import           Puppet.Parser-import           Puppet.Parser.Internal+import Puppet.Parser+import Puppet.Parser.Internal+import System.FilePath.Glob+import Test.Hspec+import Test.Hspec.Megaparsec+import Text.Megaparsec (eof, parse)+import XPrelude  validFiles = do   files <- runIO $ globDir1 (compile "*.pp") "tests/Parser/lexer"   mapM_ test files-   where     test fp = do-      r <- runIO  $ fmap check (readFile fp)+      r <- runIO $ fmap check (readFile fp)       it ("should parse " <> fp) r-    check i  =+    check i =       parse (puppetParser <* eof) empty `shouldSucceedOn` i  spec = describe "Lexer" $ do-  describe "Valid lexer" $ validFiles+  describe "Valid lexer" validFiles   describe "Invalid lexer" $ do-    it "should fail to parse resource reference with a space after the resource type" $ invalid resourceReference  "File ['/test']"+    it "should fail to parse resource reference with a space after the resource type" $ invalid resourceReference "File ['/test']"     xit "should fail if there is a space after the variable name" $ invalid interpolableString "\"${os ['name']}\""  -- Utils
tests/PuppetdbSpec.hs view
@@ -1,14 +1,12 @@-module PuppetdbSpec(spec) where--import           XPrelude--import qualified Data.Text      as Text-import           System.IO.Temp as Temp-import           Test.Hspec+module PuppetdbSpec (spec) where -import           PuppetDB+import qualified Data.Text as Text+import PuppetDB+import System.IO.Temp as Temp+import Test.Hspec+import XPrelude -checkPanicE :: Show x => Text -> ExceptT x IO a -> IO a+checkPanicE :: (Show x) => Text -> ExceptT x IO a -> IO a checkPanicE msg = runExceptT >=> either (panic . ((msg <> " ") <>) . show) return  fqdn = "node.site.com"@@ -29,7 +27,7 @@         checkPanicE "replaceFacts" (replaceFacts pdb [(fqdn, nfacts)])         checkPanicE "commitDB" (commitDB pdb)         -- check that our custom fact was indeed saved-        dblines <- (fmap Text.strip . Text.lines) <$> readFile pdbfile+        dblines <- fmap Text.strip . Text.lines <$> readFile pdbfile         dblines `shouldContain` ["customfact: MyCustomFactValue"]         -- initiate a new puppetdbapi         fpdb <- loadTestDB pdbfile >>= unwrapError "loadTestDB"@@ -38,5 +36,5 @@         checkPanicE "replaceCatalog" (replaceCatalog fpdb (generateWireCatalog fqdn mempty mempty))         checkPanicE "commit 2" (commitDB fpdb)         -- check our facts again-        fdblines <- (fmap (Text.strip) . Text.lines) `fmap` readFile pdbfile+        fdblines <- (fmap Text.strip . Text.lines) `fmap` readFile pdbfile         fdblines `shouldContain` ["customfact: MyCustomFactValue"]
tests/Spec.hs view
@@ -1,8 +1,5 @@-import           Test.Hspec--import           Helpers- import qualified ErbSpec+import Helpers import qualified HieraSpec import qualified Interpreter.ClassSpec import qualified Interpreter.CollectorSpec@@ -25,6 +22,7 @@ import qualified Parser.ExprSpec import qualified Parser.LexerSpec import qualified PuppetdbSpec+import Test.Hspec  main :: IO () main = hspec spec