diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,10 @@ +# v1.3.11 (2017/10/07) + +* Added yera command +* Minor fixes to the validate_integer function, and to the mount resource +* Support for the "lookup" command in hiera files +* Fix Glob compilation problem + # v1.3.10 (2017/08/28) * Add `sort` stdlib function diff --git a/Erb/Ruby.hs b/Erb/Ruby.hs --- a/Erb/Ruby.hs +++ b/Erb/Ruby.hs @@ -55,4 +55,3 @@ | DropPrevSpace' | DropNextSpace !RubyStatement deriving(Show,Eq) - diff --git a/Hiera/Server.hs b/Hiera/Server.hs --- a/Hiera/Server.hs +++ b/Hiera/Server.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {- | This module runs a Hiera server that caches Hiera data. There is a huge caveat : only the data files are watched for changes, not the main configuration file. @@ -19,8 +20,9 @@ ) where import Control.Applicative -import Control.Exception import Control.Lens +import Control.Monad.Except +import Control.Monad.Trans.Reader import Control.Monad.Writer.Strict import Data.Aeson (FromJSON, Value (..), (.!=), (.:?)) import qualified Data.Aeson as A @@ -29,9 +31,9 @@ import qualified Data.ByteString.Lazy as BS import qualified Data.Either.Strict as S import qualified Data.FileCache as F -import qualified Data.HashMap.Strict as HM import qualified Data.List as L -import Data.Maybe (fromMaybe, catMaybes) +import Data.Maybe (catMaybes, mapMaybe) +import Data.String (fromString) import qualified Data.Text as T import qualified Data.Vector as V import qualified Data.Yaml as Y @@ -54,21 +56,29 @@ | JsonBackend FilePath deriving Show -newtype InterpolableHieraString = InterpolableHieraString [HieraStringPart] +newtype InterpolableHieraString = InterpolableHieraString { getInterpolableHieraString :: [HieraStringPart] } deriving Show -data HieraStringPart = HString T.Text - | HVariable T.Text +data HieraStringPart = HPString T.Text + | HPVariable T.Text deriving Show instance Pretty HieraStringPart where - pretty (HString t) = ttext t - pretty (HVariable v) = dullred (string "%{" <> ttext v <> string "}") + pretty (HPString t) = ttext t + pretty (HPVariable v) = dullred (string "%{" <> ttext v <> string "}") prettyList = mconcat . map pretty -type Cache = F.FileCacheR String Y.Value +type Cache = F.FileCacheR String Value +data QRead + = QRead + { _qvars :: Container T.Text + , _qtype :: HieraQueryType + , _qhier :: [Value] + } + makeClassy ''HieraConfigFile +makeLenses ''QRead instance FromJSON InterpolableHieraString where parseJSON (String s) = case parseInterpolableString s of @@ -91,12 +101,12 @@ return (backendConstructor (T.unpack datadir)) HieraConfigFile <$> (v .:? ":backends" .!= ["yaml"] >>= mapM genBackend) - <*> (v .:? ":hierarchy" .!= [InterpolableHieraString [HString "common"]]) + <*> (v .:? ":hierarchy" .!= [InterpolableHieraString [HPString "common"]]) parseJSON _ = fail "Not a valid Hiera configuration" -- | An attoparsec parser that turns text into parts that are ready for interpolation interpolableString :: AT.Parser [HieraStringPart] -interpolableString = AT.many1 (fmap HString rawPart <|> fmap HVariable interpPart) +interpolableString = AT.many1 (fmap HPString rawPart <|> fmap HPVariable interpPart) where rawPart = AT.takeWhile1 (/= '%') interpPart = AT.string "%{" *> AT.takeWhile1 (/= '}') <* AT.char '}' @@ -119,74 +129,106 @@ dummyHiera :: Monad m => HieraQueryFunc m dummyHiera _ _ _ = return $ S.Right Nothing --- | The combinator for "normal" queries -queryCombinator :: HieraQueryType -> [IO (Maybe PValue)] -> IO (Maybe PValue) -queryCombinator qt = fmap (createOutput . catMaybes) . sequence - where - createOutput :: [PValue] -> Maybe PValue - createOutput [] = Nothing - createOutput xs = case qt of - Priority -> return (head xs) - ArrayMerge -> return (rejoin xs) - HashMerge -> PHash . mconcat <$> mapM toH xs - rejoin = PArray . V.fromList . L.nub . concatMap toA - toA (PArray r) = V.toList r - toA a = [a] - toH (PHash h) = Just h - toH _ = Nothing +resolveString :: Container T.Text -> InterpolableHieraString -> Maybe T.Text +resolveString vars = fmap T.concat . mapM resolve . getInterpolableHieraString + where + resolve (HPString x) = Just x + resolve (HPVariable v) = vars ^? ix v -interpolateText :: Container T.Text -> T.Text -> T.Text -interpolateText vars t = fromMaybe t ((parseInterpolableString t ^? _Right) >>= resolveInterpolable vars) +query :: HieraConfigFile -> FilePath -> Cache -> HieraQueryFunc IO +query HieraConfigFile {_backends, _hierarchy} fp cache vars hquery qt = do + -- step 1, resolve hierarchies + let searchin = do + mhierarchy <- resolveString vars <$> _hierarchy + Just hier <- [mhierarchy] + backend <- _backends + let decodeInfo :: (FilePath -> IO (S.Either String Value), String, String) + decodeInfo + = case backend of + JsonBackend d -> (fmap (strictifyEither . A.eitherDecode') . BS.readFile , d, ".json") + YamlBackend d -> (fmap (strictifyEither . (_Left %~ show)) . Y.decodeFileEither, d, ".yaml") + return (decodeInfo, hier) + -- step 2, read all the files, returning a raw data structure + mvals <- forM searchin $ \((decodefunction, datadir, extension), hier) -> do + let filename = basedir <> datadir <> "/" <> T.unpack hier <> extension + basedir = case datadir of + '/' : _ -> mempty + _ -> fp ^. directory <> "/" + efilecontent <- F.query cache filename (decodefunction filename) + case efilecontent of + S.Left r -> do + let errs = "Hiera: error when reading file " <> string filename <+> string r + if "Yaml file not found: " `L.isInfixOf` r + then LOG.debugM hieraLoggerName (show errs) + else LOG.warningM hieraLoggerName (show errs) + return Nothing + S.Right val -> return (Just val) + let vals = catMaybes mvals + -- step 3, query through all the results + return (strictifyEither $ runReader (runExceptT (recursiveQuery hquery [])) (QRead vars qt vals)) -resolveInterpolable :: Container T.Text -> [HieraStringPart] -> Maybe T.Text -resolveInterpolable vars = fmap T.concat . mapM resolvePart - where - resolvePart :: HieraStringPart -> Maybe T.Text - resolvePart (HString x) = Just x - resolvePart (HVariable v) = vars ^. at v +type QM a = ExceptT PrettyError (Reader QRead) a -interpolatePValue :: Container T.Text -> PValue -> PValue -interpolatePValue v (PHash h) = PHash . HM.fromList . map ( (_1 %~ interpolateText v) . (_2 %~ interpolatePValue v) ) . HM.toList $ h -interpolatePValue v (PArray r) = PArray (fmap (interpolatePValue v) r) -interpolatePValue v (PString t) = PString (interpolateText v t) -interpolatePValue _ x = x +checkLoop :: T.Text -> [T.Text] -> QM () +checkLoop x xs = + when (x `elem` xs) (throwError ("Loop in hiera: " <> fromString (T.unpack (T.intercalate ", " (x:xs))))) -query :: HieraConfigFile -> FilePath -> Cache -> HieraQueryFunc IO -query (HieraConfigFile {_backends, _hierarchy}) fp cache vars hquery qtype = - fmap S.Right (queryCombinator qtype (map query' _hierarchy)) `catch` (\e -> return . S.Left . PrettyError . string . show $ (e :: SomeException)) - where - varlist = hcat (L.intersperse comma (map (dullblue . ttext) (L.sort (HM.keys vars)))) - query' :: InterpolableHieraString -> IO (Maybe PValue) - query' (InterpolableHieraString strs) = - case resolveInterpolable vars strs of - Just s -> queryCombinator qtype (map (query'' s) _backends) - Nothing -> do - LOG.infoM hieraLoggerName (show $ "Hiera lookup: skipping using hierarchy level" <+> pretty strs - <$$> "It couldn't be interpolated with known variables:" <+> varlist) - return Nothing - query'' :: T.Text -> Backend -> IO (Maybe PValue) - query'' hierastring backend = do - let (decodefunction, datadir, extension) = case backend of - (JsonBackend d) -> (fmap (strictifyEither . A.eitherDecode') . BS.readFile , d, ".json") - (YamlBackend d) -> (fmap (strictifyEither . (_Left %~ show)) . Y.decodeFileEither, d, ".yaml") - filename = basedir <> datadir <> "/" <> T.unpack hierastring <> extension - where - basedir = case datadir of - '/' : _ -> mempty - _ -> fp^.directory <> "/" - mfromJSON :: Maybe Value -> IO (Maybe PValue) - mfromJSON Nothing = return Nothing - mfromJSON (Just v) = case A.fromJSON v of - A.Success a -> return (Just (interpolatePValue vars a)) - _ -> do - LOG.warningM hieraLoggerName (show $ "Hiera:" <+> dullred "could not convert this Value to a Puppet type" <> ":" <+> string (show v)) - return Nothing - v <- liftIO (F.query cache filename (decodefunction filename)) - case v of - S.Left r -> do - let errs = "Hiera: error when reading file " <> string filename <+> string r - if "Yaml file not found: " `L.isInfixOf` r - then LOG.debugM hieraLoggerName (show errs) - else LOG.warningM hieraLoggerName (show errs) - return Nothing - S.Right x -> mfromJSON (x ^? key hquery) +recursiveQuery :: T.Text -> [T.Text] -> QM (Maybe PValue) +recursiveQuery curquery prevqueries = do + checkLoop curquery prevqueries + rawlookups <- mapMaybe (preview (key curquery)) <$> view qhier + lookups <- mapM (resolveValue (curquery : prevqueries)) rawlookups + case lookups of + [] -> return Nothing + (x:xs) -> do + qt <- view qtype + let evalue = foldM (mergeWith qt) x xs + case A.fromJSON <$> evalue of + Left _ -> return Nothing + Right (A.Success o) -> return o + Right (A.Error rr) -> throwError ("Something horrible happened in recursiveQuery: " <> fromString (show rr)) + +resolveValue :: [T.Text] -> Value -> QM Value +resolveValue prevqueries value = + case value of + String t -> String <$> resolveText prevqueries t + Array arr -> Array <$> mapM (resolveValue prevqueries) arr + Object hh -> Object <$> mapM (resolveValue prevqueries) hh + _ -> return value + +resolveText :: [T.Text] -> T.Text -> QM T.Text +resolveText prevqueries t + = case parseInterpolableString t of + Right qparts -> T.concat <$> mapM (resolveStringPart prevqueries) qparts + Left _ -> return t + +resolveStringPart :: [T.Text] -> HieraStringPart -> QM T.Text +resolveStringPart prevqueries sp + = case sp of + HPString s -> return s + HPVariable varname -> do + let varsolve = fmap PString . preview (ix varname) <$> view qvars + r <- case T.stripPrefix "lookup('" varname >>= T.stripSuffix "')" of + Just lk -> recursiveQuery lk prevqueries + Nothing -> varsolve + case r of + Just (PString v) -> return v + _ -> return mempty + +mergeWith :: HieraQueryType -> Value -> Value -> Either PrettyError Value +mergeWith qt cur new + = case qt of + QFirst -> return cur + QUnique -> + let getArray x = case x of + Array array -> V.toList array + _ -> [x] + curarray = getArray cur + newarray = getArray new + in case new of + Object _ -> throwError "Tried to merge a hash" + _ -> return (Array (V.fromList (L.nub (curarray ++ newarray)))) + QHash -> case (cur, new) of + (Object curh, Object newh) -> return (Object (curh <> newh)) + _ -> throwError (PrettyError ("Tried to merge things that are not hashes: " <> text (show cur) <+> text (show new))) + QDeep{} -> throwError "deep queries not supported" diff --git a/Puppet/Interpreter.hs b/Puppet/Interpreter.hs --- a/Puppet/Interpreter.hs +++ b/Puppet/Interpreter.hs @@ -575,7 +575,7 @@ checkHiera :: T.Text -> ExceptT (Max Bool) InterpreterMonad PValue checkHiera k = case wHiera of S.Nothing -> throwE (Max False) - S.Just classname -> lift (runHiera (classname <> "::" <> k) Priority) >>= checkUndef + S.Just classname -> lift (runHiera (classname <> "::" <> k) QFirst) >>= checkUndef checkDef :: T.Text -> ExceptT (Max Bool) InterpreterMonad PValue checkDef k = checkUndef (params ^. at k) @@ -805,7 +805,7 @@ "class" -> {-# SCC "rrClass" #-} do definedResources . at resid ?= r let attrs = r ^. rattributes - fmap (r:) $ loadClass rn S.Nothing attrs ClassResourceLike + (r:) <$> loadClass rn S.Nothing attrs ClassResourceLike _ -> {-# SCC "rrGeneralCase" #-} use (definedResources . at resid) >>= \case Just otheres -> throwPosError ("Resource" <+> pretty resid <+> "already defined:" @@ -870,7 +870,7 @@ mainFunctionCall "fail" _ = throwPosError "fail(): This function takes a single argument" mainFunctionCall "hiera_include" [x] = do ndname <- resolvePValueString x - classes <- toListOf (traverse . _PArray . traverse) <$> runHiera ndname ArrayMerge + classes <- toListOf (traverse . _PArray . traverse) <$> runHiera ndname QUnique p <- use curPos curPos . _1 . lSourceName <>= " [hiera_include call]" o <- mainFunctionCall "include" classes diff --git a/Puppet/Interpreter/Resolve.hs b/Puppet/Interpreter/Resolve.hs --- a/Puppet/Interpreter/Resolve.hs +++ b/Puppet/Interpreter/Resolve.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PackageImports #-} -- | This module is all about converting and resolving foreign data into -- the fully exploitable corresponding data type. The main use case is the -- conversion of 'Expression' to 'PValue'. @@ -28,13 +29,15 @@ hfRestorevars, toNumbers, fixResourceName, - datatypeMatch + datatypeMatch, + -- * Synonym + NumberPair ) where import Control.Lens import Control.Monad import Control.Monad.Operational (singleton) -import Crypto.Hash +import "cryptonite" Crypto.Hash import Data.Aeson hiding ((.=)) import Data.Aeson.Lens hiding (key) import Data.Bits @@ -76,12 +79,10 @@ md5 :: ByteString -> ByteString md5 = convert . (hash :: ByteString -> Digest MD5) --- | A useful type that is used when trying to perform arithmetic on Puppet --- numbers. +-- | A useful type that is used when trying to perform arithmetic on Puppet numbers. type NumberPair = Pair Scientific Scientific --- | Converts class resource names to lowercase (fix for the jenkins --- plugin). +-- | Converts class resource names to lowercase (fix for the jenkins plugin). fixResourceName :: T.Text -- ^ Resource type -> T.Text -- ^ Resource name -> T.Text @@ -117,7 +118,7 @@ Just d -> return d Nothing -> throwPosError ("Lookup for " <> ttext qs <> " failed") --- | Tries to convert a pair of 'PValue's into 'Number's, as defined in +-- | Tries to convert a pair of 'PValue's into a 'NumberPair', as defined in -- attoparsec. If the two values can be converted, it will convert them so -- that they are of the same type toNumbers :: PValue -> PValue -> S.Maybe NumberPair @@ -130,7 +131,7 @@ -- | This tries to run a numerical binary operation on two puppet -- expressions. It will try to resolve them, then convert them to numbers --- (using 'toNumbners'), and will finally apply the correct operation. +-- (using 'toNumbers'), and will finally apply the correct operation. binaryOperation :: Expression -- ^ left operand -> Expression -- ^ right operand -> (Scientific -> Scientific -> Scientific) -- ^ operation @@ -428,7 +429,7 @@ checkStrict "The use of the 'defined' function is a code smell." "The 'defined' function is not allowed in strict mode." t <- resolvePValueString ut - if (not (T.null t) && T.head t == '$') -- variable test + if not (T.null t) && T.head t == '$' -- variable test then do scps <- use scopes scp <- getScopeName @@ -489,7 +490,7 @@ escapeDangerous x | isDangerous x = T.snoc "\\" x | otherwise = T.singleton x between c s = c <> s <> c - return $ PString $ T.unwords $ V.toList $ fmap escape $ mconcat sargs + return $ PString $ T.unwords $ V.toList (escape <$> mconcat sargs) resolveFunction' "mysql_password" [pstr] = fmap (PString . T.decodeUtf8 . B16.encode . sha1 . sha1 . T.encodeUtf8) (resolvePValueString pstr) resolveFunction' "mysql_password" _ = throwPosError "mysql_password(): Expects a single argument" @@ -529,15 +530,15 @@ resolveFunction' "pdbresourcequery" [q] = pdbresourcequery q Nothing resolveFunction' "pdbresourcequery" [q,k] = fmap Just (resolvePValueString k) >>= pdbresourcequery q resolveFunction' "pdbresourcequery" _ = throwPosError "pdbresourcequery(): Expects one or two arguments" -resolveFunction' "hiera" [q] = hieraCall Priority q Nothing Nothing -resolveFunction' "hiera" [q,d] = hieraCall Priority q (Just d) Nothing -resolveFunction' "hiera" [q,d,o] = hieraCall Priority q (Just d) (Just o) -resolveFunction' "hiera_array" [q] = hieraCall ArrayMerge q Nothing Nothing -resolveFunction' "hiera_array" [q,d] = hieraCall ArrayMerge q (Just d) Nothing -resolveFunction' "hiera_array" [q,d,o] = hieraCall ArrayMerge q (Just d) (Just o) -resolveFunction' "hiera_hash" [q] = hieraCall HashMerge q Nothing Nothing -resolveFunction' "hiera_hash" [q,d] = hieraCall HashMerge q (Just d) Nothing -resolveFunction' "hiera_hash" [q,d,o] = hieraCall HashMerge q (Just d) (Just o) +resolveFunction' "hiera" [q] = hieraCall QFirst q Nothing Nothing +resolveFunction' "hiera" [q,d] = hieraCall QFirst q (Just d) Nothing +resolveFunction' "hiera" [q,d,o] = hieraCall QFirst q (Just d) (Just o) +resolveFunction' "hiera_array" [q] = hieraCall QUnique q Nothing Nothing +resolveFunction' "hiera_array" [q,d] = hieraCall QUnique q (Just d) Nothing +resolveFunction' "hiera_array" [q,d,o] = hieraCall QUnique q (Just d) (Just o) +resolveFunction' "hiera_hash" [q] = hieraCall QHash q Nothing Nothing +resolveFunction' "hiera_hash" [q,d] = hieraCall QHash q (Just d) Nothing +resolveFunction' "hiera_hash" [q,d,o] = hieraCall QHash q (Just d) (Just o) resolveFunction' "hiera" _ = throwPosError "hiera(): Expects one, two or three arguments" -- user functions @@ -614,14 +615,14 @@ checkSearchExpression (REqualitySearch attributename v) r = case r ^. rattributes . at attributename of Nothing -> False - Just (PArray x) -> F.any (flip puppetEquality v) x + Just (PArray x) -> F.any (`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 (PArray x) -> not (F.all (`puppetEquality` v) x) Just x -> not (puppetEquality x v) -- | Generates variable associations for evaluation of blocks. Each item diff --git a/Puppet/Interpreter/Resolve/Sprintf.hs b/Puppet/Interpreter/Resolve/Sprintf.hs --- a/Puppet/Interpreter/Resolve/Sprintf.hs +++ b/Puppet/Interpreter/Resolve/Sprintf.hs @@ -1,7 +1,9 @@ -module Puppet.Interpreter.Resolve.Sprintf where +module Puppet.Interpreter.Resolve.Sprintf ( + sprintf +) where import Control.Applicative -import Control.Monad +import Control.Monad.Except import Data.Attoparsec.Text import Data.Scientific (Scientific) import qualified Data.Text as T @@ -141,4 +143,3 @@ go [] [] = return [] go _ [] = throwPosError "sprintf: not enough arguments" go [] _ = [] <$ let msg = "sprintf: too many arguments" in checkStrict msg msg - diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -8,6 +8,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} + module Puppet.Interpreter.Types ( -- * Record & lenses HasResource(..) @@ -84,8 +85,7 @@ , EdgeMap -- * Classes , MonadThrowPos(..) - , MonadError(..) - -- * definitions + -- * Definitions , metaparameters , showPos ) where @@ -176,20 +176,25 @@ _ -> Left p toNumber p = Left p --- | The different kind of hiera queries -data HieraQueryType = Priority -- ^ standard hiera query - | ArrayMerge -- ^ hiera_array - | HashMerge -- ^ hiera_hash +-- | The different kind of hiera queries. +data HieraQueryType + = QFirst -- ^ standard hiera query + | QUnique -- ^ hiera_array + | QHash -- ^ hiera_hash + | QDeep + { _knockoutPrefix :: Maybe Text + , _sortMerged :: Bool + , _mergeHashArray :: Bool + } deriving (Show) --- | The type of the Hiera API function +-- | The type of the Hiera API function. type HieraQueryFunc m = Container Text -- ^ All the variables that Hiera can interpolate, the top level ones being prefixed with :: -> Text -- ^ The query -> HieraQueryType -> m (S.Either PrettyError (Maybe PValue)) -- | The intepreter can run in two modes : a strict mode (recommended), and --- a permissive mode. The permissive mode let known antipatterns work with --- the interpreter. +-- a permissive mode. data Strictness = Strict | Permissive deriving (Show, Eq) @@ -206,13 +211,12 @@ deriving (Show, Eq) -- | Puppet has two main ways to declare classes: include-like and resource-like --- https://docs.puppetlabs.com/puppet/latest/reference/lang_classes.html#include-like-vs-resource-like +-- See data ClassIncludeType = ClassIncludeLike -- ^ using the include or contain function | ClassResourceLike -- ^ resource like declaration deriving (Eq) --- |This type is used to differenciate the distinct top level types that are --- exposed by the DSL. +-- | This type is used to differenciate the distinct top level types that are exposed by the DSL. data TopLevelType -- |This is for node entries. = TopNode @@ -250,7 +254,7 @@ | SEChild !Text -- ^ We enter the scope as the child of another class | SEParent !Text -- ^ We enter the scope as the parent of another class --- | TODO related to Scope: explain ... +-- TODO related to Scope: explain ... data CurContainer = CurContainer { _cctype :: !CurContainerDesc , _cctags :: !(HS.HashSet Text) @@ -334,6 +338,7 @@ -- | The main monad type InterpreterMonad = ProgramT InterpreterInstr (State InterpreterState) + instance MonadError PrettyError InterpreterMonad where throwError = singleton . ErrorThrow catchError a c = singleton (ErrorCatch a c) @@ -416,7 +421,9 @@ -- See data PuppetEdge = PuppetEdge RIdentifier RIdentifier LinkType deriving Show --- | Wire format, see . +-- | Wire format +-- +-- See . data WireCatalog = WireCatalog { _wireCatalogNodename :: !NodeName , _wireCatalogVersion :: !Text diff --git a/Puppet/Lens.hs b/Puppet/Lens.hs --- a/Puppet/Lens.hs +++ b/Puppet/Lens.hs @@ -11,8 +11,7 @@ , _PResourceReference , _PUndef , _PArray - -- * Parsing prism - -- * Lenses and Prisms for 'Statement's + -- * Lenses and prims for 'Statement's , _Statements , _ResDecl , _ResDefaultDecl @@ -26,7 +25,7 @@ , _MainFuncDecl , _HigherOrderLambdaDecl , _DepDecl - -- * Lenses and Prisms for 'Expression's + -- * Prim for 'Expression's , _Equal , _Different , _Not @@ -57,19 +56,29 @@ import Control.Lens +import Puppet.Parser (puppetParser) import Puppet.Parser.Types import Puppet.Interpreter.Types import Puppet.Interpreter.Pure import Puppet.Interpreter.Resolve +import qualified Puppet.Parser.PrettyPrinter() import qualified Data.Vector as V import qualified Data.HashMap.Strict as HM import Data.Tuple.Strict hiding (uncurry) import Control.Exception (SomeException, toException, fromException) +import qualified Data.Text as T +import Text.PrettyPrint.ANSI.Leijen (pretty) ---makePrisms ''Statement +import Text.Megaparsec (parse) + makePrisms ''Expression +_PuppetParser :: Prism' T.Text (V.Vector Statement) +_PuppetParser = prism' (T.pack . unlines . V.toList . fmap (show . pretty)) $ \t -> case parse puppetParser "dummy" t of + Left _ -> Nothing + Right r -> Just r + _PrettyError :: Prism' SomeException PrettyError _PrettyError = prism' toException fromException @@ -152,8 +161,6 @@ toU (PHash h) = UHash (V.fromList $ map (\(k,v) -> (Terminal (UString k) :!: Terminal (toU v))) $ HM.toList h) toU (PType _) = error "TODO, _PResolveValue PType undefined" --- | Extracts the statements from 'ClassDeclaration', 'DefineDeclaration', --- 'Node' and the spurious statements of 'TopContainer'. _Statements :: Lens' Statement [Statement] _Statements = lens (V.toList . sget) (\s v -> sset s (V.fromList v)) where diff --git a/Puppet/NativeTypes/Helpers.hs b/Puppet/NativeTypes/Helpers.hs --- a/Puppet/NativeTypes/Helpers.hs +++ b/Puppet/NativeTypes/Helpers.hs @@ -4,7 +4,6 @@ module Puppet.NativeTypes.Helpers ( module Puppet.PP , ipaddr - -- smart constructor for NativeTypeMethods , nativetypemethods , paramname , rarray @@ -57,6 +56,7 @@ perror :: Doc -> Either PrettyError Resource perror = Left . PrettyError +-- | Smart constructor for 'NativeTypeMethods'. nativetypemethods :: [(T.Text, [T.Text -> NativeTypeValidate])] -> NativeTypeValidate -> NativeTypeMethods nativetypemethods def extraV = let params = fromKeys def @@ -98,7 +98,7 @@ newparams p = HM.filter def $ HM.union p defaults defaults = HM.empty --- | Helper function that runs a validor on a PArray +-- | Helper function that runs a validor on a 'PArray' runarray :: T.Text -> (T.Text -> PValue -> NativeTypeValidate) -> NativeTypeValidate runarray param func res = case res ^. rattributes . at param of Just (PArray x) -> V.foldM (flip (func param)) res x @@ -146,8 +146,8 @@ defaultvalue :: T.Text -> T.Text -> NativeTypeValidate defaultvalue value param = Right . over (rattributes . at param) (Just . fromMaybe (PString value)) --- | Checks that a given parameter, if set, is a 'ResolvedInt'. If it is a --- 'PString' it will attempt to parse it. +-- | Checks that a given parameter, if set, is a 'ResolvedInt'. +-- If it is a 'PString' it will attempt to parse it. integer :: T.Text -> NativeTypeValidate integer prm res = string prm res >>= integer' prm where @@ -163,8 +163,8 @@ Just v -> Right (res & rattributes . at param ?~ PNumber (fromIntegral v)) _ -> perror $ "Parameter" <+> paramname param <+> "must be an integer" --- | Copies the "name" value into the parameter if this is not set. It implies --- the `string` validator. +-- | Copies the "name" value into the parameter if this is not set. +-- It implies the `string` validator. nameval :: T.Text -> NativeTypeValidate nameval prm res = string prm res >>= \r -> case r ^. rattributes . at prm of diff --git a/Puppet/NativeTypes/Mount.hs b/Puppet/NativeTypes/Mount.hs --- a/Puppet/NativeTypes/Mount.hs +++ b/Puppet/NativeTypes/Mount.hs @@ -11,10 +11,10 @@ parameterfunctions = [("atboot" , [string, values ["true","false"]]) ,("blockdevice" , [string]) - ,("device" , [string, mandatory]) + ,("device" , [string, mandatoryIfNotAbsent]) ,("dump" , [integer, inrange 0 2]) ,("ensure" , [defaultvalue "present", string, values ["present","absent","mounted"]]) - ,("fstype" , [string, mandatory]) + ,("fstype" , [string, mandatoryIfNotAbsent]) ,("name" , [nameval]) ,("options" , [string]) ,("pass" , [defaultvalue "0", integer]) diff --git a/Puppet/NativeTypes/User.hs b/Puppet/NativeTypes/User.hs --- a/Puppet/NativeTypes/User.hs +++ b/Puppet/NativeTypes/User.hs @@ -7,7 +7,8 @@ nativeUser :: (NativeTypeName, NativeTypeMethods) nativeUser = ("user", nativetypemethods parameterfunctions return) --- Autorequires: If Puppet is managing the user or user that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. +-- Autorequires: If Puppet is managing the user or user that owns a file, the file resource will autorequire them. +-- If Puppet is managing any parent directories of a file, the file resource will autorequire them. parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])] parameterfunctions = [("allowdupe" , [string, defaultvalue "false", values ["true","false"]]) diff --git a/Puppet/NativeTypes/ZoneRecord.hs b/Puppet/NativeTypes/ZoneRecord.hs --- a/Puppet/NativeTypes/ZoneRecord.hs +++ b/Puppet/NativeTypes/ZoneRecord.hs @@ -9,7 +9,8 @@ nativeZoneRecord :: (NativeTypeName, NativeTypeMethods) nativeZoneRecord = ("zone_record", nativetypemethods parameterfunctions validateMandatories) --- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. +-- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. +-- If Puppet is managing any parent directories of a file, the file resource will autorequire them. parameterfunctions :: [(T.Text, [T.Text -> NativeTypeValidate])] parameterfunctions = [("name" , [nameval]) diff --git a/Puppet/PP.hs b/Puppet/PP.hs --- a/Puppet/PP.hs +++ b/Puppet/PP.hs @@ -19,7 +19,7 @@ prettyToShow :: Doc -> String prettyToShow d = displayS (renderCompact d) "" --- | A rendering function that drops colors: +-- | A rendering function that drops colors. displayNocolor :: Doc -> String displayNocolor = flip displayS "" . dropEffects . renderPretty 0.4 180 where diff --git a/Puppet/Parser.hs b/Puppet/Parser.hs --- a/Puppet/Parser.hs +++ b/Puppet/Parser.hs @@ -1,9 +1,11 @@ {-# LANGUAGE TupleSections #-} + {-| Parse puppet source code from text. -} module Puppet.Parser ( -- * Runner runPParser -- * Parsers + , Parser , puppetParser , expression , datatype @@ -558,6 +560,7 @@ -- | Heterogeneous chain (interleaving resource declarations with -- resource references)needs to be supported: +-- -- class { 'docker::service': } -> -- Class['docker'] chainableResources :: Parser [Statement] diff --git a/Puppet/Parser/Types.hs b/Puppet/Parser/Types.hs --- a/Puppet/Parser/Types.hs +++ b/Puppet/Parser/Types.hs @@ -48,6 +48,9 @@ DefineDecl(..), NodeDecl(..), VarAssignDecl(..), + vadname, + vadpos, + vadvalue, MainFuncDecl(..), HigherOrderLambdaDecl(..), ResCollDecl(..) @@ -73,7 +76,7 @@ import Text.Megaparsec.Pos import Text.Regex.PCRE.String --- | Properly capitalizes resource types +-- | Properly capitalizes resource types. capitalizeRT :: Text -> Text capitalizeRT = T.intercalate "::" . map capitalize' . T.splitOn "::" where @@ -108,7 +111,7 @@ let p = (initialPos (T.unpack fl)) { sourceLine = mkPos $ fromIntegral (max 1 ln) } in (p :!: p) --- | High Order "lambdas" +-- | /High Order lambdas/. data LambdaFunc = LambEach | LambMap @@ -119,6 +122,7 @@ deriving (Eq, Show) -- | Lambda block parameters: +-- -- Currently only two types of block parameters are supported: -- single values and pairs. data LambdaParameters @@ -285,10 +289,10 @@ deriving (Eq, Show) data Virtuality - = Normal -- ^ Normal resource, that will be included in the catalog - | Virtual -- ^ Type for virtual resources - | Exported -- ^ Type for exported resources - | ExportedRealized -- ^ These are resources that are exported AND included in the catalogderiving (Generic, Eq, Show) + = Normal -- ^ Normal resource, that will be included in the catalog. + | Virtual -- ^ Type for virtual resources. + | Exported -- ^ Type for exported resources. + | ExportedRealized -- ^ These are resources that are exported AND included in the catalogderiving (Generic, Eq, Show). deriving (Eq, Show) data NodeDesc @@ -322,43 +326,60 @@ instance ToJSON LinkType where toJSON = String . rel2text --- | Resource declaration: e.g `file { mode => 755}` +-- | Resource declaration: +-- +-- @ file { mode => 755} @ data ResDecl = ResDecl !Text !Expression !(V.Vector AttributeDecl) !Virtuality !PPosition deriving (Eq, Show) --- | Resource default: e.g `File { mode => 755 }` --- https://docs.puppetlabs.com/puppet/latest/reference/lang_defaults.html#language:-resource-default-statements +-- | Resource default: +-- +-- @ File { mode => 755 } @ +-- +-- . data ResDefaultDecl = ResDefaultDecl !Text !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show) --- | Resource override: e.g `File['title'] { mode => 755}` --- https://docs.puppetlabs.com/puppet/latest/reference/lang_resources_advanced.html#amending-attributes-with-a-resource-reference +-- | Resource override: +-- +-- @ File['title'] { mode => 755} @ +-- +-- See . data ResOverrideDecl = ResOverrideDecl !Text !Expression !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show) --- | All types of conditional statements (@case@, @if@, etc.) are stored as an ordered list of pair (condition, statements) --- (interpreted as "if first cond is true, choose first statements, else take the next pair, check the condition ...") +-- | All types of conditional statements : @case@, @if@, ... +-- +-- Stored as an ordered list of pair @ (condition, statements) @. +-- Interpreted as "if first cond is true, choose first statements, else take the next pair, check the condition ..." data ConditionalDecl = ConditionalDecl !(V.Vector (Pair Expression (V.Vector Statement))) !PPosition deriving (Eq, Show) data ClassDecl = ClassDecl !Text !(V.Vector (Pair (Pair Text (S.Maybe DataType)) (S.Maybe Expression))) !(S.Maybe Text) !(V.Vector Statement) !PPosition deriving (Eq, Show) data DefineDecl = DefineDecl !Text !(V.Vector (Pair (Pair Text (S.Maybe DataType)) (S.Maybe Expression))) !(V.Vector Statement) !PPosition deriving (Eq, Show) --- | A node is a collection of statements + maybe an inherit node +-- | A node is a collection of statements + maybe an inherit node. data NodeDecl = NodeDecl !NodeDesc !(V.Vector Statement) !(S.Maybe NodeDesc) !PPosition deriving (Eq, Show) --- | e.g $newvar = 'world' -data VarAssignDecl = VarAssignDecl !Text !Expression !PPosition deriving (Eq, Show) +-- | @ $newvar = 'world' @ +data VarAssignDecl + = VarAssignDecl + { _vadname :: !Text + , _vadvalue :: !Expression + , _vadpos :: !PPosition + } deriving (Eq, Show) data MainFuncDecl = MainFuncDecl !Text !(V.Vector Expression) !PPosition deriving (Eq, Show) -- | /Higher order function/ call. data HigherOrderLambdaDecl = HigherOrderLambdaDecl !HOLambdaCall !PPosition deriving (Eq, Show) --- | Resource Collector including exported collector (`<<| |>>`) --- e.g `User <| title == 'jenkins' |> { groups +> "docker"}` --- https://docs.puppetlabs.com/puppet/latest/reference/lang_collectors.html#language:-resource-collectors +-- | Resource Collector including exported collector (`\<\<| |>>`) +-- +-- @ User \<| title == 'jenkins' |> { groups +> "docker"} @ +-- +-- See data ResCollDecl = ResCollDecl !CollectorType !Text !SearchExpression !(V.Vector AttributeDecl) !PPosition deriving (Eq, Show) data DepDecl = DepDecl !(Pair Text Expression) !(Pair Text Expression) !LinkType !PPosition deriving (Eq, Show) --- | All the possible statements +-- | All possible statements. data Statement = ResourceDeclaration !ResDecl | ResourceDefaultDeclaration !ResDefaultDecl @@ -376,5 +397,5 @@ deriving (Eq, Show) makeClassy ''HOLambdaCall +makeLenses ''VarAssignDecl $(deriveToJSON defaultOptions ''DataType) - diff --git a/Puppet/Stdlib.hs b/Puppet/Stdlib.hs --- a/Puppet/Stdlib.hs +++ b/Puppet/Stdlib.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE PatternGuards #-} module Puppet.Stdlib (stdlibFunctions) where import Control.Applicative @@ -27,6 +28,7 @@ import Puppet.Interpreter.Types import Puppet.Interpreter.Utils import Puppet.PP +import Puppet.Utils (text2Scientific) -- | Contains the implementation of the StdLib functions. stdlibFunctions :: Container ( [PValue] -> InterpreterMonad PValue ) @@ -484,10 +486,12 @@ validateInteger :: [PValue] -> InterpreterMonad PValue validateInteger [] = throwPosError "validate_integer(): wrong number of arguments, must be > 0" -validateInteger x = mapM_ vb x >> return PUndef +validateInteger x = PUndef <$ mapM_ vb x where msg d = pretty d <+> "is not an integer." - vb (PNumber n) = unless (Scientific.isInteger n) $ throwPosError (msg (show n)) + check n = unless (Scientific.isInteger n) $ throwPosError (msg (show n)) + vb (PNumber n) = check n + vb (PString s) | Just n <- text2Scientific s = check n vb a = throwPosError (msg a) pvalues :: PValue -> InterpreterMonad PValue diff --git a/PuppetDB/Common.hs b/PuppetDB/Common.hs --- a/PuppetDB/Common.hs +++ b/PuppetDB/Common.hs @@ -49,7 +49,7 @@ Nothing -> fmap Right initTestDB -- | Turns a 'FinalCatalog' and 'EdgeMap' into a document that can be --- serialized and fed to @puppet apply@. + -- serialized and fed to @puppet apply@. generateWireCatalog :: NodeName -> FinalCatalog -> EdgeMap -> WireCatalog generateWireCatalog node cat edgemap = WireCatalog node "version" edges resources "uiid" where diff --git a/PuppetDB/Dummy.hs b/PuppetDB/Dummy.hs --- a/PuppetDB/Dummy.hs +++ b/PuppetDB/Dummy.hs @@ -2,6 +2,7 @@ -- responses. module PuppetDB.Dummy where +import Control.Monad.Except import Puppet.Interpreter.Types dummyPuppetDB :: Monad m => PuppetDBAPI m diff --git a/README.adoc b/README.adoc --- a/README.adoc +++ b/README.adoc @@ -12,13 +12,21 @@ puppetresources -p /where/your/puppet/files/are -o node.name.com ``` -.Easy build instructions: +.Quick install instruction with stack ```bash +stack install language-puppet +``` + +.Build instructions: +```bash git clone https://github.com/bartavelle/language-puppet.git cd language-puppet -# Add ~/.local/bin to $PATH -ln -s stack-8.0.yaml stack.yaml -stack install +# Using nix +cabal2nix . > default.nix +nix-build shell.nix # or nix-shell +# Using stack +ln -s stack-9.yaml stack.yaml +stack build ``` == Puppetresources diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet -version: 1.3.10 +version: 1.3.11 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/ @@ -195,7 +195,7 @@ ghc-options: -Wall -rtsopts -funbox-strict-fields -threaded -with-rtsopts "-A2M" -eventlog -- ghc-prof-options: -auto-all -caf-all -fprof-auto build-depends: base - , Glob + , Glob < 0.9 , aeson , bytestring , containers @@ -215,6 +215,19 @@ , unordered-containers , vector main-is: PuppetResources.hs + +executable yera + hs-source-dirs: progs + extensions: BangPatterns, OverloadedStrings + ghc-options: -Wall -rtsopts -threaded + build-depends: base + , language-puppet + , optparse-applicative + , text + , strict-base-types + , ansi-wl-pprint + , unordered-containers + main-is: yera.hs executable pdbquery hs-source-dirs: progs diff --git a/progs/PuppetResources.hs b/progs/PuppetResources.hs --- a/progs/PuppetResources.hs +++ b/progs/PuppetResources.hs @@ -38,7 +38,7 @@ import qualified Facter import Puppet.Daemon import Puppet.Lens -import Puppet.Parser +import Puppet.Parser hiding (Parser) import Puppet.Parser.PrettyPrinter (ppStatements) import Puppet.Parser.Types import Puppet.Preferences diff --git a/progs/yera.hs b/progs/yera.hs new file mode 100644 --- /dev/null +++ b/progs/yera.hs @@ -0,0 +1,59 @@ +module Main (main) where + +import Options.Applicative +import Data.Monoid +import qualified Data.Text as T +import qualified Data.Either.Strict as S +import qualified Data.HashMap.Strict as HM +import Text.PrettyPrint.ANSI.Leijen (pretty) + +import Puppet.Interpreter.Types +import Puppet.Interpreter.PrettyPrinter() +import Hiera.Server + +data Config + = Config + { _filepath :: FilePath + , _query :: String + , _queryType :: HieraQueryType + , _variables :: [(T.Text,T.Text)] + } + +readQT :: String -> Maybe HieraQueryType +readQT s + = case s of + "first" -> Just QFirst + "unique" -> Just QUnique + "hash" -> Just QHash + _ -> Nothing + +parseVariable :: String -> Either String (T.Text, T.Text) +parseVariable s = + case break (=='=') s of + ([], []) -> Left "Empty variable" + ([], _) -> Left "Nothing on the left side of the = symbol" + (_, []) -> Left "Nothing on the right side of the = symbol" + (var, '=':val) -> Right (T.pack var, T.pack val) + _ -> Left "???" + +configParser :: Parser Config +configParser = Config <$> strOption (long "config" <> short 'c' <> metavar "CONFIG" <> value "hiera.yaml") + <*> strOption (long "query" <> short 'q' <> metavar "QUERY") + <*> option (maybeReader readQT) (long "querytype" <> short 't' <> metavar "QUERYTYPE" <> value QFirst <> help "values: first (default), unique, hash") + <*> many (argument (eitherReader parseVariable) (metavar "VARIABLE" <> help "Variables, in the form key=value")) + +configInfo :: ParserInfo Config +configInfo = info (configParser <**> helper) mempty + +main :: IO () +main = do + Config fp query qtype vars <- execParser configInfo + ehiera <- startHiera fp + case ehiera of + Left rr -> error rr + Right hiera -> do + r <- hiera (HM.fromList vars) (T.pack query) qtype + case r of + S.Left rr -> error (show rr) + S.Right Nothing -> putStrLn "no match" + S.Right (Just res) -> print (pretty res) diff --git a/tests/Helpers.hs b/tests/Helpers.hs --- a/tests/Helpers.hs +++ b/tests/Helpers.hs @@ -17,6 +17,7 @@ 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) @@ -50,4 +51,3 @@ case stdlibFunctions ^? ix fname of Just f -> testsuite f Nothing -> fail ("Don't know this function: " ++ show fname) - diff --git a/tests/hiera.hs b/tests/hiera.hs --- a/tests/hiera.hs +++ b/tests/hiera.hs @@ -34,26 +34,26 @@ let checkOutput v (S.Right x) = x @?= v checkOutput _ (S.Left rr) = assertFailure (show rr) hspec $ do - describe "lookup data without a key" $ do - it "returns an error when called with an empty string" $ q mempty "" Priority >>= checkOutput Nothing + describe "lookup data without a key" $ + it "returns an error when called with an empty string" $ q mempty "" QFirst >>= checkOutput Nothing describe "lookup data without a valid key" $ do - it "returns an error when called with a non existent key [Priority]" $ q mempty "foo" Priority >>= checkOutput Nothing - it "returns an error when called with a non existent key [ArrayMerge]" $ q mempty "foo" ArrayMerge >>= checkOutput Nothing - it "returns an error when called with a non existent key [HashMerge]" $ q mempty "foo" HashMerge >>= checkOutput Nothing + it "returns an error when called with a non existent key [QFirst]" $ q mempty "foo" QFirst >>= checkOutput Nothing + it "returns an error when called with a non existent key [QUnique]" $ q mempty "foo" QUnique >>= checkOutput Nothing + it "returns an error when called with a non existent key [QHash]" $ q mempty "foo" QHash >>= checkOutput Nothing describe "lookup data with no options" $ do - it "can get string data" $ q mempty "http_port" Priority >>= checkOutput (Just (PNumber 8080)) - it "can get arrays" $ q mempty "ntp_servers" Priority >>= checkOutput (Just (PArray (V.fromList ["0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"]))) - it "can get hashes" $ q mempty "users" Priority >>= checkOutput (Just (PHash users)) + it "can get string data" $ q mempty "http_port" QFirst >>= checkOutput (Just (PNumber 8080)) + it "can get arrays" $ q mempty "ntp_servers" QFirst >>= checkOutput (Just (PArray (V.fromList ["0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"]))) + it "can get hashes" $ q mempty "users" QFirst >>= checkOutput (Just (PHash users)) describe "lookup data with a scope" $ do - it "overrides some values" $ q vars "http_port" Priority >>= checkOutput (Just (PNumber 9090)) - it "doesn't fail on others" $ q vars "global" Priority >>= checkOutput (Just "glob") - describe "json backend" $ do - it "resolves in json" $ q vars "testjson" Priority >>= checkOutput (Just "ok") + it "overrides some values" $ q vars "http_port" QFirst >>= checkOutput (Just (PNumber 9090)) + it "doesn't fail on others" $ q vars "global" QFirst >>= checkOutput (Just "glob") + describe "json backend" $ + it "resolves in json" $ q vars "testjson" QFirst >>= checkOutput (Just "ok") describe "deep interpolation" $ do - it "resolves in strings" $ q vars "interp1" Priority >>= checkOutput (Just (PString ("**" <> ndname <> "**"))) - it "resolves in objects" $ q vars "testnode" Priority >>= checkOutput (Just (PHash (HM.fromList [("1",PString ("**" <> ndname <> "**")),("2",PString "nothing special")]))) - it "resolves in arrays" $ q vars "arraytest" Priority >>= checkOutput (Just (PArray (V.fromList [PString "a", PString ndname, PString "c"]))) + it "resolves in strings" $ q vars "interp1" QFirst >>= checkOutput (Just (PString ("**" <> ndname <> "**"))) + it "resolves in objects" $ q vars "testnode" QFirst >>= checkOutput (Just (PHash (HM.fromList [("1",PString ("**" <> ndname <> "**")),("2",PString "nothing special")]))) + it "resolves in arrays" $ q vars "arraytest" QFirst >>= checkOutput (Just (PArray (V.fromList [PString "a", PString ndname, PString "c"]))) describe "other merge modes" $ do - it "catenates arrays" $ q vars "ntp_servers" ArrayMerge >>= checkOutput (Just (PArray (V.fromList ["2.ntp.puppetlabs.com","3.ntp.puppetlabs.com","0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"]))) - it "puts single values in arrays" $ q vars "http_port" ArrayMerge >>= checkOutput (Just (PArray (V.fromList [PNumber 9090, PNumber 8080]))) - it "merges hashes" $ q vars "users" HashMerge >>= checkOutput (Just (PHash (pusers <> users))) + it "catenates arrays" $ q vars "ntp_servers" QUnique >>= checkOutput (Just (PArray (V.fromList ["2.ntp.puppetlabs.com","3.ntp.puppetlabs.com","0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"]))) + it "puts single values in arrays" $ q vars "http_port" QUnique >>= checkOutput (Just (PArray (V.fromList [PNumber 9090, PNumber 8080]))) + it "merges hashes" $ q vars "users" QHash >>= checkOutput (Just (PHash (pusers <> users)))