diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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 diff --git a/Puppet/Interpreter.hs b/Puppet/Interpreter.hs --- a/Puppet/Interpreter.hs +++ b/Puppet/Interpreter.hs @@ -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:" diff --git a/Puppet/Interpreter/Resolve.hs b/Puppet/Interpreter/Resolve.hs --- a/Puppet/Interpreter/Resolve.hs +++ b/Puppet/Interpreter/Resolve.hs @@ -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. diff --git a/Puppet/Interpreter/Utils.hs b/Puppet/Interpreter/Utils.hs --- a/Puppet/Interpreter/Utils.hs +++ b/Puppet/Interpreter/Utils.hs @@ -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 #-} diff --git a/Puppet/NativeTypes/Helpers.hs b/Puppet/NativeTypes/Helpers.hs --- a/Puppet/NativeTypes/Helpers.hs +++ b/Puppet/NativeTypes/Helpers.hs @@ -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 diff --git a/Puppet/NativeTypes/Notify.hs b/Puppet/NativeTypes/Notify.hs --- a/Puppet/NativeTypes/Notify.hs +++ b/Puppet/NativeTypes/Notify.hs @@ -10,6 +10,6 @@ parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])] parameterfunctions = - [("message" , [string]) + [("message" , []) ,("withpath" , [string, defaultvalue "false", values ["true","false"]]) ] diff --git a/Puppet/Parser.hs b/Puppet/Parser.hs --- a/Puppet/Parser.hs +++ b/Puppet/Parser.hs @@ -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 diff --git a/Puppet/Stdlib.hs b/Puppet/Stdlib.hs --- a/Puppet/Stdlib.hs +++ b/Puppet/Stdlib.hs @@ -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) diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet -version: 1.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 diff --git a/tests/Function/AssertPrivateSpec.hs b/tests/Function/AssertPrivateSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Function/AssertPrivateSpec.hs @@ -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") diff --git a/tests/Function/EachSpec.hs b/tests/Function/EachSpec.hs --- a/tests/Function/EachSpec.hs +++ b/tests/Function/EachSpec.hs @@ -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" diff --git a/tests/Function/JoinKeysToValuesSpec.hs b/tests/Function/JoinKeysToValuesSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Function/JoinKeysToValuesSpec.hs @@ -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"] diff --git a/tests/Function/MergeSpec.hs b/tests/Function/MergeSpec.hs --- a/tests/Function/MergeSpec.hs +++ b/tests/Function/MergeSpec.hs @@ -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) diff --git a/tests/Function/SizeSpec.hs b/tests/Function/SizeSpec.hs --- a/tests/Function/SizeSpec.hs +++ b/tests/Function/SizeSpec.hs @@ -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) diff --git a/tests/Helpers.hs b/tests/Helpers.hs --- a/tests/Helpers.hs +++ b/tests/Helpers.hs @@ -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) diff --git a/tests/Interpreter/CollectorSpec.hs b/tests/Interpreter/CollectorSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Interpreter/CollectorSpec.hs @@ -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"] diff --git a/tests/InterpreterSpec.hs b/tests/InterpreterSpec.hs --- a/tests/InterpreterSpec.hs +++ b/tests/InterpreterSpec.hs @@ -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 diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -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 diff --git a/tests/expr.hs b/tests/expr.hs --- a/tests/expr.hs +++ b/tests/expr.hs @@ -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 diff --git a/tests/hiera.hs b/tests/hiera.hs --- a/tests/hiera.hs +++ b/tests/hiera.hs @@ -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)