language-puppet 1.3.15 → 1.3.16
raw patch · 35 files changed
+728/−618 lines, 35 filesdep −HUnitdep −neat-interpolationdep ~ansi-wl-pprintdep ~basedep ~exceptions
Dependencies removed: HUnit, neat-interpolation
Dependency ranges changed: ansi-wl-pprint, base, exceptions, lens, megaparsec, mtl, protolude, scientific, strict-base-types, text, unix, unordered-containers, vector
Files
- CHANGELOG +6/−0
- language-puppet.cabal +32/−50
- src/Erb/Parser.hs +89/−89
- src/Erb/Ruby.hs +1/−0
- src/Puppet/Interpreter/IO.hs +2/−2
- src/Puppet/Interpreter/PrettyPrinter.hs +5/−5
- src/Puppet/Interpreter/Resolve.hs +19/−13
- src/Puppet/Interpreter/Types.hs +7/−2
- src/Puppet/Language/Core.hs +5/−2
- src/Puppet/Parser.hs +4/−1
- src/Puppet/Runner.hs +2/−0
- src/Puppet/Runner/Daemon.hs +1/−1
- src/Puppet/Runner/Erb.hs +105/−98
- src/Puppet/Runner/Erb/Evaluate.hs +56/−34
- src/Puppet/Runner/Preferences.hs +1/−1
- src/Puppet/Runner/Pure.hs +20/−13
- src/XPrelude/Extra.hs +9/−1
- tests/ErbSpec.hs +73/−0
- tests/EvalSpec.hs +44/−0
- tests/ExprSpec.hs +35/−0
- tests/HieraSpec.hs +77/−0
- tests/LexerSpec.hs +22/−0
- tests/PuppetdbSpec.hs +42/−0
- tests/Spec.hs +24/−12
- tests/erb.hs +0/−18
- tests/evals.hs +0/−52
- tests/expr.hs +0/−35
- tests/hiera.hs +0/−93
- tests/hiera/common.yaml +10/−0
- tests/hiera/hiera-v3.yaml +12/−0
- tests/hiera/hiera-v5.yaml +10/−0
- tests/hiera/node.com.json +6/−0
- tests/hiera/production.yaml +9/−0
- tests/lexer.hs +0/−52
- tests/puppetdb.hs +0/−44
CHANGELOG view
@@ -1,3 +1,9 @@+language-puppet (1.3.16) artful; urgency=medium+ [ PierreR ]+ * Fix #213 Hash lookup failing in erb template++ -- Simon Marechal <bartavelle@gmail.com> Thu, 01 Mar 2018 17:48:48 +0100+ language-puppet (1.3.15) artful; urgency=medium * Improve parsing error messages
language-puppet.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet-version: 1.3.15+version: 1.3.16 synopsis: Tools to parse and evaluate the Puppet DSL. description: This is a set of tools that is supposed to fill all your Puppet needs : syntax checks, catalog compilation, PuppetDB queries, simulationg of complex interactions between nodes, Puppet master replacement, and more ! homepage: http://lpuppet.banquise.net/@@ -22,6 +22,8 @@ CHANGELOG README.adoc HLint.hs+ tests/hiera/*.yaml+ tests/hiera/*.com.json Data-Files: ruby/hrubyerb.rb@@ -101,7 +103,7 @@ , containers == 0.5.* , cryptonite >= 0.6 , directory >= 1.2 && < 1.4- , exceptions >= 0.8 && < 0.9+ , exceptions >= 0.8 && < 0.10 , filecache >= 0.2.9 && < 0.4 , filepath >= 1.4 , formatting@@ -136,56 +138,34 @@ , unordered-containers == 0.2.* , vector >= 0.10 , yaml >= 0.8.8 && < 0.9-Test-Suite test-evals- hs-source-dirs: tests- type: exitcode-stdio-1.0- ghc-options: -Wall -rtsopts -threaded- extensions: OverloadedStrings- build-depends: language-puppet,base,text,lens,megaparsec,hspec,vector- main-is: evals.hs-Test-Suite test-lexer- hs-source-dirs: tests- type: exitcode-stdio-1.0- ghc-options: -Wall -rtsopts -threaded- extensions: OverloadedStrings- build-depends: language-puppet,base,Glob,text,megaparsec,vector,ansi-wl-pprint,unix- main-is: lexer.hs-Test-Suite test-expr- hs-source-dirs: tests- type: exitcode-stdio-1.0- ghc-options: -Wall -rtsopts -threaded- extensions: OverloadedStrings- build-depends: language-puppet,base,text,megaparsec,vector,ansi-wl-pprint, strict-base-types, hspec, hspec-megaparsec- main-is: expr.hs-Test-Suite test-hiera- hs-source-dirs: tests- type: exitcode-stdio-1.0- ghc-options: -Wall -rtsopts -threaded- extensions: OverloadedStrings, NoImplicitPrelude, FlexibleContexts- Other-Modules: Helpers- build-depends: language-puppet,base,hspec,temporary,strict-base-types,HUnit,lens,vector,unordered-containers,text,hslogger,neat-interpolation,protolude >=0.2,scientific,mtl- main-is: hiera.hs-Test-Suite test-puppetdb- hs-source-dirs: tests- type: exitcode-stdio-1.0- ghc-options: -Wall -rtsopts -threaded- extensions: OverloadedStrings- build-depends: language-puppet,base,temporary,strict-base-types,lens,text,transformers,mtl- main-is: puppetdb.hs-Test-Suite erbparser- hs-source-dirs: tests- type: exitcode-stdio-1.0- ghc-options: -Wall -rtsopts -threaded- extensions: OverloadedStrings- build-depends: language-puppet,base,strict-base-types,lens,text- main-is: erb.hs Test-Suite spec hs-source-dirs: tests type: exitcode-stdio-1.0 ghc-options: -Wall -Wno-missing-signatures -rtsopts -threaded- extensions: OverloadedStrings, NoImplicitPrelude, FlexibleContexts- build-depends: language-puppet,base,strict-base-types,lens,text,hspec,unordered-containers,megaparsec,vector,scientific,mtl,hspec-megaparsec, protolude >= 0.2- other-modules: Function.ShellquoteSpec+ extensions: OverloadedStrings, NoImplicitPrelude, FlexibleContexts, LambdaCase+ build-depends: base+ , Glob+ , hslogger+ , hspec+ , hspec-megaparsec+ , megaparsec+ , language-puppet+ , lens+ , mtl+ , scientific+ , protolude+ , strict-base-types+ , text+ , temporary+ , transformers+ , unordered-containers+ , vector+ other-modules: DT.Parser+ ErbSpec+ EvalSpec+ ExprSpec+ HieraSpec+ Function.ShellquoteSpec Function.SprintfSpec Function.SizeSpec Function.MergeSpec@@ -194,12 +174,14 @@ Function.AssertPrivateSpec Function.JoinKeysToValuesSpec Function.LookupSpec+ Helpers InterpreterSpec Interpreter.CollectorSpec Interpreter.IfSpec- DT.Parser- Helpers+ LexerSpec+ PuppetdbSpec main-is: Spec.hs+ executable puppetresources hs-source-dirs: progs
src/Erb/Parser.hs view
@@ -18,16 +18,16 @@ 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- }+ { 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,73 +60,73 @@ 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+term =+ parens rubyexpression+ <|> scopeLookup+ <|> stringLiteral+ <|> objectterm+ <|> variablereference scopeLookup :: Parser Expression scopeLookup = do- void $ try $ string "scope"- end <- (string ".lookupvar(" >> return (char ')')) <|> (char '[' >> return (char ']'))- expr <- rubyexpression- void end- return $ Object expr+ void $ try $ string "scope"+ end <- (string ".lookupvar(" >> return (char ')')) <|> (char '[' >> return (char ']'))+ expr <- rubyexpression+ void end+ pure $ ScopeObject expr stringLiteral :: Parser Expression stringLiteral = Value `fmap` (doubleQuoted <|> singleQuoted) doubleQuoted :: Parser Value doubleQuoted = Interpolable <$> between (char '"') (char '"') quoteInternal- where- quoteInternal = many (basicContent <|> interpvar <|> escaped)- escaped = char '\\' >> (Value . Literal . Text.singleton) `fmap` anyChar- basicContent = (Value . Literal . Text.pack) `fmap` many1 (noneOf "\"\\#")- interpvar = do- void $ try (string "#{")- o <- many1 (noneOf "}")- void $ char '}'- return (Object (Value (Literal (Text.pack o))))+ where+ quoteInternal = many (basicContent <|> interpvar <|> escaped)+ escaped = char '\\' >> (Value . Literal . Text.singleton) `fmap` anyChar+ basicContent = (Value . Literal . Text.pack) `fmap` many1 (noneOf "\"\\#")+ interpvar = do+ void $ try (string "#{")+ o <- many1 (noneOf "}")+ void $ char '}'+ return (Object (Value (Literal (Text.pack o)))) singleQuoted :: Parser Value singleQuoted = Literal . Text.pack <$> between (char '\'') (char '\'') (many $ noneOf "'") objectterm :: Parser Expression objectterm = do- void $ optional (char '@')- methodname' <- fmap Text.pack identifier- let methodname = Value (Literal methodname')- lookAhead anyChar >>= \case- '[' -> do- hr <- many (symbol "[" *> rubyexpression <* symbol "]")- return $! foldl LookupOperation (Object methodname) hr- '{' -> fmap (MethodCall methodname . BlockOperation . Text.pack) (braces (many1 $ noneOf "}"))- '(' -> fmap (MethodCall methodname . Value . Array) (parens (rubyexpression `sepBy` symbol ","))- _ -> return $ Object methodname+ arobase <- optional (char '@')+ methodname' <- toS <$> identifier+ let methodname = Value (Literal $ maybe methodname' (\a -> Text.cons a methodname') arobase)+ lookAhead anyChar >>= \case+ '[' -> do+ 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 variablereference :: Parser Expression variablereference = fmap (Object . Value . Literal . Text.pack) identifier@@ -136,36 +136,36 @@ textblockW :: Maybe Char -> Parser [RubyStatement] textblockW c = do- s <- many (noneOf "<")- let ns = case c of- Just x -> x:s- Nothing -> s- returned = Puts $ Value $ Literal $ Text.pack ns- optionMaybe eof >>= \case- Just _ -> return [returned]- Nothing -> do- void $ char '<'- n <- optionMaybe (char '%') >>= \case- Just _ -> rubyblock- Nothing -> textblockW (Just '<')- return (returned : n)+ s <- many (noneOf "<")+ let ns = case c of+ Just x -> x:s+ Nothing -> s+ returned = Puts $ Value $ Literal $ Text.pack ns+ optionMaybe eof >>= \case+ Just _ -> return [returned]+ Nothing -> do+ void $ char '<'+ n <- optionMaybe (char '%') >>= \case+ Just _ -> rubyblock+ Nothing -> textblockW (Just '<')+ pure (returned : n) textblock :: Parser [RubyStatement] textblock = textblockW Nothing rubyblock :: Parser [RubyStatement] rubyblock = do- ps <- option [] (char '-' >> return [DropPrevSpace'])- parsed <- optionMaybe (char '=') >>= \case- Just _ -> spaces >> fmap (return . Puts) rubyexpression- Nothing -> spaces >> many1 rubystatement- spaces- let dn (x:xs) = DropNextSpace x : xs- dn x = x- ns <- option identity (char '-' >> return dn)- void $ string "%>"- n <- textblock- return (ps ++ parsed ++ ns n)+ ps <- option [] (char '-' >> return [DropPrevSpace'])+ parsed <- optionMaybe (char '=') >>= \case+ Just _ -> spaces >> fmap (return . Puts) rubyexpression+ Nothing -> spaces >> many1 rubystatement+ spaces+ let dn (x:xs) = DropNextSpace x : xs+ dn x = x+ ns <- option identity (char '-' >> return dn)+ void $ string "%>"+ n <- textblock+ pure (ps <> parsed <> ns n) erbparser :: Parser [RubyStatement] erbparser = textblock@@ -174,9 +174,9 @@ parseErbFile fname = parseContent `catch` handler where- parseContent = (runParser erbparser () fname . Text.unpack) `fmap` readFile fname- handler e = let msg = show (e :: SomeException)- in return $ Left $ newErrorMessage (Message msg) (initialPos fname)+ parseContent = (runParser erbparser () fname . Text.unpack) `fmap` readFile fname+ handler e = let msg = show (e :: SomeException)+ in return $ Left $ newErrorMessage (Message msg) (initialPos fname) parseErbString :: String -> Either ParseError [RubyStatement]-parseErbString = runParser erbparser () "dummy"+parseErbString = runParser erbparser () mempty
src/Erb/Ruby.hs view
@@ -32,6 +32,7 @@ | NegOperation !Expression | ConditionalValue !Expression !Expression | Object !Expression+ | ScopeObject !Expression | MethodCall !Expression !Expression | BlockOperation !Text | Value !Value
src/Puppet/Interpreter/IO.hs view
@@ -55,7 +55,7 @@ Nothing -> thpe (PrettyError ("Unknown function: " <> ppline fname)) GetStatement topleveltype toplevelname -> canFail ((r ^. readerGetStatement) topleveltype toplevelname)- ComputeTemplate fn stt -> canFail ((r ^. readerGetTemplate) fn stt r)+ ComputeTemplate src st -> canFail ((r ^. readerGetTemplate) src st r) WriterTell t -> logStuff t (runInstr ()) WriterPass _ -> thpe "WriterPass" WriterListen _ -> thpe "WriterListen"@@ -87,7 +87,7 @@ Right x -> logStuff w (interpretMonad r s' (k x)) --- query hiera layers+-- query all hiera layers queryHiera :: Monad m => HieraQueryLayers m -> Container Text -> Text -> HieraQueryType -> m (S.Either PrettyError (Maybe PValue)) queryHiera layers scps q t = do val <- (layers^.globalLayer) scps q t
src/Puppet/Interpreter/PrettyPrinter.hs view
@@ -10,6 +10,10 @@ import Puppet.Interpreter.Types import PuppetDB +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"@@ -41,11 +45,7 @@ pretty IsStrict = pf "IsStrict" [] pretty GetNativeTypes = pf "GetNativeTypes" [] pretty (GetStatement tlt nm) = pf "GetStatement" [pretty tlt,ppline nm]- pretty (ComputeTemplate fn _) = pf "ComputeTemplate" [fn']- where- fn' = case fn of- Left content -> pretty (PString content)- Right filena -> ppline filena+ 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]
src/Puppet/Interpreter/Resolve.hs view
@@ -452,7 +452,10 @@ resolveFunction' "defined" x = throwPosError ("defined(): expects a single resource reference, type or class name, and not" <+> pretty x) resolveFunction' "fail" x = throwPosError ("fail:" <+> pretty x) resolveFunction' "inline_template" [] = throwPosError "inline_template(): Expects at least one argument"-resolveFunction' "inline_template" templates = PString . mconcat <$> mapM (calcTemplate Left) templates+resolveFunction' "inline_template" templates =+ let compute = fmap Inline . resolvePValueString >=> calcTemplate+ 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,8 +478,8 @@ src <- fmap Text.encodeUtf8 (resolvePValueString psrc) splt <- fmap Text.encodeUtf8 (resolvePValueString psplt) case Regex.splitCompile' splt src of- Left rr -> throwPosError ("splitCompile():" <+> ppstring rr)- Right x -> fmap (PArray . V.fromList) (mapM (fmap PString . safeDecodeUtf8) x)+ Left err -> throwPosError ("splitCompile():" <+> ppstring err)+ 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@@ -514,7 +517,10 @@ scpset <- use (scopes . ix scp . scopeExtraTags) pure (PBoolean (scpset `HS.intersection` tags == tags)) resolveFunction' "template" [] = throwPosError "template(): Expects at least one argument"-resolveFunction' "template" templates = PString . mconcat <$> mapM (calcTemplate Right) templates+resolveFunction' "template" templates =+ let compute = fmap (Filename . Text.unpack) . resolvePValueString >=> calcTemplate+ in+ PString . mconcat <$> traverse compute templates resolveFunction' "versioncmp" [pa,pb] = do a <- resolvePValueString pa b <- resolvePValueString pb@@ -547,10 +553,10 @@ resolveFunction' "hiera_hash" [q,d,o] = hieraCall QHash q (Just d) Nothing (Just o) resolveFunction' "lookup" [q] = hieraCall QFirst q Nothing Nothing Nothing resolveFunction' "lookup" [q, PType dt] = hieraCall QFirst q Nothing (Just dt) Nothing-resolveFunction' "lookup" [q, PType dt, PString t,d] =- case readQueryType t of- Nothing -> throwPosError ("Unknown merge strategy " <> ppline t)- Just qt -> hieraCall qt q (Just d) (Just dt) Nothing+resolveFunction' "lookup" [q, PType dt, PString qt, def] = do+ 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" -- user functions@@ -574,11 +580,11 @@ Nothing -> pure (PArray rv) (Just k) -> fmap PArray (V.mapM (extractSubHash k) rv) -calcTemplate :: (Text -> Either Text Text) -> PValue -> InterpreterMonad Text-calcTemplate templatetype templatename = do- fname <- resolvePValueString templatename- stt <- use identity- Operational.singleton (ComputeTemplate (templatetype fname) stt)++calcTemplate :: TemplateSource -> InterpreterMonad Text+calcTemplate templatetype = do+ intpstate <- use identity+ Operational.singleton (ComputeTemplate templatetype intpstate) resolveExpressionSE :: Expression -> InterpreterMonad PValue resolveExpressionSE e =
src/Puppet/Interpreter/Types.hs view
@@ -80,6 +80,8 @@ , HieraQueryLayers(..) , globalLayer , moduleLayer+ -- * Template+ , TemplateSource(..) -- * Re-export , module Puppet.Language ) where@@ -204,10 +206,13 @@ , _moduleLayer :: Container (HieraQueryFunc m) } +-- | Whether the template source is specified 'inline' or loaded from a file.+data TemplateSource= Inline Text | Filename FilePath+ data InterpreterReader m = InterpreterReader { _readerNativeTypes :: !(Container NativeTypeMethods) , _readerGetStatement :: TopLevelType -> Text -> m (S.Either PrettyError Statement)- , _readerGetTemplate :: Either Text Text -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError Text)+ , _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@@ -224,7 +229,7 @@ -- Utility for using what's in 'InterpreterReader' GetNativeTypes :: InterpreterInstr (Container NativeTypeMethods) GetStatement :: TopLevelType -> Text -> InterpreterInstr Statement- ComputeTemplate :: Either Text Text -> InterpreterState -> InterpreterInstr Text+ ComputeTemplate :: TemplateSource-> InterpreterState -> InterpreterInstr Text ExternalFunction :: Text -> [PValue] -> InterpreterInstr PValue GetNodeName :: InterpreterInstr Text HieraQuery :: Container Text -> Text -> HieraQueryType -> InterpreterInstr (Maybe PValue)
src/Puppet/Language/Core.hs view
@@ -12,13 +12,16 @@ import qualified GHC.Show as Show (Show (..)) import Text.Megaparsec.Pos - showPos :: Position -> Doc showPos = blue . pptext . sourcePosPretty --- | showing a position interval only show the first position+-- | showing the first position of a position interval. showPPos :: PPosition -> Doc showPPos = showPos . Tuple.fst++-- | showing the first position of a position interval as string.+showPPos' :: PPosition -> String+showPPos' = sourcePosPretty . Tuple.fst -- | Generates an initial position interval based on a filename. initialPPos :: FilePath -> PPosition
src/Puppet/Parser.hs view
@@ -728,7 +728,10 @@ <|> reserved "Stdlib::Absolutepath" $> UDTData <|> reserved "Stdlib::Unixpath" $> UDTData <|> reserved "Nginx::ErrorLogSeverity" $> UDTData-+ <|> reserved "Jenkins::Tunnel" $> UDTData+ <|> reserved "Systemd::Unit" $> UDTData+ <|> reserved "Systemd::ServiceLimits" $> UDTData+ <|> reserved "Systemd::Dropin" $> UDTData statementList :: Parser (Vector Statement) statementList = (V.fromList . concat) <$> many statement
src/Puppet/Runner.hs view
@@ -19,6 +19,7 @@ -- * Daemon , module Puppet.Runner.Daemon -- * Re-export+ , module Puppet.Runner.Erb.Evaluate , module Puppet.Interpreter ) where@@ -28,4 +29,5 @@ import Puppet.Runner.Stats import Puppet.Runner.Stdlib import Puppet.Runner.Pure+import Puppet.Runner.Erb.Evaluate import Puppet.Interpreter
src/Puppet/Runner/Daemon.hs view
@@ -85,7 +85,7 @@ getCatalog' :: Preferences IO -> ( TopLevelType -> Text -> IO (S.Either PrettyError Statement) )- -> (Either Text Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text))+ -> (TemplateSource -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text)) -> MStats -> HieraQueryLayers IO -> NodeName
src/Puppet/Runner/Erb.hs view
@@ -11,9 +11,10 @@ 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 V+import qualified Data.Vector as Vector import Debug.Trace import Foreign.Ruby import qualified Foreign.Ruby.Bindings as FR@@ -36,12 +37,13 @@ import Puppet.Runner.Preferences import Puppet.Runner.Stats + instance IsString TemplateParseError where- fromString s = TemplateParseError $ newErrorMessage (Message s) (initialPos "dummy")+ fromString s = TemplateParseError $ newErrorMessage (Message s) (initialPos mempty) newtype TemplateParseError = TemplateParseError { tgetError :: ParseError } -type TemplateQuery = (Chan TemplateAnswer, Either Text Text, InterpreterState, InterpreterReader IO)+type TemplateQuery = (Chan TemplateAnswer, TemplateSource, InterpreterState, InterpreterReader IO) type TemplateAnswer = S.Either PrettyError Text showRubyError :: RubyError -> PrettyError@@ -50,98 +52,102 @@ 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 (Either Text Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text))-initTemplateDaemon intr prefs mvstats = do- controlchan <- newChan- templatecache <- Cache.newFileCache- let returnError rs = return $ \_ _ _ -> return (S.Left (showRubyError rs))- x <- runExceptT $ do- liftIO (getRubyScriptPath "hrubyerb.rb") >>= ExceptT . loadFile intr- ExceptT (registerGlobalFunction4 intr "varlookup" hrresolveVariable)- ExceptT (registerGlobalFunction5 intr "callextfunc" hrcallfunction)- liftIO $ void $ forkIO $ templateDaemon intr- (Text.pack (prefs ^. prefPuppetPaths.modulesPath))- (Text.pack (prefs ^. prefPuppetPaths.templatesPath))- controlchan- mvstats- templatecache- pure $! templateQuery controlchan- either returnError return x+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+ let returnError rs = return $ \_ _ _ -> pure (S.Left (showRubyError rs))+ x <- runExceptT $ do+ 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+ pure $! templateQuery controlchan+ either returnError pure x -templateQuery :: Chan TemplateQuery -> Either Text Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text)-templateQuery qchan filename stt rdr = do+templateQuery :: Chan TemplateQuery -> TemplateSource -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text)+templateQuery qchan filename intpstate intpreader = do rchan <- newChan- writeChan qchan (rchan, filename, stt, rdr)+ writeChan qchan (rchan, filename, intpstate, intpreader) readChan rchan -templateDaemon :: RubyInterpreter -> Text -> Text -> Chan TemplateQuery -> MStats -> Cache.FileCacheR TemplateParseError [RubyStatement] -> IO ()-templateDaemon intr modpath templatepath qchan mvstats filecache = do+templateDaemon :: RubyInterpreter -> FilePath -> FilePath -> Chan TemplateQuery -> MStats -> Cache.FileCacheR TemplateParseError [RubyStatement] -> IO ()+templateDaemon rubyintp modpath templatepath qchan mvstats filecache = do let nameThread :: String -> IO () nameThread n = myThreadId >>= flip labelThread n nameThread "RubyTemplateDaemon"- (respchan, fileinfo, stt, rdr) <- readChan qchan+ (respchan, fileinfo, intpstate, intpreader) <- readChan qchan case fileinfo of- Right filename -> do- let prts = Text.splitOn "/" filename- searchpathes | length prts > 1 = [modpath <> "/" <> List.head prts <> "/templates/" <> Text.intercalate "/" (List.tail prts), templatepath <> "/" <> filename]- | otherwise = [templatepath <> "/" <> filename]- acceptablefiles <- filterM (fileExist . Text.unpack) searchpathes+ 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]+ acceptablefiles <- filterM fileExist searchpathes if null acceptablefiles- then writeChan respchan (S.Left $ PrettyError $ "Can't find template file for" <+> ppline filename <+> ", looked in" <+> list (map ppline searchpathes))- else measure mvstats filename (computeTemplate intr (Right (List.head acceptablefiles)) stt rdr mvstats filecache) >>= writeChan respchan- Left _ -> measure mvstats "inline" (computeTemplate intr fileinfo stt rdr mvstats filecache) >>= writeChan respchan- templateDaemon intr modpath templatepath qchan mvstats filecache+ then writeChan respchan (S.Left $ PrettyError $ "Can't find template file for" <+> pptext filename <+> ", looked in" <+> list (map pptext searchpathes))+ else measure mvstats (toS filename) (computeTemplate rubyintp (Filename (List.head acceptablefiles)) intpstate intpreader mvstats filecache) >>= writeChan respchan+ Inline _ -> measure mvstats "inline" (computeTemplate rubyintp fileinfo intpstate intpreader mvstats filecache) >>= writeChan respchan+ templateDaemon rubyintp modpath templatepath qchan mvstats filecache -computeTemplate :: RubyInterpreter -> Either Text Text -> InterpreterState -> InterpreterReader IO -> MStats -> Cache.FileCacheR TemplateParseError [RubyStatement] -> IO TemplateAnswer-computeTemplate intr fileinfo stt rdr mstats filecache = do- let (curcontext, fvariables) = case extractFromState stt of- Nothing -> (mempty, mempty)- Just (c,v) -> (c,v)- let (filename, ufilename) = case fileinfo of- Left _ -> ("inline", "inline")- Right x -> (x, Text.unpack x)- mkSafe a = makeSafe intr a >>= \case- Left rr -> return (S.Left (showRubyError rr))+computeTemplate :: RubyInterpreter -> TemplateSource -> InterpreterState -> InterpreterReader IO -> MStats -> Cache.FileCacheR TemplateParseError [RubyStatement] -> IO TemplateAnswer+computeTemplate rubyintp srcinfo intpstate intpreader mstats filecache = do+ let (curcontext, fvariables) =+ case extractFromState intpstate of+ 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 encapsulateError = _Left %~ TemplateParseError variables = fvariables & traverse . scopeVariables . traverse . _1 . _1 %~ toStr toStr (PNumber n) = PString (scientific2text n) toStr x = x- traceEventIO ("START template " ++ Text.unpack filename)- parsed <- case fileinfo of- Right _ -> measure mstats ("parsing - " <> filename) $ Cache.lazyQuery filecache ufilename $ fmap encapsulateError (parseErbFile ufilename)- Left content -> measure mstats ("parsing - " <> filename) $ return $ encapsulateError (runParser erbparser () "inline" (Text.unpack content))+ 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)+ Inline s -> measure mstats ("parsing - " <> toS template_src) $ pure $ encapsulateError (runParser erbparser () "inline" (toS s)) o <- case parsed of+ Left err -> do+ let !msg = "Template '" <> template_src <> "' could not be parsed " <> show (tgetError err)+ -- if the haskell parser fails the ruby one will fallback.+ logInfoStr msg+ measure mstats ("ruby - " <> toS template_src) $ mkSafe $ computeTemplateWRuby srcinfo curcontext variables intpstate intpreader+ Right ast -> case rubyEvaluate variables curcontext ast of+ Right ev -> pure (S.Right ev) Left err -> do- let msg = "Template '" <> toS ufilename <> "' could not be parsed " <> show (tgetError err)- logDebug msg- measure mstats ("ruby - " <> filename) $ mkSafe $ computeTemplateWRuby fileinfo curcontext variables stt rdr- Right ast -> case rubyEvaluate variables curcontext ast of- Right ev -> return (S.Right ev)- Left err -> do- let !msg = "Template '" <> toS ufilename <> "' evaluation failed with: " <> show err- logDebug msg- measure mstats ("ruby efail - " <> filename) $ mkSafe $ computeTemplateWRuby fileinfo curcontext variables stt rdr- traceEventIO ("STOP template " ++ Text.unpack filename)- return o+ 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.+ logCriticalStr msg+ measure mstats ("ruby efail - " <> toS template_src) $ mkSafe $ computeTemplateWRuby srcinfo curcontext variables intpstate intpreader+ traceEventIO ("STOP template " <> template_src)+ pure o getRubyScriptPath :: String -> IO String getRubyScriptPath rubybin = do let checkpath :: FilePath -> IO FilePath -> IO FilePath checkpath fp nxt = do- e <- fileExist fp- if e- then return fp- else nxt+ ifM (fileExist fp)+ (pure fp)+ nxt withExecutablePath = do- path <- fmap takeDirectory getExecutablePath- let fullpath = path </> rubybin- checkpath fullpath $ checkpath ("/usr/local/bin/" <> rubybin) (return rubybin)+ path <- fmap takeDirectory getExecutablePath+ let fullpath = path </> rubybin+ checkpath fullpath $ checkpath ("/usr/local/bin/" <> rubybin) (pure rubybin) cabalPath <- getDataFileName $ "ruby/" ++ rubybin :: IO FilePath checkpath cabalPath withExecutablePath --- This must be called from the proper thread. As this is callback, this--- should be ok.+-- This must be called from the proper thread. As this is callback, this should be ok. hrresolveVariable :: RValue -> RValue -> RValue -> RValue -> IO RValue -- Text -> Container PValue -> RValue -> RValue -> IO RValue hrresolveVariable _ rscp rvariables rtoresolve = do@@ -154,7 +160,7 @@ vars = getvars "::" <> getvars scope in Right (PHash vars) Right t -> getVariable variables scope t- Left rr -> Left ("The variable name is not a string" <+> pptext rr)+ Left err -> Left ("The variable name is not a string" <+> pptext err) case answer of Left _ -> getSymbol "undef" Right r -> FR.toRuby r@@ -165,25 +171,25 @@ eargs <- FR.fromRuby rargs rdr <- FR.extractHaskellValue rrdr stt <- FR.extractHaskellValue rstt- let err :: String -> IO RValue- err rr = fmap (either snd identity) (FR.toRuby (Text.pack rr) >>= FR.safeMethodCall "MyError" "new" . (:[]))+ let rubyerr :: String -> IO RValue+ 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 logError $ "Can't parse a call to the external ruby function '" <> fname <> "' n an erb file.\n\tIt is not possible to call it from a Ruby function. It would stall (yes it sucks ...).\n\tChoosing to output \"undef\" !" getSymbol "undef" | otherwise -> do let args = case varray of- [PArray vargs] -> V.toList vargs+ [PArray vargs] -> Vector.toList vargs _ -> varray (x,_,_) <- interpretMonad rdr stt (resolveFunction' fname args) case x of Right o -> case o ^? _Number of Just n -> FR.toRuby n Nothing -> FR.toRuby o- Left rr -> err (show rr)- Left rr -> err rr+ Left err -> rubyerr (show err)+ Left err -> rubyerr err -computeTemplateWRuby :: Either Text Text -> Text -> Container ScopeInformation -> InterpreterState -> InterpreterReader IO -> IO TemplateAnswer+computeTemplateWRuby :: TemplateSource -> Text -> Container ScopeInformation -> InterpreterState -> InterpreterReader IO -> IO TemplateAnswer computeTemplateWRuby fileinfo curcontext variables stt rdr = FR.freezeGC $ eitherDocIO $ do rscp <- FR.embedHaskellValue curcontext rvariables <- FR.embedHaskellValue variables@@ -192,37 +198,38 @@ let varlist = variables ^. ix curcontext . scopeVariables -- must be called from a "makeSafe" thingie contentinfo <- case fileinfo of- Right fname -> FR.toRuby fname- Left _ -> FR.toRuby ("-" :: Text)+ Filename fname -> FR.toRuby (Text.pack fname)+ Inline _ -> FR.toRuby ("-" :: Text) let withBinding f = do- erbBinding <- FR.safeMethodCall "ErbBinding" "new" [rscp,rvariables,rstt,rrdr,contentinfo]- case erbBinding of- Left x -> return (Left x)- Right v -> do- forM_ (itoList varlist) $ \(varname, varval :!: _ :!: _) -> FR.toRuby varval >>= FR.rb_iv_set v (Text.unpack varname)- f v+ 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 o <- case fileinfo of- Right fname -> do- rfname <- FR.toRuby fname- withBinding $ \v -> FR.safeMethodCall "Controller" "runFromFile" [rfname,v]- Left content -> withBinding $ \v -> FR.toRuby content >>= FR.safeMethodCall "Controller" "runFromContent" . (:[v])+ 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]) FR.freeHaskellValue rrdr FR.freeHaskellValue rstt FR.freeHaskellValue rvariables FR.freeHaskellValue rscp case o of- Left (rr, _) ->- let fname = case fileinfo of- Right f -> Text.unpack f- Left _ -> "inline_template"- in return (S.Left $ PrettyError (dullred (pptext rr) <+> "in" <+> dullgreen (pptext fname)))+ Left (err, _) ->+ pure (S.Left $ PrettyError (dullred (pptext err) <+> "in" <+> dullgreen (pptext (templateSrc fileinfo)))) Right r -> FR.fromRuby r >>= \case- Right result -> return (S.Right result)- Left rr -> return (S.Left $ PrettyError ("Could not deserialiaze ruby output" <+> pptext rr))+ 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 -> return $ S.Left $ PrettyError $ dullred $ ppline $ show (e :: SomeException))+ (computation >>= check) `catch` (\e -> pure $ S.Left $ PrettyError $ dullred $ ppline $ show (e :: SomeException)) where- check (S.Left r) = return (S.Left r)- check (S.Right x) = return (S.Right x)+ check (S.Left r) = pure (S.Left r)+ check (S.Right x) = pure (S.Right x)++templateSrc :: TemplateSource -> String+templateSrc = \case+ Inline _ -> "inline_template"+ Filename n -> n
src/Puppet/Runner/Erb/Evaluate.hs view
@@ -6,24 +6,31 @@ import XPrelude import Data.Aeson.Lens-import qualified Data.Char as Char-import qualified Data.Text as Text-import qualified Data.Vector as V+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 -rubyEvaluate :: Container ScopeInformation -> Text -> [RubyStatement] -> Either Doc Text+type ScopeName = Text++-- | Evaluate a list of ruby statements.+rubyEvaluate :: Container ScopeInformation+ -> ScopeName+ -> [RubyStatement]+ -> Either Doc Text rubyEvaluate vars ctx = foldl (evalruby vars ctx) (Right "") . optimize- where- optimize [] = []- optimize (Puts x : DropPrevSpace' : xs) = optimize $ DropPrevSpace (Puts x) : xs- optimize (x:xs) = x : optimize xs+ where+ optimize [] = []+ optimize (Puts x : DropPrevSpace' : xs) = optimize $ DropPrevSpace (Puts x) : xs+ optimize (x:xs) = x : optimize xs spaceNotCR :: Char -> Bool spaceNotCR c = Char.isSpace c && c /= '\n' && c /= '\r' -evalruby :: Container ScopeInformation -> Text -> Either Doc Text -> RubyStatement -> Either Doc Text+evalruby :: 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 mp ctx (Right curstr) (DropNextSpace x) =@@ -34,35 +41,50 @@ case evalruby mp ctx (Right curstr) x of Left err -> Left err Right y -> Right (Text.dropWhileEnd spaceNotCR y)-evalruby mp ctx (Right curstr) (Puts e) = case evalExpression mp ctx e of+evalruby mp ctx (Right curstr) (Puts e) =+ case (evalExpression mp ctx e >>= evalValue) of Left err -> Left err Right ex -> Right (curstr <> ex) -evalExpression :: Container ScopeInformation -> Text -> Expression -> Either Doc Text-evalExpression mp ctx (LookupOperation varname varindex) = do- rvname <- evalExpression mp ctx varname- rvindx <- evalExpression mp ctx varindex- getVariable mp ctx rvname >>= \case+evalExpression :: Container ScopeInformation -> ScopeName -> Expression -> Either Doc PValue+evalExpression mp ctx (LookupOperation expvar expidx) = do+ val <- evalExpression mp ctx expvar+ idx <- evalExpression mp ctx expidx+ case val of PArray arr ->- case a2i rvindx of- Nothing -> Left $ "Can't convert index to integer when resolving" <+> ppline rvname <> brackets (ppline rvindx)- Just i -> if fromIntegral (V.length arr) <= i- then Left $ "Array out of bound" <+> ppline rvname <> brackets (ppline rvindx)- else evalValue (arr V.! fromIntegral i)- PHash hs -> case hs ^. at rvindx of- Just x -> evalValue x- _ -> Left $ "Can't index variable" <+> ppline rvname <+> ", it is " <+> pretty (PHash hs)- varvalue -> Left $ "Can't index variable" <+> ppline rvname <+> ", it is " <+> pretty varvalue-evalExpression _ _ (Value (Literal x)) = Right x-evalExpression mp ctx (Object (Value (Literal x))) = getVariable mp ctx x >>= evalValue+ case idx ^? _Integer of+ Nothing -> Left $ "Can't convert index to integer when resolving" <+> pretty val <> brackets (pretty idx)+ 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))+ PHash hs ->+ case idx of+ PString idx' ->+ case hs ^. at idx' of+ Just x' -> Right x'+ _ -> 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 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 evalValue :: PValue -> Either Doc Text-evalValue (PString x) = Right x-evalValue (PNumber x) = Right (scientific2text x)-evalValue x = Right $ show x--a2i :: Text -> Maybe Integer-a2i x = case text2Scientific x of- Just y -> y ^? _Integer- _ -> Nothing+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"+ 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)
src/Puppet/Runner/Preferences.hs view
@@ -51,7 +51,7 @@ , _prefKnownusers :: [Text] , _prefKnowngroups :: [Text] , _prefExternalmodules :: HS.HashSet Text- , _prefPuppetSettings :: Container Text+ , _prefPuppetSettings :: Container Text -- ^ Puppet server settings , _prefFactsOverride :: Container PValue , _prefFactsDefault :: Container PValue , _prefLogLevel :: LOG.Priority
src/Puppet/Runner/Pure.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedLists #-} -- | Publicly exposed pure helpers to evaluate the 'InterpreterMonad' -- functions that can be found in "Puppet.Interpreter" and -- "Puppet.Interpreter.Resolve".@@ -26,9 +27,9 @@ import PuppetDB (dummyPuppetDB) -dummyTemplate :: Monad m => Either Text Text -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError Text)-dummyTemplate (Right _) _ _ = return (S.Left "Can't interpret files")-dummyTemplate (Left cnt) s _ =+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 extractFromState s of Nothing -> S.Left "Context retrieval error (pureReader)" Just (ctx, scope) ->@@ -135,18 +136,24 @@ , ("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")- , ("physicalprocessorcount", "1")- , ("processor0", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")- , ("processor1", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")- , ("processor2", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")- , ("processor3", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")- , ("processor4", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")- , ("processor5", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")- , ("processor6", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")- , ("processor7", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")- , ("processorcount", "8")+ , ("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")
src/XPrelude/Extra.hs view
@@ -17,12 +17,14 @@ -- * Logger , loggerName , logDebug+ , logDebugStr , logInfo , logInfoStr , logWarning , logWarningStr , logError- , logDebugStr+ , logCritical+ , logCriticalStr ) where import Protolude as Exports hiding (Down, Infix, Prefix, Selector,@@ -170,6 +172,12 @@ logError :: Text -> IO () logError = Log.errorM "language-puppet" . toS++logCritical :: Text -> IO ()+logCritical = Log.criticalM "language-puppet" . toS++logCriticalStr :: String -> IO ()+logCriticalStr = Log.criticalM "language-puppet" logDebugStr :: String -> IO () logDebugStr = Log.debugM "language-puppet"
+ tests/ErbSpec.hs view
@@ -0,0 +1,73 @@+module ErbSpec(spec) where++import XPrelude++import Test.Hspec++import Erb+import Puppet.Runner++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 ""))])+ ]++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"+ )+ ]+ 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++resolvespec =+ let state0 = initialState dummyFacts mempty+ Just (scope_name, scope) = extractFromState 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++spec = describe "Erb" $ do+ parsingspec+ resolvespec
+ tests/EvalSpec.hs view
@@ -0,0 +1,44 @@+module EvalSpec (spec) where+++import Test.Hspec+import Text.Megaparsec (eof, parse)++import Puppet.Interpreter+import Puppet.Parser+import Puppet.Runner+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"+ , "$architecture == 'amd64'"+ , "$facts['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++check :: Text -> Either String Bool+check t =+ case parse (expression <* eof) "dummy" t of+ Left _ -> Left $ "Parsing error: are you sure the evaluation is correct ?"+ Right e -> case dummyEval (resolveExpression e) of+ Right (PBoolean True) -> Right True+ _ -> Right False++spec = do+ describe "Evaluation of expressions" $ mapM_ testEvaluation evaluations
+ tests/ExprSpec.hs view
@@ -0,0 +1,35 @@+module ExprSpec (spec) where++import qualified Data.Vector as Vector+import Test.Hspec+import Test.Hspec.Megaparsec+import Text.Megaparsec++import Puppet.Parser+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" (Vector.singleton "foo::bar") ))+ , ("$y ? {\+ \ undef => 'undef',\+ \ default => 'default',\+ \ }", ConditionalValue (Terminal (UVariableReference "y"))+ (Vector.fromList [SelectorValue UUndef :!: Terminal (UString "undef")+ ,SelectorDefault :!: Terminal (UString "default")]))+ , ("$x", Terminal (UVariableReference "x"))+ , ("x($y)", Terminal (UFunctionCall "x" (Vector.singleton (Terminal (UVariableReference "y")))))+ , ("\"${x}\"", Terminal (UInterpolable (Vector.fromList [Terminal (UVariableReference "x")])))+ , ("\"${x[3]}\"", Terminal (UInterpolable (Vector.fromList [Lookup (Terminal (UVariableReference "x")) 3])))+ , ("\"${x[$y]}\"", Terminal (UInterpolable (Vector.fromList [Lookup (Terminal (UVariableReference "x")) (Terminal (UVariableReference "y")) ])))+ , ("\"${x($y)}\"", Terminal (UInterpolable (Vector.fromList [ Terminal (UFunctionCall "x" (Vector.singleton (Terminal (UVariableReference "y")))) ])))+ , ("\"${x($y)}$'\"", Terminal (UInterpolable (Vector.fromList [ Terminal (UFunctionCall "x" (Vector.singleton (Terminal (UVariableReference "y")))),Terminal (UString "$"),Terminal (UString "'")])))+ ]+++testExpression (t,e) = it ("should parse " ++ show t) $ parse (expression <* eof) "" t `shouldParse` e++spec = do+ describe "Expression parser" $ mapM_ testExpression expressions
+ tests/HieraSpec.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE QuasiQuotes #-}+module HieraSpec(spec) where++import XPrelude++import qualified Data.Either.Strict as S+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++checkOutput v (S.Right x) = x `shouldBe` v+checkOutput _ (S.Left rr) = expectationFailure (show rr)++fqdn = "node.com"+config_v3 = "./tests/hiera/hiera-v3.yaml"+config_v5 = "./tests/hiera/hiera-v5.yaml"++vars = HM.fromList [ ("::environment", "production")+ , ("::fqdn" , fqdn)+ ]+users = HM.fromList [ ("pete", PHash (HM.singleton "uid" (PNumber 2000)))+ , ("tom" , PHash (HM.singleton "uid" (PNumber 2001)))+ ]+pusers = HM.fromList [ ("bob", PHash (HM.singleton "uid" (PNumber 100)))+ , ("tom" , PHash (HM.singleton "uid" (PNumber 12)))+ ]++spec = do+ runIO $ Log.updateGlobalLogger loggerName (Log.setLevel Log.WARNING)+ q3 <- runIO $ startHiera config_v3+ q5 <- runIO $ startHiera config_v5+ describe "Hiera" $ do+ describe "v5 lookup hierarchy" $ do+ it "should override some values" $ do+ q5 vars "http_port" QFirst >>= checkOutput (Just (PNumber 9090))+ q5 vars "global" QFirst >>= checkOutput (Just "glob")+ describe "v3 lookup with no context variables" $ do+ it "should return nothing when called with an empty string" $+ q3 mempty "" QFirst >>= checkOutput Nothing+ it "should return nothing when called with a non existent key [First merge]" $+ q3 mempty "foo" QFirst >>= checkOutput Nothing+ it "should return nothing when called with a non existent key [Unique merge]" $+ q3 mempty "foo" QUnique >>= checkOutput Nothing+ it "should return nothing when called with a non existent key [Hash merge]" $+ q3 mempty "foo" QHash >>= checkOutput Nothing+ 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 (PArray (Vector.fromList ["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+ it "should override value" $+ q3 vars "http_port" QFirst >>= checkOutput (Just (PNumber 9090))+ it "should find common value" $+ q3 vars "global" QFirst >>= checkOutput (Just "glob")+ describe "v3 json backend" $+ it "resolves in json" $+ q3 vars "testjson" QFirst >>= checkOutput (Just "ok")+ describe "v3 deep interpolation" $ do+ it "resolves in strings" $+ q3 vars "interp1" QFirst >>= checkOutput (Just (PString ("**" <> fqdn <> "**")))+ it "resolves in objects" $+ q3 vars "testnode" QFirst >>= checkOutput (Just (PHash (HM.fromList [("1",PString ("**" <> fqdn <> "**")),("2",PString "nothing special")])))+ it "resolves in arrays" $+ q3 vars "arraytest" QFirst >>= checkOutput (Just (PArray (Vector.fromList [PString "a", PString fqdn, PString "c"])))+ describe "v3 other merge modes" $ do+ it "catenates arrays" $+ q3 vars "ntp_servers" QUnique >>= checkOutput (Just (PArray (Vector.fromList ["2.ntp.puppetlabs.com","3.ntp.puppetlabs.com","0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])))+ it "puts single values in arrays" $+ q3 vars "http_port" QUnique >>= checkOutput (Just (PArray (Vector.fromList [PNumber 9090, PNumber 8080])))+ it "merges hashes" $+ q3 vars "users" QHash >>= checkOutput (Just (PHash (pusers <> users)))
+ tests/LexerSpec.hs view
@@ -0,0 +1,22 @@+module LexerSpec(spec) where++import System.FilePath.Glob+import Test.Hspec+import Text.Megaparsec (eof, parse)+import Test.Hspec.Megaparsec+import XPrelude++import Puppet.Parser++alltests = do+ files <- runIO $ globDir1 (compile "*.pp") "tests/lexer"+ mapM_ test files++ where+ test fp = do+ r <- runIO $ fmap check (readFile fp)+ it ("should parse " <> fp) r+ check i =+ parse (puppetParser <* eof) empty `shouldSucceedOn` i++spec = describe "Lexer" $ alltests
+ tests/PuppetdbSpec.hs view
@@ -0,0 +1,42 @@+module PuppetdbSpec(spec) where++import XPrelude++import qualified Data.Text as Text+import System.IO.Temp as Temp+import Test.Hspec++import PuppetDB++checkPanicE :: Show x => Text -> ExceptT x IO a -> IO a+checkPanicE msg = runExceptT >=> either (panic . ((msg <> " ") <>) . show) return++fqdn = "node.site.com"++spec :: SpecWith ()+spec =+ around (Temp.withSystemTempDirectory "puppetdbtest") $ do+ describe "PuppetDB" $ do+ it "should save facts" $ \tmpfp -> do+ let pdbfile = tmpfp <> "/puppetdb.yaml"+ -- generate an empty puppetdb+ pdb <- loadTestDB pdbfile >>= unwrapError "While loading a test DB"+ -- get some dummy facts+ facts <- puppetDBFacts fqdn pdb+ -- and add a custom fact+ let nfacts = facts & at "customfact" ?~ "MyCustomFactValue"+ -- save the facts+ 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 `shouldContain` ["customfact: MyCustomFactValue"]+ -- initiate a new puppetdbapi+ fpdb <- loadTestDB pdbfile >>= unwrapError "loadTestDB"+ ffacts <- puppetDBFacts fqdn pdb+ ffacts `shouldBe` nfacts+ 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 `shouldContain` ["customfact: MyCustomFactValue"]
tests/Spec.hs view
@@ -1,20 +1,26 @@-import Test.Hspec+import Test.Hspec -import Helpers+import Helpers -import qualified InterpreterSpec-import qualified Interpreter.CollectorSpec-import qualified Function.ShellquoteSpec-import qualified Function.SizeSpec-import qualified Function.MergeSpec-import qualified Function.EachSpec+import qualified DT.Parser+import qualified ErbSpec+import qualified EvalSpec+import qualified ExprSpec import qualified Function.AssertPrivateSpec-import qualified Function.JoinKeysToValuesSpec import qualified Function.DeleteAtSpec-import qualified Interpreter.IfSpec-import qualified Function.SprintfSpec+import qualified Function.EachSpec+import qualified Function.JoinKeysToValuesSpec import qualified Function.LookupSpec-import qualified DT.Parser+import qualified Function.MergeSpec+import qualified Function.ShellquoteSpec+import qualified Function.SizeSpec+import qualified Function.SprintfSpec+import qualified Interpreter.CollectorSpec+import qualified Interpreter.IfSpec+import qualified InterpreterSpec+import qualified LexerSpec+import qualified PuppetdbSpec+import qualified HieraSpec main :: IO () main = hspec spec@@ -23,6 +29,10 @@ spec = do describe "Data types" $ do describe "Parser" DT.Parser.spec+ EvalSpec.spec+ ExprSpec.spec+ ErbSpec.spec+ LexerSpec.spec describe "Interpreter" $ do describe "Collector" InterpreterSpec.collectorSpec describe "Class include" InterpreterSpec.classIncludeSpec@@ -39,3 +49,5 @@ describe "The merge function" Function.MergeSpec.spec describe "The size function" Function.SizeSpec.spec describe "The delete_at function" Function.DeleteAtSpec.spec+ PuppetdbSpec.spec+ HieraSpec.spec
− tests/erb.hs
@@ -1,18 +0,0 @@-module Main where--import System.Environment-import Erb-import Control.Monad (when)--checkParse :: FilePath -> IO (Maybe [RubyStatement])-checkParse fp = parseErbFile fp >>= \c ->- case c of- Left rr -> print rr >> return Nothing- Right x -> return (Just x)--main :: IO ()-main = do- a <- getArgs- r <- mapM checkParse a- putStrLn (show (length $ filter (/= Nothing) r) ++ "/" ++ show (length a) ++ " files parsed")- when (length a == 1) (mapM_ print r)
− tests/evals.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Main where--import XPrelude--import qualified Data.Text as T--import Data.Foldable (forM_)-import Test.Hspec-import Text.Megaparsec (eof, parse)--import Puppet.Interpreter-import Puppet.Runner-import Puppet.Parser--pureTests :: [T.Text]-pureTests = [ "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"- , "$architecture == 'amd64'"- , "$facts['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'"- ]--main :: IO ()-main = do- let check :: T.Text -> Either Text ()- check t = case parse (expression <* eof) "dummy" t of- Left rr -> Left (t <> " -> " <> show rr)- Right e -> case dummyEval (resolveExpression e) of- Right (PBoolean True) -> Right ()- Right x -> Left (t <> " -> " <> show (pretty x))- Left rr -> Left (t <> " -> " <> show rr)- runcheck :: String -> IO ()- runcheck t = case parse (expression <* eof) "dummy" (T.pack t) of- Left rr -> panic ("Can't parse: " <> show rr)- Right e -> case dummyEval (resolveExpression e) of- Right x -> print (pretty x)- Left rr -> panic ("Can't eval: " <> show rr)- args <- getArgs- if null args- then hspec $ describe "evaluation" $ forM_ pureTests $ \t -> it ("should evaluate " ++ show t) $ either panic (const True) (check t)- else mapM_ runcheck args
− tests/expr.hs
@@ -1,35 +0,0 @@-module Main where--import qualified Data.Text as T-import Data.Tuple.Strict-import qualified Data.Vector as V-import Puppet.Parser-import Text.Megaparsec--import Test.Hspec-import Test.Hspec.Megaparsec--testcases :: [(T.Text, Expression)]-testcases =- [ ("5 + 3 * 2", 5 + 3 * 2)- , ("5+2 == 7", Equal (5 + 2) 7)- , ("include(foo::bar)", Terminal (UFunctionCall "include" (V.singleton "foo::bar") ))- , ("$y ? {\- \ undef => 'undef',\- \ default => 'default',\- \ }", ConditionalValue (Terminal (UVariableReference "y"))- (V.fromList [SelectorValue UUndef :!: Terminal (UString "undef")- ,SelectorDefault :!: Terminal (UString "default")]))- , ("$x", Terminal (UVariableReference "x"))- , ("x($y)", Terminal (UFunctionCall "x" (V.singleton (Terminal (UVariableReference "y")))))- , ("\"${x}\"", Terminal (UInterpolable (V.fromList [Terminal (UVariableReference "x")])))- , ("\"${x[3]}\"", Terminal (UInterpolable (V.fromList [Lookup (Terminal (UVariableReference "x")) 3])))- , ("\"${x[$y]}\"", Terminal (UInterpolable (V.fromList [Lookup (Terminal (UVariableReference "x")) (Terminal (UVariableReference "y")) ])))- , ("\"${x($y)}\"", Terminal (UInterpolable (V.fromList [ Terminal (UFunctionCall "x" (V.singleton (Terminal (UVariableReference "y")))) ])))- , ("\"${x($y)}$'\"", Terminal (UInterpolable (V.fromList [ Terminal (UFunctionCall "x" (V.singleton (Terminal (UVariableReference "y")))),Terminal (UString "$"),Terminal (UString "'")])))- ]--main :: IO ()-main = hspec $ describe "Expression parser" $ mapM_ test testcases- where- test (t,e) = it ("should parse " ++ show t) $ parse (expression <* eof) "" t `shouldParse` e
− tests/hiera.hs
@@ -1,93 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-module Main where--import Helpers--import qualified Data.Either.Strict as S-import qualified Data.HashMap.Strict as HM-import qualified Data.Vector as Vector-import NeatInterpolation-import qualified System.IO.Temp as IO-import qualified System.Log.Logger as Log-import Test.HUnit--import Hiera.Server--main :: IO ()-main = IO.withSystemTempDirectory "hieratest" $ \tmpfp -> do- Log.updateGlobalLogger loggerName (Log.setLevel Log.ERROR)- let ndname = "node.site.com"- vars = HM.fromList [ ("::environment", "production")- , ("::fqdn" , ndname)- ]- hiera5_config fp =- [text|- version: 5- hierarchy:- - name: "Hiera config for unit test"- data_hash: yaml_data- datadir: $fp- paths:- - "%{::fqdn}.yaml"- - "%{::environment}.yaml"- - "global.yaml"- |]- hiera3_config fp =- [text|- :backends:- - "yaml"- - "json"- :logger: "console"- :hierarchy:- - "%{::fqdn}"- - "%{::environment}"- - "global"- :yaml:- :datadir: $fp- :json:- :datadir: $fp- |]- writeFile (tmpfp <> "/hiera3.yaml") (hiera3_config (toS tmpfp))- writeFile (tmpfp <> "/hiera5.yaml") (hiera5_config (toS tmpfp))- writeFile (tmpfp <> "/global.yaml") "---\nhttp_port: 8080\nntp_servers: ['0.ntp.puppetlabs.com', '1.ntp.puppetlabs.com']\nusers:\n pete:\n uid: 2000\n tom:\n uid: 2001\nglobal: \"glob\""- writeFile (tmpfp <> "/production.yaml") "---\nhttp_port: 9090\nntp_servers: ['2.ntp.puppetlabs.com', '3.ntp.puppetlabs.com']\ninterp1: '**%{::fqdn}**'\nusers:\n bob:\n uid: 100\n tom:\n uid: 12\n"- writeFile (tmpfp <> "/" <> toS ndname <> ".json") "{\"testnode\":{\"1\":\"**%{::fqdn}**\",\"2\":\"nothing special\"},\"testjson\":\"ok\",\"arraytest\":[\"a\",\"%{::fqdn}\",\"c\"]}\n"- let users = HM.fromList [ ("pete", PHash (HM.singleton "uid" (PNumber 2000)))- , ("tom" , PHash (HM.singleton "uid" (PNumber 2001)))- ]- pusers = HM.fromList [ ("bob", PHash (HM.singleton "uid" (PNumber 100)))- , ("tom" , PHash (HM.singleton "uid" (PNumber 12)))- ]- q3 <- startHiera (tmpfp ++ "/hiera3.yaml")- q5 <- startHiera (tmpfp ++ "/hiera5.yaml")- let checkOutput v (S.Right x) = x @?= v- checkOutput _ (S.Left rr) = assertFailure (show rr)- hspec $ do- describe "lookup data without a key" $- it "returns an error when called with an empty string" $ q3 mempty "" QFirst >>= checkOutput Nothing- describe "lookup data without a valid key" $ do- it "returns an error when called with a non existent key [QFirst]" $ q3 mempty "foo" QFirst >>= checkOutput Nothing- it "returns an error when called with a non existent key [QUnique]" $ q3 mempty "foo" QUnique >>= checkOutput Nothing- it "returns an error when called with a non existent key [QHash]" $ q3 mempty "foo" QHash >>= checkOutput Nothing- describe "lookup data with no options" $ do- it "can get string data" $ q3 mempty "http_port" QFirst >>= checkOutput (Just (PNumber 8080))- it "can get arrays" $ q3 mempty "ntp_servers" QFirst >>= checkOutput (Just (PArray (Vector.fromList ["0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])))- it "can get hashes" $ q3 mempty "users" QFirst >>= checkOutput (Just (PHash users))- describe "lookup data with a scope" $ do- it "overrides some values" $ q3 vars "http_port" QFirst >>= checkOutput (Just (PNumber 9090))- it "doesn't fail on others" $ q3 vars "global" QFirst >>= checkOutput (Just "glob")- describe "json backend" $- it "resolves in json" $ q3 vars "testjson" QFirst >>= checkOutput (Just "ok")- describe "deep interpolation" $ do- it "resolves in strings" $ q3 vars "interp1" QFirst >>= checkOutput (Just (PString ("**" <> ndname <> "**")))- it "resolves in objects" $ q3 vars "testnode" QFirst >>= checkOutput (Just (PHash (HM.fromList [("1",PString ("**" <> ndname <> "**")),("2",PString "nothing special")])))- it "resolves in arrays" $ q3 vars "arraytest" QFirst >>= checkOutput (Just (PArray (Vector.fromList [PString "a", PString ndname, PString "c"])))- describe "other merge modes" $ do- it "catenates arrays" $ q3 vars "ntp_servers" QUnique >>= checkOutput (Just (PArray (Vector.fromList ["2.ntp.puppetlabs.com","3.ntp.puppetlabs.com","0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])))- it "puts single values in arrays" $ q3 vars "http_port" QUnique >>= checkOutput (Just (PArray (Vector.fromList [PNumber 9090, PNumber 8080])))- it "merges hashes" $ q3 vars "users" QHash >>= checkOutput (Just (PHash (pusers <> users)))-- -- V5 format- describe "[V5] lookup data with a scope" $ do- it "overrides some values" $ q5 vars "http_port" QFirst >>= checkOutput (Just (PNumber 9090))- it "doesn't fail on others" $ q5 vars "global" QFirst >>= checkOutput (Just "glob")
+ tests/hiera/common.yaml view
@@ -0,0 +1,10 @@+---+http_port: 8080+ntp_servers: ['0.ntp.puppetlabs.com', '1.ntp.puppetlabs.com']+interp1: "**%{::fqdn}**"+global: 'glob'+users:+ pete:+ uid: 2000+ tom:+ uid: 2001
+ tests/hiera/hiera-v3.yaml view
@@ -0,0 +1,12 @@+:backends:+ - "yaml"+ - "json"+:logger: "console"+:hierarchy:+ - "%{::fqdn}"+ - "%{::environment}"+ - common+:yaml:+ :datadir: . +:json:+ :datadir: .
+ tests/hiera/hiera-v5.yaml view
@@ -0,0 +1,10 @@+---+version: 5+hierarchy:+ - name: "Hiera config for unit test"+ data_hash: yaml_data+ datadir: .+ paths:+ - "%{::fqdn}.yaml"+ - "%{::environment}.yaml"+ - common.yaml
+ tests/hiera/node.com.json view
@@ -0,0 +1,6 @@+{ "testnode":+ { "1": "**%{::fqdn}**",+ "2": "nothing special"},+ "testjson": "ok",+ "arraytest": [ "a", "%{::fqdn}", "c"]+}
+ tests/hiera/production.yaml view
@@ -0,0 +1,9 @@+---+http_port: 9090+ntp_servers: ['2.ntp.puppetlabs.com', '3.ntp.puppetlabs.com']+interp1: "**%{::fqdn}**"+users:+ bob:+ uid: 100+ tom:+ uid: 12
− tests/lexer.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE LambdaCase #-}-module Main where--import Control.Monad-import qualified Data.Text.IO as T-import System.Environment-import System.FilePath.Glob-import System.IO-import System.Posix.Terminal-import System.Posix.Types-import Text.Megaparsec (eof, parse, parseErrorPretty)-import Text.PrettyPrint.ANSI.Leijen--import Puppet.Parser--allchecks :: IO ()-allchecks = do- filelist <- globDir1 (compile "*.pp") "tests/lexer"- testres <- mapM testparser filelist- let isgood = all snd testres- mapM_ (\(rr, t) -> unless t (putStrLn rr)) testres- unless isgood (error "fail")---- returns errors-testparser :: FilePath -> IO (String, Bool)-testparser fp =- fmap (parse (puppetParser <* eof) fp) (T.readFile fp) >>= \case- Right _ -> return ("PASS", True)- Left rr -> return (parseErrorPretty rr, False)--check :: String -> IO ()-check fname = do- putStr fname- putStr ": "- res <- fmap (parse puppetParser fname) (T.readFile fname)- is <- queryTerminal (Fd 1)- let rfunc = if is- then renderPretty 0.2 200- else renderCompact- case res of- Left rr -> putStrLn (parseErrorPretty rr)- Right x -> do- putStrLn ""- displayIO stdout (rfunc (pretty (ppStatements x)))- putStrLn ""--main :: IO ()-main = do- args <- getArgs- if null args- then allchecks- else mapM_ check args
− tests/puppetdb.hs
@@ -1,44 +0,0 @@-module Main where--import Control.Monad-import System.IO.Temp-import Data.Semigroup-import qualified Data.Text as T-import qualified Data.Text.IO as T-import Control.Lens-import Control.Monad.Trans.Except--import PuppetDB--checkError :: Show x => String -> Either x a -> IO a-checkError _ (Right x) = return x-checkError step (Left rr) = error (step ++ ": " ++ show rr)--checkErrorE :: Show x => String -> ExceptT x IO a -> IO a-checkErrorE msg = runExceptT >=> either (error . ((msg ++ " ") ++) . show) return--main :: IO ()-main = withSystemTempDirectory "hieratest" $ \tmpfp -> do- let ndname = "node.site.com"- pdbfile = tmpfp <> "/puppetdb.yaml"- -- generate an empty puppetdb- pdb <- loadTestDB pdbfile >>= checkError "loadTestDB"- -- get some dummy facts- facts <- puppetDBFacts ndname pdb- -- and add a custom fact- let nfacts = facts & at "customfact" ?~ "MyCustomFactValue"- -- save the facts- checkErrorE "replaceFacts" (replaceFacts pdb [(ndname, nfacts)])- checkErrorE "commitDB" (commitDB pdb)- -- check that our custom fact was indeed saved- dblines <- T.lines `fmap` T.readFile pdbfile- unless (" customfact: MyCustomFactValue" `elem` dblines) (error "could not find my fact")- -- now we initiate a new puppetdbapi- fpdb <- loadTestDB pdbfile >>= checkError "loadTestDB"- ffacts <- puppetDBFacts ndname pdb- unless (ffacts == nfacts) (error "facts are distinct")- checkErrorE "replaceCatalog" (replaceCatalog fpdb (generateWireCatalog ndname mempty mempty))- checkErrorE "commit 2" (commitDB fpdb)- -- and check for our facts again- fdblines <- T.lines `fmap` T.readFile pdbfile- unless (" customfact: MyCustomFactValue" `elem` fdblines) (error "could not find my fact")