diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,9 @@ +language-puppet (1.3.16) artful; urgency=medium + [ PierreR ] + * Fix #213 Hash lookup failing in erb template + + -- Simon Marechal Thu, 01 Mar 2018 17:48:48 +0100 + language-puppet (1.3.15) artful; urgency=medium * Improve parsing error messages diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet -version: 1.3.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 diff --git a/src/Erb/Parser.hs b/src/Erb/Parser.hs --- a/src/Erb/Parser.hs +++ b/src/Erb/Parser.hs @@ -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 diff --git a/src/Erb/Ruby.hs b/src/Erb/Ruby.hs --- a/src/Erb/Ruby.hs +++ b/src/Erb/Ruby.hs @@ -32,6 +32,7 @@ | NegOperation !Expression | ConditionalValue !Expression !Expression | Object !Expression + | ScopeObject !Expression | MethodCall !Expression !Expression | BlockOperation !Text | Value !Value 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 @@ -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 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 @@ -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] 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 @@ -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 = 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 @@ -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) 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 @@ -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 diff --git a/src/Puppet/Parser.hs b/src/Puppet/Parser.hs --- a/src/Puppet/Parser.hs +++ b/src/Puppet/Parser.hs @@ -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 diff --git a/src/Puppet/Runner.hs b/src/Puppet/Runner.hs --- a/src/Puppet/Runner.hs +++ b/src/Puppet/Runner.hs @@ -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 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 @@ -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 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 @@ -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 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 @@ -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) 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 @@ -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 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,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") diff --git a/src/XPrelude/Extra.hs b/src/XPrelude/Extra.hs --- a/src/XPrelude/Extra.hs +++ b/src/XPrelude/Extra.hs @@ -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" diff --git a/tests/ErbSpec.hs b/tests/ErbSpec.hs new file mode 100644 --- /dev/null +++ b/tests/ErbSpec.hs @@ -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 diff --git a/tests/EvalSpec.hs b/tests/EvalSpec.hs new file mode 100644 --- /dev/null +++ b/tests/EvalSpec.hs @@ -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 diff --git a/tests/ExprSpec.hs b/tests/ExprSpec.hs new file mode 100644 --- /dev/null +++ b/tests/ExprSpec.hs @@ -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 diff --git a/tests/HieraSpec.hs b/tests/HieraSpec.hs new file mode 100644 --- /dev/null +++ b/tests/HieraSpec.hs @@ -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))) diff --git a/tests/LexerSpec.hs b/tests/LexerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/LexerSpec.hs @@ -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 diff --git a/tests/PuppetdbSpec.hs b/tests/PuppetdbSpec.hs new file mode 100644 --- /dev/null +++ b/tests/PuppetdbSpec.hs @@ -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"] diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -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 diff --git a/tests/erb.hs b/tests/erb.hs deleted file mode 100644 --- a/tests/erb.hs +++ /dev/null @@ -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) diff --git a/tests/evals.hs b/tests/evals.hs deleted file mode 100644 --- a/tests/evals.hs +++ /dev/null @@ -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 diff --git a/tests/expr.hs b/tests/expr.hs deleted file mode 100644 --- a/tests/expr.hs +++ /dev/null @@ -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 diff --git a/tests/hiera.hs b/tests/hiera.hs deleted file mode 100644 --- a/tests/hiera.hs +++ /dev/null @@ -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") diff --git a/tests/hiera/common.yaml b/tests/hiera/common.yaml new file mode 100644 --- /dev/null +++ b/tests/hiera/common.yaml @@ -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 diff --git a/tests/hiera/hiera-v3.yaml b/tests/hiera/hiera-v3.yaml new file mode 100644 --- /dev/null +++ b/tests/hiera/hiera-v3.yaml @@ -0,0 +1,12 @@ +:backends: + - "yaml" + - "json" +:logger: "console" +:hierarchy: + - "%{::fqdn}" + - "%{::environment}" + - common +:yaml: + :datadir: . +:json: + :datadir: . diff --git a/tests/hiera/hiera-v5.yaml b/tests/hiera/hiera-v5.yaml new file mode 100644 --- /dev/null +++ b/tests/hiera/hiera-v5.yaml @@ -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 diff --git a/tests/hiera/node.com.json b/tests/hiera/node.com.json new file mode 100644 --- /dev/null +++ b/tests/hiera/node.com.json @@ -0,0 +1,6 @@ +{ "testnode": + { "1": "**%{::fqdn}**", + "2": "nothing special"}, + "testjson": "ok", + "arraytest": [ "a", "%{::fqdn}", "c"] +} diff --git a/tests/hiera/production.yaml b/tests/hiera/production.yaml new file mode 100644 --- /dev/null +++ b/tests/hiera/production.yaml @@ -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 diff --git a/tests/lexer.hs b/tests/lexer.hs deleted file mode 100644 --- a/tests/lexer.hs +++ /dev/null @@ -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 diff --git a/tests/puppetdb.hs b/tests/puppetdb.hs deleted file mode 100644 --- a/tests/puppetdb.hs +++ /dev/null @@ -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")