language-puppet 1.1.5 → 1.1.5.1
raw patch · 20 files changed
+463/−95 lines, 20 filesdep +hspec-megaparsecdep ~hsloggerdep ~megaparsecdep ~mtl
Dependencies added: hspec-megaparsec
Dependency ranges changed: hslogger, megaparsec, mtl
Files
- CHANGELOG.markdown +11/−1
- Puppet/Interpreter.hs +9/−13
- Puppet/Interpreter/Resolve.hs +13/−4
- Puppet/Interpreter/Utils.hs +10/−1
- Puppet/NativeTypes/Helpers.hs +8/−0
- Puppet/NativeTypes/Notify.hs +1/−1
- Puppet/Parser.hs +13/−21
- Puppet/Stdlib.hs +101/−5
- language-puppet.cabal +9/−6
- tests/Function/AssertPrivateSpec.hs +40/−0
- tests/Function/EachSpec.hs +10/−7
- tests/Function/JoinKeysToValuesSpec.hs +27/−0
- tests/Function/MergeSpec.hs +3/−5
- tests/Function/SizeSpec.hs +3/−6
- tests/Helpers.hs +15/−4
- tests/Interpreter/CollectorSpec.hs +153/−0
- tests/InterpreterSpec.hs +15/−3
- tests/Spec.hs +14/−5
- tests/expr.hs +6/−13
- tests/hiera.hs +2/−0
CHANGELOG.markdown view
@@ -1,4 +1,14 @@-# v1.1.5 (TBA)+# v1.1.5.1 (2016/03/14)++## New features+* `assert_private` function+* `join_keys_to_values` function++## Bugs Fixed+* Several resource collector misbehaviour+* Case expressions can now have multiple matchers of any kind as the same selector++# v1.1.5 (2016/02/02) ## New features
Puppet/Interpreter.hs view
@@ -43,7 +43,6 @@ import Puppet.PP import Puppet.Utils - {-| Call the operational 'interpretMonad' function to compute the catalog. Returns either an error, or a tuple containing all the resources, dependency map, exported resources, and defined resources alongside with@@ -343,7 +342,7 @@ when (rmod ^. rmModifierType == ModifierMustMatch && null filtrd) (throwError (PrettyError ("Could not apply this resource override :" <+> pretty rmod <> ",no matching resource was found."))) return result equalModifier (ResourceModifier a1 b1 c1 d1 _ e1) (ResourceModifier a2 b2 c2 d2 _ e2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2- result <- use resMod >>= foldM mutate (rma :!: mempty) . nubBy equalModifier+ result <- use resMod >>= foldM mutate (rma :!: mempty) . reverse . nubBy equalModifier resMod .= [] return result @@ -380,7 +379,8 @@ else nestedDeclarations . at (TopDefine, scp <> "::" <> dname) ?= r >> return [] evaluateStatement r@(ResourceCollectionDeclaration (ResCollDecl ct rtype searchexp mods p)) = do curPos .= p- unless (isEmpty mods || ct == Collector) (throwPosError ("It doesnt seem possible to amend attributes with an exported resource collector:" </> pretty r))+ unless (isEmpty mods || ct == Collector) (throwPosError ("It doesn't seem possible to amend attributes with an exported resource collector:" </> pretty r))+ when (rtype == "class") (throwPosError "Classes cannot be collected") rsearch <- resolveSearchExpression searchexp let et = case ct of Collector -> RealizeVirtual@@ -609,13 +609,11 @@ p <- use curPos -- check if the class has already been loaded -- http://docs.puppetlabs.com/puppet/3/reference/lang_classes.html#using-resource-like-declarations- use (loadedClasses . at name') >>= \case- Just (loadedincltype :!: pp) -> do- when ((incltype == ClassResourceLike) || (loadedincltype == ClassResourceLike)) $- throwPosError ("Can't include class" <+> ttext name' <+> "twice when using the resource-like syntax (first occurence at"- <+> showPPos pp <> ")")- -- already loaded, go on- return []+ preuse (loadedClasses . ix name' . _2) >>= \case+ Just pp -> case incltype of+ ClassIncludeLike -> return []+ _ -> throwPosError ("Can't include class" <+> ttext name' <+> "twice when using the resource-like syntax (first occurence at"+ <+> showPPos pp <> ")") Nothing -> do loadedClasses . at name' ?= (incltype :!: p) -- load the actual class, note we are not changing the current position right now@@ -762,9 +760,7 @@ "class" -> {-# SCC "rrClass" #-} do definedResources . at resid ?= r let attrs = r ^. rattributes- fmap (r:) $ loadClass rn S.Nothing attrs $ if HM.null attrs- then ClassIncludeLike- else ClassResourceLike+ fmap (r:) $ loadClass rn S.Nothing attrs ClassResourceLike _ -> {-# SCC "rrGeneralCase" #-} use (definedResources . at resid) >>= \case Just otheres -> throwPosError ("Resource" <+> pretty resid <+> "already defined:" </>
Puppet/Interpreter/Resolve.hs view
@@ -50,6 +50,7 @@ import qualified Data.ByteString.Base16 as B16 import Data.CaseInsensitive (mk) import Data.Char (isAlphaNum)+import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS import Data.Maybe (mapMaybe,fromMaybe)@@ -572,7 +573,6 @@ checkSearchExpression RAlwaysTrue _ = True checkSearchExpression (RAndSearch a b) r = checkSearchExpression a r && checkSearchExpression b r checkSearchExpression (ROrSearch a b) r = checkSearchExpression a r || checkSearchExpression b r-checkSearchExpression (RNonEqualitySearch a b) r = not (checkSearchExpression (REqualitySearch a b) r) checkSearchExpression (REqualitySearch "tag" (PString s)) r = r ^. rtags . contains s checkSearchExpression (REqualitySearch "tag" _) _ = False checkSearchExpression (REqualitySearch "title" v) r =@@ -581,9 +581,18 @@ Just a -> puppetEquality v a Nothing -> False in nameequal || aliasequal-checkSearchExpression (REqualitySearch attributename v) r = case r ^. rattributes . at attributename of- Nothing -> False- Just x -> puppetEquality x v+checkSearchExpression (REqualitySearch attributename v) r =+ case r ^. rattributes . at attributename of+ Nothing -> False+ Just (PArray x) -> F.any (flip puppetEquality v) x+ Just x -> puppetEquality x v+checkSearchExpression (RNonEqualitySearch attributename v) r+ | attributename == "tag" = True+ | attributename == "title" = not (checkSearchExpression (REqualitySearch attributename v) r)+ | otherwise = case r ^. rattributes . at attributename of+ Nothing -> True+ Just (PArray x) -> not (F.all (flip puppetEquality v) x)+ Just x -> not (puppetEquality x v) -- | Generates variable associations for evaluation of blocks. Each item -- corresponds to an iteration in the calling block.
Puppet/Interpreter/Utils.hs view
@@ -2,7 +2,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} --- | The module should not depend on the Interpreter module+-- | The module should not depend on the Interpreter module. It is an+-- internal module and should not be used if expecting a stable API. module Puppet.Interpreter.Utils where import Control.Lens hiding (Strict)@@ -69,6 +70,14 @@ scopeName (ContClass x ) = x scopeName (ContDefine dt dn _) = "#define/" `T.append` dt `T.append` "/" `T.append` dn scopeName (ContImport _ x ) = "::import::" `T.append` scopeName x++moduleName :: CurContainerDesc -> Text+moduleName (ContRoot ) = "::"+moduleName (ContImported x ) = moduleName x+moduleName (ContClass x ) = x+moduleName (ContDefine dt _ _) = dt+moduleName (ContImport _ x ) = moduleName x+ getScope :: InterpreterMonad CurContainerDesc {-# INLINABLE getScope #-}
Puppet/NativeTypes/Helpers.hs view
@@ -10,6 +10,7 @@ , rarray , string , strings+ , string_s , noTrailingSlash , fullyQualified , fullyQualifieds@@ -114,6 +115,13 @@ strings :: T.Text -> NativeTypeValidate strings param = runarray param string'++-- | Validates a string or an array of strings+string_s :: T.Text -> NativeTypeValidate+string_s param res = case res ^. rattributes . at param of+ Nothing -> Right res+ Just (PArray _) -> strings param res+ Just _ -> string param res string' :: T.Text -> PValue -> NativeTypeValidate string' param rev res = case rev of
Puppet/NativeTypes/Notify.hs view
@@ -10,6 +10,6 @@ parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])] parameterfunctions =- [("message" , [string])+ [("message" , []) ,("withpath" , [string, defaultvalue "false", values ["true","false"]]) ]
Puppet/Parser.hs view
@@ -335,7 +335,7 @@ ] indexLookupChain :: Parser (Expression -> Expression)-indexLookupChain = chainl1 checkLookup (return (flip (.)))+indexLookupChain = foldr1 (flip (.)) <$> some checkLookup where checkLookup = flip Lookup <$> between (operator "[") (operator "]") expression @@ -413,32 +413,24 @@ caseCondition :: Parser ConditionalDecl caseCondition = do- let puppetRegexpCase = do- reg <- termRegexp- void $ symbolic ':'- stmts <- braces statementList- return [ (Terminal (URegexp reg), stmts) ]- defaultCase = do- try (reserved "default")- void $ symbolic ':'- stmts <- braces statementList- return [ (Terminal (UBoolean True), stmts) ]- puppetCase = do- compares <- expression `sepBy1` comma+ let puppetRegexpCase = Terminal . URegexp <$> termRegexp+ defaultCase = Terminal (UBoolean True) <$ try (reserved "default")+ matchesToExpression e (x, stmts) = f x :!: stmts+ where f = case x of+ (Terminal (UBoolean _)) -> id+ (Terminal (URegexp _)) -> RegexMatch e+ _ -> Equal e+ cases = do+ matches <- (puppetRegexpCase <|> defaultCase <|> expression) `sepBy1` comma void $ symbolic ':' stmts <- braces statementList- return $ map (,stmts) compares- condsToExpression e (x, stmts) = f x :!: stmts- where f = case x of- (Terminal (UBoolean _))-> id- (Terminal (URegexp _)) -> RegexMatch e- _ -> Equal e+ return $ map (,stmts) matches p <- getPosition reserved "case" expr1 <- expression- condlist <- braces (some (puppetRegexpCase <|> defaultCase <|> puppetCase))+ condlist <- concat <$> braces (some cases) pe <- getPosition- return (ConditionalDecl (V.fromList (map (condsToExpression expr1) (concat condlist))) (p :!: pe) )+ return (ConditionalDecl (V.fromList (map (matchesToExpression expr1) condlist)) (p :!: pe) ) data OperatorChain a = OperatorChain a LinkType (OperatorChain a) | EndOfChain a
Puppet/Stdlib.hs view
@@ -29,50 +29,120 @@ stdlibFunctions :: Container ( [PValue] -> InterpreterMonad PValue ) stdlibFunctions = HM.fromList [ singleArgument "abs" puppetAbs , ("any2array", any2array)+ , ("assert_private", assertPrivate) , ("base64", base64)+ -- basename , singleArgument "bool2num" bool2num+ -- bool2str+ -- camelcase , ("capitalize", stringArrayFunction (safeEmptyString (\t -> T.cons (toUpper (T.head t)) (T.tail t))))+ -- ceiling , ("chomp", stringArrayFunction (T.dropWhileEnd (\c -> c == '\n' || c == '\r'))) , ("chop", stringArrayFunction (safeEmptyString T.init))+ -- clamp , ("concat", puppetConcat)+ -- convert_base , ("count", puppetCount)+ -- deep_merge , ("defined_with_params", const (throwPosError "defined_with_params can't be implemented with language-puppet")) , ("delete", delete) , ("delete_at", deleteAt) , singleArgument "delete_undef_values" deleteUndefValues+ -- delete_values+ -- difference+ -- dirname+ -- dos2unix , ("downcase", stringArrayFunction T.toLower) , singleArgument "empty" _empty+ -- ensure_packages+ -- ensure_resource , singleArgument "flatten" flatten- , singleArgument "getvar" getvar+ -- floor+ -- fqdn_rand_string+ -- fqdn_rotate+ -- get_module_path , ("getparam", const $ throwPosError "The getparam function is uncool and shall not be implemented in language-puppet")+ , singleArgument "getvar" getvar , ("grep", _grep) , ("hash", hash)+ -- has_interface_with+ -- has_ip_address+ -- has_ip_network+ , ("has_key", hasKey)+ -- intersection+ -- is_absolute_path , singleArgument "is_array" isArray- , singleArgument "is_domain_name" isDomainName- , singleArgument "is_integer" isInteger , singleArgument "is_bool" isBool+ , singleArgument "is_domain_name" isDomainName+ -- is_float+ -- is_function_available , singleArgument "is_hash" isHash+ , singleArgument "is_integer" isInteger+ -- is_ip_address+ -- is_mac_address+ -- is_numeric , singleArgument "is_string" isString , ("join", puppetJoin)+ , ("join_keys_to_values", joinKeysToValues) , singleArgument "keys" keys- , ("has_key", hasKey)+ -- load_module_metadata+ -- loadyaml , ("lstrip", stringArrayFunction T.stripStart)- , ("merge", merge)+ -- max , ("member", member)+ , ("merge", merge)+ -- min+ -- num2bool+ -- parsejson+ -- parseyaml , ("pick", pick) , ("pick_default", pickDefault)+ -- prefix+ -- private+ -- pw_hash+ -- range+ -- reject+ -- reverse , ("rstrip", stringArrayFunction T.stripEnd)+ -- seeded_rand+ -- shuffle , singleArgument "size" size+ -- sort+ -- squeeze , singleArgument "str2bool" str2Bool+ -- strtosaltedshar512+ -- strftime , ("strip", stringArrayFunction T.strip)+ -- suffix+ -- swapcase+ -- time+ -- to_bytes+ -- try_get_value+ -- type3x+ -- type+ -- union+ -- unique+ -- unix2dos , ("upcase", stringArrayFunction T.toUpper)+ -- uriescape , ("validate_absolute_path", validateAbsolutePath) , ("validate_array", validateArray)+ -- validate_augeas , ("validate_bool", validateBool)+ -- validate_cmd , ("validate_hash", validateHash)+ -- validate_integer+ -- validate_ip_address+ -- validate_ipv4_address+ -- validate_ipv6_address+ -- validate_numeric , ("validate_re", validateRe)+ -- validate_slength , ("validate_string", validateString)+ -- validate_x509_rsa_key_pair+ -- values_at , singleArgument "values" pvalues+ -- zip ] singleArgument :: T.Text -> (PValue -> InterpreterMonad PValue) -> (T.Text, [PValue] -> InterpreterMonad PValue )@@ -106,6 +176,22 @@ Just x -> return $ _Number # abs x Nothing -> throwPosError ("abs(): Expects a number, not" <+> pretty y) +assertPrivate :: [PValue] -> InterpreterMonad PValue+assertPrivate args = case args of+ [] -> go Nothing+ [t] -> resolvePValueString t >>= go . Just+ _ -> throwPosError "assert_private: expects no or a single string argument"+ where+ go msg = do+ scp <- use curScope+ case scp of+ funScope : callerScope : _ ->+ let takeModule = T.takeWhile (/= ':') . moduleName+ in if takeModule funScope == takeModule callerScope+ then return PUndef+ else throwPosError $ maybe ("assert_private: failed: " <> pretty funScope <> " is private") ttext msg+ _ -> return PUndef+ any2array :: [PValue] -> InterpreterMonad PValue any2array [PArray v] = return (PArray v) any2array [PHash h] = return (PArray lst)@@ -260,6 +346,16 @@ return (PString (T.intercalate interc rrt)) puppetJoin [_,_] = throwPosError "join(): expected an array of strings, and a string" puppetJoin _ = throwPosError "join(): expected two arguments"++joinKeysToValues :: [PValue] -> InterpreterMonad PValue+joinKeysToValues [PHash h, separator] = do+ ssep <- resolvePValueString separator+ fmap (PArray . V.fromList) $ forM (itoList h) $ \(k,v) -> do+ sv <- case v of+ PUndef -> return ""+ _ -> resolvePValueString v+ return (PString (k <> ssep <> sv))+joinKeysToValues _ = throwPosError "join_keys_to_values(): expects 2 arguments, an hash and a string" keys :: PValue -> InterpreterMonad PValue keys (PHash h) = return (PArray $ V.fromList $ map PString $ HM.keys h)
language-puppet.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet-version: 1.1.5+version: 1.1.5.1 synopsis: Tools to parse and evaluate the Puppet DSL. description: This is a set of tools that is supposed to fill all your Puppet needs : syntax checks, catalog compilation, PuppetDB queries, simulationg of complex interactions between nodes, Puppet master replacement, and more ! homepage: http://lpuppet.banquise.net/@@ -44,6 +44,7 @@ , Puppet.Interpreter.Pure , Puppet.Interpreter.Resolve , Puppet.Interpreter.Types+ , Puppet.Interpreter.Utils , Puppet.Lens , Puppet.NativeTypes , Puppet.NativeTypes.Helpers@@ -61,7 +62,6 @@ other-modules: Erb.Compute , Paths_language_puppet , Puppet.Interpreter.RubyRandom- , Puppet.Interpreter.Utils , Puppet.Manifests , Puppet.NativeTypes.Concat , Puppet.NativeTypes.Cron@@ -102,7 +102,7 @@ , hspec , lens >= 4.12 && < 5 , lens-aeson >= 1.0- , megaparsec == 4.1.*+ , megaparsec == 4.3.* , memory >= 0.7 , mtl >= 2.2 && < 2.3 , operational >= 0.2.3 && < 0.3@@ -144,14 +144,14 @@ 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+ 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- build-depends: language-puppet,base,hspec,temporary,strict-base-types,HUnit,lens,vector,unordered-containers,text+ build-depends: language-puppet,base,hspec,temporary,strict-base-types,HUnit,lens,vector,unordered-containers,text,hslogger main-is: hiera.hs Test-Suite test-puppetdb hs-source-dirs: tests@@ -172,12 +172,15 @@ type: exitcode-stdio-1.0 ghc-options: -Wall -rtsopts -threaded extensions: OverloadedStrings- build-depends: language-puppet,base,strict-base-types,lens,text,hspec,unordered-containers,megaparsec,vector,scientific+ build-depends: language-puppet,base,strict-base-types,lens,text,hspec,unordered-containers,megaparsec,vector,scientific,mtl other-modules: Function.ShellquoteSpec Function.SizeSpec Function.MergeSpec Function.EachSpec+ Function.AssertPrivateSpec+ Function.JoinKeysToValuesSpec InterpreterSpec+ Interpreter.CollectorSpec Helpers main-is: Spec.hs
+ tests/Function/AssertPrivateSpec.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedLists #-}+module Function.AssertPrivateSpec where++import Test.Hspec++import Control.Lens+import Control.Monad+import Data.Text (Text)++import Puppet.Interpreter.Resolve+import Puppet.Interpreter.Pure+import Puppet.Interpreter.Types+import Puppet.Interpreter.Utils (initialState)+import Puppet.Interpreter.IO (interpretMonad)+import Puppet.Parser.Types++import Helpers++main :: IO ()+main = hspec spec++evalWithScope :: ([PValue] -> InterpreterMonad PValue)+ -> Text -- ^ caller scope+ -> Text -- ^ module scope+ -> [Expression] -- ^ function args+ -> Either String PValue+evalWithScope apFunc callerScope moduleScope = (_Left %~ show) . view _1 . ctxEval . (mapM resolveExpression >=> apFunc)+ where+ ctxEval = runIdentity . interpretMonad (pureReader mempty) startingState+ startingState = initialState dummyFacts [("confdir", "/etc/puppet")] & curScope .~ [ContClass moduleScope, ContClass callerScope]+++spec :: Spec+spec = withStdlibFunction "assert_private" $ \apFunc -> do+ let errorWith a b = case a of+ Right x -> fail ("Should have failed, got this instead: " ++ show x)+ Left rr -> rr `shouldContain` b+ it "should work when called from inside module" (evalWithScope apFunc "bar" "bar" [] `shouldBe` Right PUndef)+ it "should fail with the default message" (evalWithScope apFunc "bar" "baz" [] `errorWith` "is private")+ it "should fail with an explicit failure message" (evalWithScope apFunc "bar" "baz" ["lalala"] `errorWith` "lalala")
tests/Function/EachSpec.hs view
@@ -11,42 +11,45 @@ spec :: Spec spec = do+ let mgetCatalog x = case getCatalog x of+ Left rr -> fail rr+ Right y -> return y describe "should be callable as" $ do it "each on an array selecting each value" $ do- c <- getCatalog "$a = [1,2,3]\n $a.each |$v| {\n file { \"/file_$v\": ensure => present } \n } "+ c <- mgetCatalog "$a = [1,2,3]\n $a.each |$v| {\n file { \"/file_$v\": ensure => present } \n } " getResource (RIdentifier "file" "/file_1") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" getResource (RIdentifier "file" "/file_2") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" getResource (RIdentifier "file" "/file_3") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" it "each on an array selecting each value - function call style" $ do- c <- getCatalog "$a = [1,2,3]\n each ($a) |$index, $v| {\n file { \"/file_$v\": ensure => present }\n }"+ c <- mgetCatalog "$a = [1,2,3]\n each ($a) |$index, $v| {\n file { \"/file_$v\": ensure => present }\n }" getResource (RIdentifier "file" "/file_1") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" getResource (RIdentifier "file" "/file_2") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" getResource (RIdentifier "file" "/file_3") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" it "each on an array with index" $ do- c <- getCatalog "$a = [present, absent, present]\n $a.each |$k,$v| {\n file { \"/file_$k\": ensure => $v }\n }"+ c <- mgetCatalog "$a = [present, absent, present]\n $a.each |$k,$v| {\n file { \"/file_$k\": ensure => $v }\n }" getResource (RIdentifier "file" "/file_0") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" getResource (RIdentifier "file" "/file_1") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "absent" getResource (RIdentifier "file" "/file_2") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" it "each on a hash selecting entries" $ do- c <- getCatalog "$a = {'a'=>'present','b'=>'absent','c'=>'present'}\n $a.each |$e| {\n $num = $e[0]\n file { \"/file_${num}\": ensure => $e[1] }\n }"+ c <- mgetCatalog "$a = {'a'=>'present','b'=>'absent','c'=>'present'}\n $a.each |$e| {\n $num = $e[0]\n file { \"/file_${num}\": ensure => $e[1] }\n }" getResource (RIdentifier "file" "/file_a") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" getResource (RIdentifier "file" "/file_b") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "absent" getResource (RIdentifier "file" "/file_c") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" it "each on a hash selecting key and value" $ do- c <- getCatalog "$a = {'a'=>present,'b'=>absent,'c'=>present}\n $a.each |$k, $v| {\n file { \"/file_$k\": ensure => $v }\n }"+ c <- mgetCatalog "$a = {'a'=>present,'b'=>absent,'c'=>present}\n $a.each |$k, $v| {\n file { \"/file_$k\": ensure => $v }\n }" getResource (RIdentifier "file" "/file_a") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" getResource (RIdentifier "file" "/file_b") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "absent" getResource (RIdentifier "file" "/file_c") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" it "each on a hash selecting key and value (using captures-last parameter)" $ do pending- c <- getCatalog "$a = {'a'=>present,'b'=>absent,'c'=>present}\n $a.each |*$kv| {\n file { \"/file_${kv[0]}\": ensure => $kv[1] }\n }"+ c <- mgetCatalog "$a = {'a'=>present,'b'=>absent,'c'=>present}\n $a.each |*$kv| {\n file { \"/file_${kv[0]}\": ensure => $kv[1] }\n }" getResource (RIdentifier "file" "/file_a") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" getResource (RIdentifier "file" "/file_b") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "absent" getResource (RIdentifier "file" "/file_c") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present" describe "should produce receiver" $ it "each checking produced value using single expression" $ do pending- c <- getCatalog "$a = [1, 3, 2]\n $b = $a.each |$x| { \"unwanted\" }\n $u = $b[1]\n file { \"/file_${u}\":\n ensure => present\n }"+ c <- mgetCatalog "$a = [1, 3, 2]\n $b = $a.each |$x| { \"unwanted\" }\n $u = $b[1]\n file { \"/file_${u}\":\n ensure => present\n }" getResource (RIdentifier "file" "/file_3") c >>= getAttribute "ensure" >>= \a -> a `shouldBe` "present"
+ tests/Function/JoinKeysToValuesSpec.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedLists #-}+module Function.JoinKeysToValuesSpec (spec) where++import Test.Hspec++import qualified Data.Foldable as F+import Data.Monoid++import Puppet.Interpreter.Pure+import Puppet.Interpreter.Types++import Helpers++spec :: Spec+spec = withStdlibFunction "join_keys_to_values" $ \jkvFunc -> it "Should work as expected" $ do+ let eval h s = case dummyEval (jkvFunc [PHash h, PString s]) of+ Left rr -> Left (spretty (getError rr))+ Right (PArray vals) -> Right (F.toList vals)+ Right v -> Left ("Expected an array, not: " <> spretty v)+ eval [] "" `shouldBe` Right []+ eval [] ":" `shouldBe` Right []+ eval [("key","value")] "" `shouldBe` Right ["keyvalue"]+ eval [("key","value")] ":" `shouldBe` Right ["key:value"]+ eval [("key",PUndef)] ":" `shouldBe` Right ["key:"]+ case eval [("key1","value1"),("key2","value2")] ":" of+ Left rr -> fail rr+ Right lst -> lst `shouldMatchList` ["key1:value1", "key2:value2"]
tests/Function/MergeSpec.hs view
@@ -11,8 +11,9 @@ import Puppet.Interpreter.Pure import Puppet.Interpreter.Types import Puppet.PP-import Puppet.Stdlib +import Helpers+ main :: IO () main = hspec spec @@ -23,10 +24,7 @@ _ -> Left ("Expected a string, not " <> PrettyError (pretty pv)) spec :: Spec-spec = do- mergeFunc <- case HM.lookup "merge" stdlibFunctions of- Just f -> return f- Nothing -> fail "Don't know the size function"+spec = withStdlibFunction "merge" $ \mergeFunc -> do let evalArgs' = evalArgs . mergeFunc let check args res = case evalArgs' (map PHash args) of Left rr -> expectationFailure (show rr)
tests/Function/SizeSpec.hs view
@@ -4,15 +4,15 @@ import Test.Hspec import Control.Monad-import qualified Data.HashMap.Strict as HM import Data.Monoid import Data.Scientific import Puppet.Interpreter.Pure import Puppet.Interpreter.Types import Puppet.PP-import Puppet.Stdlib +import Helpers+ main :: IO () main = hspec spec @@ -23,10 +23,7 @@ _ -> Left ("Expected a string, not " <> PrettyError (pretty pv)) spec :: Spec-spec = do- sizeFunc <- case HM.lookup "size" stdlibFunctions of- Just f -> return f- Nothing -> fail "Don't know the size function"+spec = withStdlibFunction "size" $ \sizeFunc -> do let evalArgs' = evalArgs . sizeFunc let check args res = case evalArgs' args of Left rr -> expectationFailure (show rr)
tests/Helpers.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE FlexibleContexts #-} module Helpers ( compileCatalog , getCatalog , getResource , getAttribute , spretty+ , withStdlibFunction ) where import Puppet.Interpreter (computeCatalog)@@ -12,22 +14,25 @@ import Puppet.Parser import Puppet.Parser.Types import Puppet.PP+import Puppet.Stdlib import Control.Lens+import Control.Monad.Except import qualified Data.HashMap.Strict as HM import qualified Data.Maybe.Strict as S import Data.Text (Text, unpack)+import Test.Hspec -compileCatalog :: Monad m => Text -> m (FinalCatalog, EdgeMap, FinalCatalog, [Resource], InterpreterState)+compileCatalog :: MonadError String m => Text -> m (FinalCatalog, EdgeMap, FinalCatalog, [Resource], InterpreterState) compileCatalog input = do- statements <- either (fail . show) return (runPParser "dummy" input)+ statements <- either (throwError . show) return (runPParser "dummy" input) let nodename = "node.fqdn" sttmap = [( (TopNode, nodename), NodeDeclaration (NodeDecl (NodeName nodename) statements S.Nothing (initialPPos "dummy")) ) ] (res, finalState, _) = pureEval dummyFacts sttmap (computeCatalog nodename)- (catalog,em,exported,defResources) <- either (fail . show) return res+ (catalog,em,exported,defResources) <- either (throwError . show) return res return (catalog,em,exported,defResources,finalState) -getCatalog :: Monad m => Text -> m FinalCatalog+getCatalog :: MonadError String m => Text -> m FinalCatalog getCatalog = fmap (view _1) . compileCatalog spretty :: Pretty a => a -> String@@ -40,4 +45,10 @@ getAttribute att res = case res ^? rattributes . ix att of Nothing -> fail ("Unknown attribute: " ++ unpack att) Just x -> return x++withStdlibFunction :: Text -> ( ([PValue] -> InterpreterMonad PValue) -> Spec ) -> Spec+withStdlibFunction fname testsuite =+ case stdlibFunctions ^? ix fname of+ Just f -> testsuite f+ Nothing -> fail ("Don't know this function: " ++ show fname)
+ tests/Interpreter/CollectorSpec.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE OverloadedLists #-}+-- | Directly ported from puppet specs+module Interpreter.CollectorSpec (spec) where++import Test.Hspec++import Control.Lens+import Control.Monad.Except+import Data.Text (Text)+import qualified Data.Text as T++import Helpers+import Puppet.Interpreter.Types+++shouldNotify :: [Text] -> [PValue] -> Expectation+shouldNotify content expectedMessages = do+ cat <- case runExcept (getCatalog (T.unlines content)) of+ Left rr -> fail rr+ Right x -> return x+ let messages = itoList cat ^.. folded . filtered (\rp -> rp ^. _1 . itype == "notify") . _2 . rattributes . ix "message"+ messages `shouldMatchList` expectedMessages++shouldFail :: [Text] -> Expectation+shouldFail content = let cat :: Either String FinalCatalog+ cat = runExcept (getCatalog (T.unlines content))+ in cat `shouldSatisfy` has _Left++spec :: Spec+spec = do+ it "matches everything when no query given" $+ [ "@notify { 'testing': message => 'the message' }"+ , "@notify { 'other': message => 'the other message' }"+ , "Notify <| |>"+ ] `shouldNotify` ["the other message", "the message"]+ it "matches regular resources" $+ [ "notify { \"testing\": message => \"the message\" }"+ , "notify { \"other\": message => \"the other message\" }"+ , "Notify <| |> { message => \"changed\" }"+ ] `shouldNotify` ["changed", "changed"]+ it "matches on tags" $+ [ "@notify { \"testing\": tag => [\"one\"], message => \"wanted\" }"+ , "@notify { \"other\": tag => [\"two\"], message => \"unwanted\" }"+ , "Notify <| tag == one |>"+ ] `shouldNotify` ["wanted"]+ it "matches on title" $+ [ "@notify { \"testing\": message => \"the message\" }"+ , "Notify <| title == \"testing\" |>"+ ] `shouldNotify` ["the message"]+ it "matches on other parameters" $+ [ "@notify { \"testing\": message => \"the message\" }"+ , "@notify { \"other testing\": message => \"the wrong message\" }"+ , "Notify <| message == \"the message\" |>"+ ] `shouldNotify` ["the message"]+ it "matches against elements of an array valued parameter" $+ [ "@notify { \"testing\": message => [\"the\", \"message\"] }"+ , "@notify { \"other testing\": message => [\"not\", \"here\"] }"+ , "Notify <| message == \"message\" |>"+ ] `shouldNotify` [PArray ["the", "message"]]+ it "matches with bare word" $+ [ "@notify { \"testing\": tag => [\"one\"], message => \"wanted\" }"+ , "Notify <| tag == one |>"+ ] `shouldNotify` ["wanted"]+ it "matches with single quoted string" $+ [ "@notify { \"testing\": tag => [\"one\"], message => \"wanted\" }"+ , "Notify <| tag == 'one' |>"+ ] `shouldNotify` ["wanted"]+ it "matches with double quoted string" $+ [ "@notify { \"testing\": tag => [\"one\"], message => \"wanted\" }"+ , "Notify <| tag == \"one\" |>"+ ] `shouldNotify` ["wanted"]+ it "matches with double quoted string with interpolated expression" $+ [ "@notify { \"testing\": tag => [\"one\"], message => \"wanted\" }"+ , "$x = 'one'"+ , "Notify <| tag == \"$x\" |>"+ ] `shouldNotify` ["wanted"]+ it "matches with resource references" $ do+ pending+ shouldNotify [ "@notify { \"foobar\": }"+ , "@notify { \"testing\": require => Notify[\"foobar\"], message => \"wanted\" }"+ , "Notify <| require == Notify[\"foobar\"] |>"+ ]+ ["wanted"]+ it "allows criteria to be combined with 'and'" $+ [ "@notify { \"testing\": message => \"the message\" }"+ , "@notify { \"other\": message => \"the message\" }"+ , "Notify <| title == \"testing\" and message == \"the message\" |>"+ ] `shouldNotify` ["the message"]+ it "allows criteria to be combined with 'or'" $+ [ "@notify { \"testing\": message => \"the message\" }"+ , "@notify { \"other\": message => \"other message\" }"+ , "@notify { \"yet another\": message => \"different message\" }"+ , "Notify <| title == \"testing\" or message == \"other message\" |>"+ ] `shouldNotify` ["the message", "other message"]+ it "allows criteria to be grouped with parens" $+ [ "@notify { \"testing\": message => \"different message\", withpath => true }"+ , "@notify { \"other\": message => \"the message\" }"+ , "@notify { \"yet another\": message => \"the message\", withpath => true }"+ , "Notify <| (title == \"testing\" or message == \"the message\") and withpath == true |>"+ ] `shouldNotify` ["the message", "different message"]+ it "does not do anything if nothing matches" $+ [ "@notify { \"testing\": message => \"different message\" }"+ , "Notify <| title == \"does not exist\" |>"+ ] `shouldNotify` []+ it "excludes items with inequalities" $+ [ "@notify { \"testing\": message => \"good message\" }"+ , "@notify { \"the wrong one\": message => \"bad message\" }"+ , "Notify <| title != \"the wrong one\" |>"+ ] `shouldNotify` ["good message"]+ it "does not exclude resources with unequal arrays" $+ [ "@notify { \"testing\": message => \"message\" }"+ , "@notify { \"the wrong one\": message => [\"not this message\", \"or this one\"] }"+ , "Notify <| message != \"not this message\" |>"+ ] `shouldNotify` ["message", PArray ["not this message", "or this one"]]+ it "does not exclude tags with inequalities" $+ [ "@notify { \"testing\": tag => [\"wanted\"], message => \"wanted message\" }"+ , "@notify { \"other\": tag => [\"why\"], message => \"the way it works\" }"+ , "Notify <| tag != \"why\" |>"+ ] `shouldNotify` ["wanted message", "the way it works"]+ it "does not collect classes" $ shouldFail $+ [ "class theclass {"+ , " @notify { \"testing\": message => \"good message\" }"+ , "}"+ , "Class <| |>"+ ]+ it "does not collect resources that don't exist" $ do+ pending+ shouldFail $+ [ "class theclass {"+ , " @notify { \"testing\": message => \"good message\" }"+ , "}"+ , "SomeResource <| |>"+ ]+ it "modifies an existing array" $+ [ "@notify { \"testing\": message => [\"original message\"] }"+ , "Notify <| |> {"+ , " message +> \"extra message\""+ , "}"] `shouldNotify` [PArray ["original message", "extra message"]]+ it "converts a scalar to an array" $+ [ "@notify { \"testing\": message => \"original message\" }"+ , "Notify <| |> {"+ , " message +> \"extra message\""+ , "}"] `shouldNotify` [PArray ["original message", "extra message"]]+ it "collects and overrides virtual resources multiple times using multiple collects" $+ [ "@notify { \"testing\": message => \"original\" }"+ , "Notify <| |> { message => 'overridden1' }"+ , "Notify <| |> { message => 'overridden2' }"+ ] `shouldNotify` ["overridden2"]+ it "collects and overrides non virtual resources multiple times using multiple collects" $+ [ "notify { \"testing\": message => \"original\" }"+ , "Notify <| |> { message => 'overridden1' }"+ , "Notify <| |> { message => 'overridden2' }"+ ] `shouldNotify` ["overridden2"]
tests/InterpreterSpec.hs view
@@ -1,4 +1,4 @@-module InterpreterSpec (collectorSpec, main) where+module InterpreterSpec (collectorSpec, classIncludeSpec, main) where import Control.Lens import Data.HashMap.Strict (HashMap)@@ -57,8 +57,18 @@ it "should override the 'groups' attributes from the user resource" $ getResAttr (computeWith AssignArrow) ^. at "groups" `shouldBe` Just (PArray $ V.fromList ["docker"]) +classIncludeSpec :: Spec+classIncludeSpec = do+ let compute i = pureCompute "dummy" i ^. _1+ describe "Multiple loading" $ do+ it "should work when using several include statements" $ compute (T.unlines [ "node 'dummy' {", "include foo", "include foo", "}" ]) `shouldSatisfy` (has _Right)+ it "should work when using class before include" $ compute (T.unlines [ "node 'dummy' {", "class { 'foo': }", "include foo", "}" ]) `shouldSatisfy` (has _Right)+ it "should fail when using include before class" $ compute (T.unlines [ "node 'dummy' {", "include foo", "class { 'foo': }", "}" ]) `shouldSatisfy` (has _Left)+ main :: IO ()-main = hspec collectorSpec+main = hspec $ do+ describe "Collectors" collectorSpec+ describe "Class inclusion" classIncludeSpec -- | Given a node and raw text input to be parsed, compute the manifest in a dummy setting. pureCompute :: NodeName@@ -71,7 +81,9 @@ hush = either (error . show) id getStatement :: NodeName -> Text -> HashMap (TopLevelType, NodeName) Statement- getStatement n i = HM.singleton (TopNode, n) (nodeStatement i)+ getStatement n i = HM.fromList [ ((TopNode, n), nodeStatement i)+ , ((TopClass, "foo"), ClassDeclaration $ ClassDecl mempty mempty mempty mempty (initialPPos "dummy"))+ ] nodeStatement :: Text -> Statement nodeStatement i = V.head $ hush $ parse (puppetParser <* eof) "test" i
tests/Spec.hs view
@@ -1,19 +1,28 @@ import Test.Hspec 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 Function.AssertPrivateSpec+import qualified Function.JoinKeysToValuesSpec main :: IO () main = hspec spec spec :: Spec spec = do- describe "Interpreter" InterpreterSpec.collectorSpec- describe "The shellquote function" Function.ShellquoteSpec.spec+ describe "Interpreter" $ do+ describe "Collector" InterpreterSpec.collectorSpec+ describe "Class include" InterpreterSpec.classIncludeSpec+ describe "Collector (puppet tests)" Interpreter.CollectorSpec.spec+ describe "Puppet functions" $ do+ describe "The shellquote function" Function.ShellquoteSpec.spec+ describe "The each function" Function.EachSpec.spec describe "stdlib functions" $ do- describe "The size function" Function.SizeSpec.spec- describe "The merge function" Function.MergeSpec.spec- describe "The each function" Function.EachSpec.spec+ describe "The assert_private function" Function.AssertPrivateSpec.spec+ describe "The join_keys_to_values function" Function.JoinKeysToValuesSpec.spec+ describe "The merge function" Function.MergeSpec.spec+ describe "The size function" Function.SizeSpec.spec
tests/expr.hs view
@@ -1,8 +1,5 @@ module Main where -import Control.Arrow (first)-import Control.Monad-import Data.Maybe import qualified Data.Text as T import Data.Tuple.Strict import qualified Data.Vector as V@@ -11,6 +8,9 @@ import Puppet.Parser.Types import Text.Megaparsec +import Test.Hspec+import Test.Hspec.Megaparsec+ testcases :: [(T.Text, Expression)] testcases = [ ("5 + 3 * 2", 5 + 3 * 2)@@ -29,13 +29,6 @@ ] main :: IO ()-main = do- let testres = map (first (parse (expression <* eof) "tests")) testcases- isFailure (Left x, _) = Just (show x)- isFailure (Right x, e) = if x == e- then Nothing- else Just ("Expected: " ++ show e ++ "\nActual: " ++ show x)- bads = mapMaybe isFailure testres- unless (null bads) $ do- mapM_ putStrLn bads- error "failed"+main = hspec $ describe "Expression parser" $ mapM_ test testcases+ where+ test (t,e) = it ("should parse " ++ show t) $ parse (expression <* eof) "" t `shouldParse` e
tests/hiera.hs view
@@ -9,11 +9,13 @@ import qualified Data.Vector as V import qualified Data.HashMap.Strict as HM import qualified Data.Text as T+import qualified System.Log.Logger as LOG import Puppet.Interpreter.Types main :: IO () main = withSystemTempDirectory "hieratest" $ \tmpfp -> do+ LOG.updateGlobalLogger hieraLoggerName (LOG.setLevel LOG.ERROR) let ndname = "node.site.com" vars = HM.fromList [ ("::environment", "production") , ("::fqdn" , ndname)