diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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** diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet -version: 1.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 diff --git a/progs/PuppetResources.hs b/progs/PuppetResources.hs --- a/progs/PuppetResources.hs +++ b/progs/PuppetResources.hs @@ -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 diff --git a/progs/pdbQuery.hs b/progs/pdbQuery.hs --- a/progs/pdbQuery.hs +++ b/progs/pdbQuery.hs @@ -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 diff --git a/progs/yera.hs b/progs/yera.hs --- a/progs/yera.hs +++ b/progs/yera.hs @@ -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 diff --git a/src/Erb.hs b/src/Erb.hs --- a/src/Erb.hs +++ b/src/Erb.hs @@ -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 diff --git a/src/Erb/Parser.hs b/src/Erb/Parser.hs --- a/src/Erb/Parser.hs +++ b/src/Erb/Parser.hs @@ -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 diff --git a/src/Erb/Ruby.hs b/src/Erb/Ruby.hs --- a/src/Erb/Ruby.hs +++ b/src/Erb/Ruby.hs @@ -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) diff --git a/src/Facter.hs b/src/Facter.hs --- a/src/Facter.hs +++ b/src/Facter.hs @@ -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 diff --git a/src/Hiera/Server.hs b/src/Hiera/Server.hs --- a/src/Hiera/Server.hs +++ b/src/Hiera/Server.hs @@ -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" diff --git a/src/Puppet/Interpreter.hs b/src/Puppet/Interpreter.hs --- a/src/Puppet/Interpreter.hs +++ b/src/Puppet/Interpreter.hs @@ -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 diff --git a/src/Puppet/Interpreter/Helpers.hs b/src/Puppet/Interpreter/Helpers.hs --- a/src/Puppet/Interpreter/Helpers.hs +++ b/src/Puppet/Interpreter/Helpers.hs @@ -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) diff --git a/src/Puppet/Interpreter/IO.hs b/src/Puppet/Interpreter/IO.hs --- a/src/Puppet/Interpreter/IO.hs +++ b/src/Puppet/Interpreter/IO.hs @@ -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 diff --git a/src/Puppet/Interpreter/PrettyPrinter.hs b/src/Puppet/Interpreter/PrettyPrinter.hs --- a/src/Puppet/Interpreter/PrettyPrinter.hs +++ b/src/Puppet/Interpreter/PrettyPrinter.hs @@ -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 diff --git a/src/Puppet/Interpreter/Resolve.hs b/src/Puppet/Interpreter/Resolve.hs --- a/src/Puppet/Interpreter/Resolve.hs +++ b/src/Puppet/Interpreter/Resolve.hs @@ -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 diff --git a/src/Puppet/Interpreter/Resolve/Sprintf.hs b/src/Puppet/Interpreter/Resolve/Sprintf.hs --- a/src/Puppet/Interpreter/Resolve/Sprintf.hs +++ b/src/Puppet/Interpreter/Resolve/Sprintf.hs @@ -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 diff --git a/src/Puppet/Interpreter/RubyRandom.hs b/src/Puppet/Interpreter/RubyRandom.hs --- a/src/Puppet/Interpreter/RubyRandom.hs +++ b/src/Puppet/Interpreter/RubyRandom.hs @@ -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) diff --git a/src/Puppet/Interpreter/Types.hs b/src/Puppet/Interpreter/Types.hs --- a/src/Puppet/Interpreter/Types.hs +++ b/src/Puppet/Interpreter/Types.hs @@ -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 . 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)) diff --git a/src/Puppet/Language.hs b/src/Puppet/Language.hs --- a/src/Puppet/Language.hs +++ b/src/Puppet/Language.hs @@ -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 diff --git a/src/Puppet/Language/Core.hs b/src/Puppet/Language/Core.hs --- a/src/Puppet/Language/Core.hs +++ b/src/Puppet/Language/Core.hs @@ -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) diff --git a/src/Puppet/Language/NativeTypes.hs b/src/Puppet/Language/NativeTypes.hs --- a/src/Puppet/Language/NativeTypes.hs +++ b/src/Puppet/Language/NativeTypes.hs @@ -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 + ) diff --git a/src/Puppet/Language/NativeTypes/Concat.hs b/src/Puppet/Language/NativeTypes/Concat.hs --- a/src/Puppet/Language/NativeTypes/Concat.hs +++ b/src/Puppet/Language/NativeTypes/Concat.hs @@ -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]) + ] diff --git a/src/Puppet/Language/NativeTypes/Cron.hs b/src/Puppet/Language/NativeTypes/Cron.hs --- a/src/Puppet/Language/NativeTypes/Cron.hs +++ b/src/Puppet/Language/NativeTypes/Cron.hs @@ -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 diff --git a/src/Puppet/Language/NativeTypes/Exec.hs b/src/Puppet/Language/NativeTypes/Exec.hs --- a/src/Puppet/Language/NativeTypes/Exec.hs +++ b/src/Puppet/Language/NativeTypes/Exec.hs @@ -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 diff --git a/src/Puppet/Language/NativeTypes/File.hs b/src/Puppet/Language/NativeTypes/File.hs --- a/src/Puppet/Language/NativeTypes/File.hs +++ b/src/Puppet/Language/NativeTypes/File.hs @@ -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) diff --git a/src/Puppet/Language/NativeTypes/Group.hs b/src/Puppet/Language/NativeTypes/Group.hs --- a/src/Puppet/Language/NativeTypes/Group.hs +++ b/src/Puppet/Language/NativeTypes/Group.hs @@ -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"]]) + ] diff --git a/src/Puppet/Language/NativeTypes/Helpers.hs b/src/Puppet/Language/NativeTypes/Helpers.hs --- a/src/Puppet/Language/NativeTypes/Helpers.hs +++ b/src/Puppet/Language/NativeTypes/Helpers.hs @@ -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 diff --git a/src/Puppet/Language/NativeTypes/Host.hs b/src/Puppet/Language/NativeTypes/Host.hs --- a/src/Puppet/Language/NativeTypes/Host.hs +++ b/src/Puppet/Language/NativeTypes/Host.hs @@ -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 diff --git a/src/Puppet/Language/NativeTypes/Mount.hs b/src/Puppet/Language/NativeTypes/Mount.hs --- a/src/Puppet/Language/NativeTypes/Mount.hs +++ b/src/Puppet/Language/NativeTypes/Mount.hs @@ -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]) + ] diff --git a/src/Puppet/Language/NativeTypes/Notify.hs b/src/Puppet/Language/NativeTypes/Notify.hs --- a/src/Puppet/Language/NativeTypes/Notify.hs +++ b/src/Puppet/Language/NativeTypes/Notify.hs @@ -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"]]) ] diff --git a/src/Puppet/Language/NativeTypes/Package.hs b/src/Puppet/Language/NativeTypes/Package.hs --- a/src/Puppet/Language/NativeTypes/Package.hs +++ b/src/Puppet/Language/NativeTypes/Package.hs @@ -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 diff --git a/src/Puppet/Language/NativeTypes/SshSecure.hs b/src/Puppet/Language/NativeTypes/SshSecure.hs --- a/src/Puppet/Language/NativeTypes/SshSecure.hs +++ b/src/Puppet/Language/NativeTypes/SshSecure.hs @@ -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 = diff --git a/src/Puppet/Language/NativeTypes/User.hs b/src/Puppet/Language/NativeTypes/User.hs --- a/src/Puppet/Language/NativeTypes/User.hs +++ b/src/Puppet/Language/NativeTypes/User.hs @@ -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]) + ] diff --git a/src/Puppet/Language/NativeTypes/ZoneRecord.hs b/src/Puppet/Language/NativeTypes/ZoneRecord.hs --- a/src/Puppet/Language/NativeTypes/ZoneRecord.hs +++ b/src/Puppet/Language/NativeTypes/ZoneRecord.hs @@ -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 diff --git a/src/Puppet/Language/Paths.hs b/src/Puppet/Language/Paths.hs --- a/src/Puppet/Language/Paths.hs +++ b/src/Puppet/Language/Paths.hs @@ -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 diff --git a/src/Puppet/Language/Resource.hs b/src/Puppet/Language/Resource.hs --- a/src/Puppet/Language/Resource.hs +++ b/src/Puppet/Language/Resource.hs @@ -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 diff --git a/src/Puppet/Language/Value.hs b/src/Puppet/Language/Value.hs --- a/src/Puppet/Language/Value.hs +++ b/src/Puppet/Language/Value.hs @@ -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 diff --git a/src/Puppet/Language/WireCatalog.hs b/src/Puppet/Language/WireCatalog.hs --- a/src/Puppet/Language/WireCatalog.hs +++ b/src/Puppet/Language/WireCatalog.hs @@ -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 -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 . 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) + ] diff --git a/src/Puppet/Parser.hs b/src/Puppet/Parser.hs --- a/src/Puppet/Parser.hs +++ b/src/Puppet/Parser.hs @@ -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. diff --git a/src/Puppet/Parser/Internal.hs b/src/Puppet/Parser/Internal.hs --- a/src/Puppet/Parser/Internal.hs +++ b/src/Puppet/Parser/Internal.hs @@ -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)) diff --git a/src/Puppet/Parser/Lens.hs b/src/Puppet/Parser/Lens.hs --- a/src/Puppet/Parser/Lens.hs +++ b/src/Puppet/Parser/Lens.hs @@ -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 = diff --git a/src/Puppet/Parser/PrettyPrinter.hs b/src/Puppet/Parser/PrettyPrinter.hs --- a/src/Puppet/Parser/PrettyPrinter.hs +++ b/src/Puppet/Parser/PrettyPrinter.hs @@ -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 diff --git a/src/Puppet/Parser/Types.hs b/src/Puppet/Parser/Types.hs --- a/src/Puppet/Parser/Types.hs +++ b/src/Puppet/Parser/Types.hs @@ -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 diff --git a/src/Puppet/Runner.hs b/src/Puppet/Runner.hs --- a/src/Puppet/Runner.hs +++ b/src/Puppet/Runner.hs @@ -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 diff --git a/src/Puppet/Runner/Daemon.hs b/src/Puppet/Runner/Daemon.hs --- a/src/Puppet/Runner/Daemon.hs +++ b/src/Puppet/Runner/Daemon.hs @@ -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") diff --git a/src/Puppet/Runner/Daemon/FileParser.hs b/src/Puppet/Runner/Daemon/FileParser.hs --- a/src/Puppet/Runner/Daemon/FileParser.hs +++ b/src/Puppet/Runner/Daemon/FileParser.hs @@ -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))) diff --git a/src/Puppet/Runner/Daemon/OptionalTests.hs b/src/Puppet/Runner/Daemon/OptionalTests.hs --- a/src/Puppet/Runner/Daemon/OptionalTests.hs +++ b/src/Puppet/Runner/Daemon/OptionalTests.hs @@ -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) diff --git a/src/Puppet/Runner/Erb.hs b/src/Puppet/Runner/Erb.hs --- a/src/Puppet/Runner/Erb.hs +++ b/src/Puppet/Runner/Erb.hs @@ -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 diff --git a/src/Puppet/Runner/Erb/Evaluate.hs b/src/Puppet/Runner/Erb/Evaluate.hs --- a/src/Puppet/Runner/Erb/Evaluate.hs +++ b/src/Puppet/Runner/Erb/Evaluate.hs @@ -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) diff --git a/src/Puppet/Runner/Preferences.hs b/src/Puppet/Runner/Preferences.hs --- a/src/Puppet/Runner/Preferences.hs +++ b/src/Puppet/Runner/Preferences.hs @@ -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) diff --git a/src/Puppet/Runner/Puppetlabs.hs b/src/Puppet/Runner/Puppetlabs.hs --- a/src/Puppet/Runner/Puppetlabs.hs +++ b/src/Puppet/Runner/Puppetlabs.hs @@ -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 diff --git a/src/Puppet/Runner/Pure.hs b/src/Puppet/Runner/Pure.hs --- a/src/Puppet/Runner/Pure.hs +++ b/src/Puppet/Runner/Pure.hs @@ -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") + ] diff --git a/src/Puppet/Runner/Stats.hs b/src/Puppet/Runner/Stats.hs --- a/src/Puppet/Runner/Stats.hs +++ b/src/Puppet/Runner/Stats.hs @@ -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 diff --git a/src/Puppet/Runner/Stdlib.hs b/src/Puppet/Runner/Stdlib.hs --- a/src/Puppet/Runner/Stdlib.hs +++ b/src/Puppet/Runner/Stdlib.hs @@ -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)) diff --git a/src/PuppetDB.hs b/src/PuppetDB.hs --- a/src/PuppetDB.hs +++ b/src/PuppetDB.hs @@ -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 diff --git a/src/PuppetDB/Core.hs b/src/PuppetDB/Core.hs --- a/src/PuppetDB/Core.hs +++ b/src/PuppetDB/Core.hs @@ -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 () -- ^ - , replaceFacts :: [(NodeName, Facts)] -> ExceptT PrettyError m () -- ^ - , deactivateNode :: NodeName -> ExceptT PrettyError m () -- ^ - , getPDBFacts :: Query FactField -> ExceptT PrettyError m [FactInfo] -- ^ - , getResources :: Query ResourceField -> ExceptT PrettyError m [Resource] -- ^ - , getNodes :: Query NodeField -> ExceptT PrettyError m [NodeInfo] - , commitDB :: ExceptT PrettyError m () -- ^ This is only here to tell the test PuppetDB to save its content to disk. - , getResourcesOfNode :: NodeName -> Query ResourceField -> ExceptT PrettyError m [Resource] + { pdbInformation :: m Doc, + -- | + replaceCatalog :: WireCatalog -> ExceptT PrettyError m (), + -- | + replaceFacts :: [(NodeName, Facts)] -> ExceptT PrettyError m (), + -- | + deactivateNode :: NodeName -> ExceptT PrettyError m (), + -- | + getPDBFacts :: Query FactField -> ExceptT PrettyError m [FactInfo], + -- | + 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] } diff --git a/src/PuppetDB/Remote.hs b/src/PuppetDB/Remote.hs --- a/src/PuppetDB/Remote.hs +++ b/src/PuppetDB/Remote.hs @@ -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) diff --git a/src/PuppetDB/TestDB.hs b/src/PuppetDB/TestDB.hs --- a/src/PuppetDB/TestDB.hs +++ b/src/PuppetDB/TestDB.hs @@ -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" diff --git a/src/XPrelude.hs b/src/XPrelude.hs --- a/src/XPrelude.hs +++ b/src/XPrelude.hs @@ -1,11 +1,11 @@ -{-| -General specific prelude for language-puppet. -Customization of the with extra specific utilities. --} +-- | +-- General specific prelude for language-puppet. +-- Customization of the 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, ()) diff --git a/src/XPrelude/Extra.hs b/src/XPrelude/Extra.hs --- a/src/XPrelude/Extra.hs +++ b/src/XPrelude/Extra.hs @@ -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 diff --git a/src/XPrelude/PP.hs b/src/XPrelude/PP.hs --- a/src/XPrelude/PP.hs +++ b/src/XPrelude/PP.hs @@ -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 diff --git a/tests/ErbSpec.hs b/tests/ErbSpec.hs --- a/tests/ErbSpec.hs +++ b/tests/ErbSpec.hs @@ -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 diff --git a/tests/Helpers.hs b/tests/Helpers.hs --- a/tests/Helpers.hs +++ b/tests/Helpers.hs @@ -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)) "" diff --git a/tests/HieraSpec.hs b/tests/HieraSpec.hs --- a/tests/HieraSpec.hs +++ b/tests/HieraSpec.hs @@ -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" $ diff --git a/tests/Interpreter/ClassSpec.hs b/tests/Interpreter/ClassSpec.hs --- a/tests/Interpreter/ClassSpec.hs +++ b/tests/Interpreter/ClassSpec.hs @@ -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 diff --git a/tests/Interpreter/CollectorSpec.hs b/tests/Interpreter/CollectorSpec.hs --- a/tests/Interpreter/CollectorSpec.hs +++ b/tests/Interpreter/CollectorSpec.hs @@ -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}", + "}" + ] diff --git a/tests/Interpreter/EvalSpec.hs b/tests/Interpreter/EvalSpec.hs --- a/tests/Interpreter/EvalSpec.hs +++ b/tests/Interpreter/EvalSpec.hs @@ -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 diff --git a/tests/Interpreter/EvaluateStatementSpec.hs b/tests/Interpreter/EvaluateStatementSpec.hs --- a/tests/Interpreter/EvaluateStatementSpec.hs +++ b/tests/Interpreter/EvaluateStatementSpec.hs @@ -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" diff --git a/tests/Interpreter/Function/AssertPrivateSpec.hs b/tests/Interpreter/Function/AssertPrivateSpec.hs --- a/tests/Interpreter/Function/AssertPrivateSpec.hs +++ b/tests/Interpreter/Function/AssertPrivateSpec.hs @@ -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") diff --git a/tests/Interpreter/Function/DeleteAtSpec.hs b/tests/Interpreter/Function/DeleteAtSpec.hs --- a/tests/Interpreter/Function/DeleteAtSpec.hs +++ b/tests/Interpreter/Function/DeleteAtSpec.hs @@ -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] diff --git a/tests/Interpreter/Function/EachSpec.hs b/tests/Interpreter/Function/EachSpec.hs --- a/tests/Interpreter/Function/EachSpec.hs +++ b/tests/Interpreter/Function/EachSpec.hs @@ -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" diff --git a/tests/Interpreter/Function/JoinKeysToValuesSpec.hs b/tests/Interpreter/Function/JoinKeysToValuesSpec.hs --- a/tests/Interpreter/Function/JoinKeysToValuesSpec.hs +++ b/tests/Interpreter/Function/JoinKeysToValuesSpec.hs @@ -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"] diff --git a/tests/Interpreter/Function/LookupSpec.hs b/tests/Interpreter/Function/LookupSpec.hs --- a/tests/Interpreter/Function/LookupSpec.hs +++ b/tests/Interpreter/Function/LookupSpec.hs @@ -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) diff --git a/tests/Interpreter/Function/MergeSpec.hs b/tests/Interpreter/Function/MergeSpec.hs --- a/tests/Interpreter/Function/MergeSpec.hs +++ b/tests/Interpreter/Function/MergeSpec.hs @@ -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")])] diff --git a/tests/Interpreter/Function/PrefixSpec.hs b/tests/Interpreter/Function/PrefixSpec.hs --- a/tests/Interpreter/Function/PrefixSpec.hs +++ b/tests/Interpreter/Function/PrefixSpec.hs @@ -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)]) diff --git a/tests/Interpreter/Function/ShellquoteSpec.hs b/tests/Interpreter/Function/ShellquoteSpec.hs --- a/tests/Interpreter/Function/ShellquoteSpec.hs +++ b/tests/Interpreter/Function/ShellquoteSpec.hs @@ -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\"" diff --git a/tests/Interpreter/Function/SizeSpec.hs b/tests/Interpreter/Function/SizeSpec.hs --- a/tests/Interpreter/Function/SizeSpec.hs +++ b/tests/Interpreter/Function/SizeSpec.hs @@ -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 diff --git a/tests/Interpreter/Function/SprintfSpec.hs b/tests/Interpreter/Function/SprintfSpec.hs --- a/tests/Interpreter/Function/SprintfSpec.hs +++ b/tests/Interpreter/Function/SprintfSpec.hs @@ -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" ] "") + 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"] "") diff --git a/tests/Interpreter/Function/SuffixSpec.hs b/tests/Interpreter/Function/SuffixSpec.hs --- a/tests/Interpreter/Function/SuffixSpec.hs +++ b/tests/Interpreter/Function/SuffixSpec.hs @@ -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)]) diff --git a/tests/Interpreter/Function/WithSpec.hs b/tests/Interpreter/Function/WithSpec.hs --- a/tests/Interpreter/Function/WithSpec.hs +++ b/tests/Interpreter/Function/WithSpec.hs @@ -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") diff --git a/tests/Interpreter/IfSpec.hs b/tests/Interpreter/IfSpec.hs --- a/tests/Interpreter/IfSpec.hs +++ b/tests/Interpreter/IfSpec.hs @@ -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 ':(' }"] diff --git a/tests/Parser/DT.hs b/tests/Parser/DT.hs --- a/tests/Parser/DT.hs +++ b/tests/Parser/DT.hs @@ -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 diff --git a/tests/Parser/ExprSpec.hs b/tests/Parser/ExprSpec.hs --- a/tests/Parser/ExprSpec.hs +++ b/tests/Parser/ExprSpec.hs @@ -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 diff --git a/tests/Parser/LexerSpec.hs b/tests/Parser/LexerSpec.hs --- a/tests/Parser/LexerSpec.hs +++ b/tests/Parser/LexerSpec.hs @@ -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 diff --git a/tests/PuppetdbSpec.hs b/tests/PuppetdbSpec.hs --- a/tests/PuppetdbSpec.hs +++ b/tests/PuppetdbSpec.hs @@ -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"] diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -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