summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimonMarechal <>2018-03-01 17:30:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-03-01 17:30:00 (GMT)
commitc2eefa7f2a36c1c1f079d3f5030cc7e216d58bb3 (patch)
treee44a4356ecb36c6e72d7d55b62524b7a019e2e0c
parent4ceee35300f3435b19699ed6324a8212189f85c8 (diff)
version 1.3.161.3.16
-rw-r--r--CHANGELOG6
-rw-r--r--language-puppet.cabal82
-rw-r--r--src/Erb/Parser.hs178
-rw-r--r--src/Erb/Ruby.hs1
-rw-r--r--src/Puppet/Interpreter/IO.hs4
-rw-r--r--src/Puppet/Interpreter/PrettyPrinter.hs10
-rw-r--r--src/Puppet/Interpreter/Resolve.hs32
-rw-r--r--src/Puppet/Interpreter/Types.hs9
-rw-r--r--src/Puppet/Language/Core.hs7
-rw-r--r--src/Puppet/Parser.hs5
-rw-r--r--src/Puppet/Runner.hs2
-rw-r--r--src/Puppet/Runner/Daemon.hs2
-rw-r--r--src/Puppet/Runner/Erb.hs207
-rw-r--r--src/Puppet/Runner/Erb/Evaluate.hs90
-rw-r--r--src/Puppet/Runner/Preferences.hs2
-rw-r--r--src/Puppet/Runner/Pure.hs33
-rw-r--r--src/XPrelude/Extra.hs10
-rw-r--r--tests/ErbSpec.hs73
-rw-r--r--tests/EvalSpec.hs44
-rw-r--r--tests/ExprSpec.hs35
-rw-r--r--tests/HieraSpec.hs77
-rw-r--r--tests/LexerSpec.hs22
-rw-r--r--tests/PuppetdbSpec.hs42
-rw-r--r--tests/Spec.hs36
-rw-r--r--tests/erb.hs18
-rw-r--r--tests/evals.hs52
-rw-r--r--tests/expr.hs35
-rw-r--r--tests/hiera.hs93
-rw-r--r--tests/hiera/common.yaml10
-rw-r--r--tests/hiera/hiera-v3.yaml12
-rw-r--r--tests/hiera/hiera-v5.yaml10
-rw-r--r--tests/hiera/node.com.json6
-rw-r--r--tests/hiera/production.yaml9
-rw-r--r--tests/lexer.hs52
-rw-r--r--tests/puppetdb.hs44
35 files changed, 730 insertions, 620 deletions
diff --git a/CHANGELOG b/CHANGELOG
index 5bccf15..0c2a542 100644
--- 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 <bartavelle@gmail.com> 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
index 87e1510..c7ebc42 100644
--- 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 @@ extra-source-files:
CHANGELOG
README.adoc
HLint.hs
+ tests/hiera/*.yaml
+ tests/hiera/*.com.json
Data-Files:
ruby/hrubyerb.rb
@@ -101,7 +103,7 @@ library
, 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 @@ library
, 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,13 +174,15 @@ Test-Suite spec
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
extensions: BangPatterns, OverloadedStrings
diff --git a/src/Erb/Parser.hs b/src/Erb/Parser.hs
index 030792c..f0b487b 100644
--- a/src/Erb/Parser.hs
+++ b/src/Erb/Parser.hs
@@ -18,16 +18,16 @@ import Erb.Ruby
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 :: Parser Expression
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 @@ rubystatement = fmap Puts rubyexpression
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 :: FilePath -> IO (Either ParseError [RubyStatement])
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
index e8b9823..0170abd 100644
--- a/src/Erb/Ruby.hs
+++ b/src/Erb/Ruby.hs
@@ -32,6 +32,7 @@ data Expression
| 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
index 1afbbb8..5d01deb 100644
--- a/src/Puppet/Interpreter/IO.hs
+++ b/src/Puppet/Interpreter/IO.hs
@@ -55,7 +55,7 @@ eval r s (a :>>= k) =
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 @@ eval r s (a :>>= k) =
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
index 36abba2..78f889b 100644
--- a/src/Puppet/Interpreter/PrettyPrinter.hs
+++ b/src/Puppet/Interpreter/PrettyPrinter.hs
@@ -10,6 +10,10 @@ import qualified Data.ByteString.Lazy.Char8 as BSL
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 @@ instance Pretty (InterpreterInstr a) where
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
index c40ba01..ed1d350 100644
--- a/src/Puppet/Interpreter/Resolve.hs
+++ b/src/Puppet/Interpreter/Resolve.hs
@@ -452,7 +452,10 @@ resolveFunction' "defined" [ut] = do
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 @@ resolveFunction' "split" [psrc, psplt] = do
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 @@ resolveFunction' "tagged" ptags = do
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] = hieraCall QHash q (Just d) Nothing Not
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 @@ pdbresourcequery q mkey = do
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
index 9b26ecd..1e4e280 100644
--- a/src/Puppet/Interpreter/Types.hs
+++ b/src/Puppet/Interpreter/Types.hs
@@ -80,6 +80,8 @@ module Puppet.Interpreter.Types (
, HieraQueryLayers(..)
, globalLayer
, moduleLayer
+ -- * Template
+ , TemplateSource(..)
-- * Re-export
, module Puppet.Language
) where
@@ -204,10 +206,13 @@ data HieraQueryLayers m = HieraQueryLayers
, _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 @@ data InterpreterInstr a where
-- 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
index a15e0f6..3af1271 100644
--- a/src/Puppet/Language/Core.hs
+++ b/src/Puppet/Language/Core.hs
@@ -12,14 +12,17 @@ import qualified Data.Tuple.Strict as Tuple
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
initialPPos x =
diff --git a/src/Puppet/Parser.hs b/src/Puppet/Parser.hs
index ec38391..9f7b083 100644
--- a/src/Puppet/Parser.hs
+++ b/src/Puppet/Parser.hs
@@ -728,7 +728,10 @@ datatype = dtString
<|> 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
index 5ed1e48..70c9126 100644
--- a/src/Puppet/Runner.hs
+++ b/src/Puppet/Runner.hs
@@ -19,6 +19,7 @@ module Puppet.Runner(
-- * Daemon
, module Puppet.Runner.Daemon
-- * Re-export
+ , module Puppet.Runner.Erb.Evaluate
, module Puppet.Interpreter
)
where
@@ -28,4 +29,5 @@ import Puppet.Runner.Preferences
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
index a357616..9f9ab50 100644
--- a/src/Puppet/Runner/Daemon.hs
+++ b/src/Puppet/Runner/Daemon.hs
@@ -85,7 +85,7 @@ initDaemon pref = do
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
index 8edbcf8..f643717 100644
--- a/src/Puppet/Runner/Erb.hs
+++ b/src/Puppet/Runner/Erb.hs
@@ -11,9 +11,10 @@ import Data.Aeson.Lens (_Number)
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.Erb.Evaluate
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 (WithOutput str _) = PrettyError $ dullred (ppstring str)
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
-
-templateQuery :: Chan TemplateQuery -> Either Text Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text)
-templateQuery qchan filename stt rdr = do
+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 -> 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
-
-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))
+ 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 -> 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 @@ hrresolveVariable _ rscp rvariables rtoresolve = do
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 @@ hrcallfunction _ rfname rargs rstt rrdr = do
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 @@ computeTemplateWRuby fileinfo curcontext variables stt rdr = FR.freezeGC $ eithe
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
index 542b51b..eb0e0a7 100644
--- a/src/Puppet/Runner/Erb/Evaluate.hs
+++ b/src/Puppet/Runner/Erb/Evaluate.hs
@@ -6,24 +6,31 @@ module Puppet.Runner.Erb.Evaluate (
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 @@ evalruby mp ctx (Right curstr) (DropPrevSpace x) =
case evalruby mp ctx (Right curstr) x of
Left err -> Left err
Right y -> Right (Text.dropWhileEnd spaceNotCR y)
-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
index e841469..a1433f9 100644
--- a/src/Puppet/Runner/Preferences.hs
+++ b/src/Puppet/Runner/Preferences.hs
@@ -51,7 +51,7 @@ data Preferences m = Preferences
, _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
index 0658ca2..a5f87f7 100644
--- 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 Puppet.Runner.Erb
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 @@ dummyFacts = HM.fromList
, ("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
index 4bc5f5d..283d506 100644
--- a/src/XPrelude/Extra.hs
+++ b/src/XPrelude/Extra.hs
@@ -17,12 +17,14 @@ module XPrelude.Extra (
-- * Logger
, loggerName
, logDebug
+ , logDebugStr
, logInfo
, logInfoStr
, logWarning
, logWarningStr
, logError
- , logDebugStr
+ , logCritical
+ , logCriticalStr
) where
import Protolude as Exports hiding (Down, Infix, Prefix, Selector,
@@ -171,6 +173,12 @@ logWarningStr = Log.warningM "language-puppet"
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
index 0000000..46046cb
--- /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
index 0000000..bf831df
--- /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
index 0000000..f2d4bff
--- /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
index 0000000..451d564
--- /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
index 0000000..f2c5a08
--- /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
index 0000000..ed3f630
--- /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
index a1c0353..982b3a1 100644
--- 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 :: Spec
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 @@ spec = do
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
index 05b73fd..0000000
--- 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
index feeb419..0000000
--- 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
index a304e31..0000000
--- 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
index 525ff19..0000000
--- 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
index 0000000..bf449f5
--- /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
index 0000000..63cbfd8
--- /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
index 0000000..e13b1f4
--- /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
index 0000000..9c3fb1d
--- /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
index 0000000..699e633
--- /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
index 76beb44..0000000
--- 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
index a4089e3..0000000
--- 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")