diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,13 @@ language-puppet (1.4.5) artful; urgency=medium + * Add the `reduce` function. + * Change A hiera lookup using an unknown key will throw an error. + * Implement `alias` in hiera files. + * Fix #277 (hiera lookup in multiple layers) + * Allow servant 0.16 + + -- Pierre Radermecker Mo, 17 June 2019 16:12:48 +0100 + language-puppet (1.4.4) artful; urgency=medium * Add the `deep_merge` stdlib function. @@ -22,6 +30,8 @@ language-puppet (1.4.2) artful; urgency=medium * Bump upper version bounds for some haskell packages + + -- Pierre Radermecker Wed, 20 Feb 2019 21:32:48 +0100 language-puppet (1.4.1) artful; urgency=medium diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -15,7 +15,7 @@ **Install with nix:** ``` -nix-env -i -f https://github.com/bartavelle/language-puppet/tarball/v1.4.3 +nix-env -i -f https://github.com/bartavelle/language-puppet/tarball/v1.4.5 ``` (replace `1.4.3` with any commit ref or tag). 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.4.4 +version: 1.4.5 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, simulation of complex interactions between nodes, Puppet master replacement, and more ! homepage: http://lpuppet.banquise.net/ @@ -16,13 +16,15 @@ cabal-version: >=1.8 bug-reports: https://github.com/bartavelle/language-puppet/issues -Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4 +Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.4 extra-source-files: CHANGELOG README.md HLint.hs tests/hiera/*.yaml + tests/hiera/interpolate/config/*.yaml + tests/hiera/interpolate/data/*.yaml tests/hiera/*.com.json tests/Parser/lexer/*.pp @@ -96,49 +98,49 @@ extensions: OverloadedStrings, BangPatterns, LambdaCase, NoImplicitPrelude, FlexibleContexts, FlexibleInstances ghc-options: -Wall -funbox-strict-fields -- ghc-prof-options: -auto-all -caf-all - build-depends: aeson >= 0.8 + build-depends: aeson >= 1.0.0.0 && < 1.5 , ansi-wl-pprint >= 0.6.8 , attoparsec >= 0.12 - , base >=4.9 && < 5 + , base >=4.9 && < 5 , base16-bytestring == 0.1.* - , bytestring + , bytestring < 0.11 , case-insensitive == 1.2.* , containers >= 0.5 && < 0.7 , cryptonite >= 0.6 , directory >= 1.2 && < 1.4 , filecache >= 0.2.9 && < 0.5 , filepath >= 1.4 - , formatting + , formatting < 7 , hashable == 1.2.* - , http-api-data >= 0.2 && < 0.5 - , http-client >= 0.4.30 && < 0.7 - , hruby >= 0.3.2 && < 0.4 + , http-api-data >= 0.2 && < 0.5 + , http-client >= 0.4.30 && < 0.7 + , hruby >= 0.3.2 && < 0.4 , hslogger == 1.2.* , lens >= 4.12 && < 5 , lens-aeson >= 1.0 , megaparsec >= 7 && < 8 - , memory >= 0.7 + , memory >= 0.14 && < 0.15 , mtl >= 2.2.1 && < 2.3 , operational >= 0.2.3 && < 0.3 , parsec == 3.1.* , parser-combinators == 1.* , pcre-utils >= 0.1.7 && < 0.2 - , protolude >= 0.2 + , protolude >= 0.2 && < 0.3 , random , regex-pcre-builtin >= 0.94.4 - , scientific >= 0.2 && < 0.4 - , servant >= 0.9 && < 0.16 - , servant-client >= 0.9 && < 0.16 + , scientific >= 0.2 && < 0.4 + , servant >= 0.9 && < 0.17 + , servant-client >= 0.9 && < 0.17 , split == 0.2.* - , stm >= 2.4 && < 2.6 + , stm >= 2.4 && < 2.6 , strict-base-types >= 0.3 - , text >= 0.11 - , time >= 1.5 && < 2 - , transformers >= 0.4 && < 0.6 - , unix >= 2.7 && < 2.8 + , text >= 0.11 && < 1.3 + , time >= 1.5 && < 2 + , transformers >= 0.4 && < 0.6 + , unix >= 2.7 && < 2.8 , unordered-containers == 0.2.* - , vector >= 0.10 - , yaml >= 0.8.31 && < 0.12 + , vector >= 0.10 && < 0.13 + , yaml >= 0.8.31 && < 0.12 Test-Suite spec hs-source-dirs: tests type: exitcode-stdio-1.0 @@ -147,13 +149,13 @@ build-depends: base , Glob , hslogger - , hspec + , hspec >= 2.0 && < 3.0 , hspec-megaparsec , megaparsec , language-puppet - , lens - , mtl - , scientific + , lens >= 4.12 && < 5 + , mtl >= 2.2.1 && < 2.3 + , scientific >= 0.2 && < 0.4 , strict-base-types , text , temporary diff --git a/progs/yera.hs b/progs/yera.hs --- a/progs/yera.hs +++ b/progs/yera.hs @@ -5,12 +5,12 @@ import XPrelude hiding (option) -import qualified Data.Either.Strict as S import qualified Data.HashMap.Strict as Map import qualified Data.List as List import Options.Applicative import Hiera.Server +import Puppet.Language (PValue(..)) data Config = Config @@ -42,7 +42,7 @@ main = do Config fp query qtype vars <- execParser configInfo hiera <- startHiera "yera" fp - hiera (Map.fromList vars) (toS query) qtype >>= \case - S.Left rr -> panic (show rr) - S.Right Nothing -> die "no match" - S.Right (Just res) -> print (pretty res) + runExceptT (hiera (PString <$> Map.fromList vars) (toS query) qtype) >>= \case + Left rr -> panic (show rr) + Right Nothing -> die "no match" + Right (Just res) -> print (pretty res) diff --git a/src/Erb/Parser.hs b/src/Erb/Parser.hs --- a/src/Erb/Parser.hs +++ b/src/Erb/Parser.hs @@ -101,8 +101,10 @@ stringLiteral = Value `fmap` (doubleQuoted <|> singleQuoted) doubleQuoted :: Parser Value -doubleQuoted = Interpolable <$> between (char '"') (char '"') quoteInternal +doubleQuoted = simplify <$> between (char '"') (char '"') quoteInternal where + simplify [Value x] = x + simplify x = Interpolable x quoteInternal = many (basicContent <|> interpvar <|> escaped) escaped = char '\\' >> (Value . Literal . Text.singleton) `fmap` anyChar basicContent = (Value . Literal . Text.pack) `fmap` many1 (noneOf "\"\\#") diff --git a/src/Hiera/Server.hs b/src/Hiera/Server.hs --- a/src/Hiera/Server.hs +++ b/src/Hiera/Server.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} @@ -17,25 +18,30 @@ , HieraQueryType (..) , readQueryType , HieraQueryFunc + , varSplitter + , mergeWith ) where import XPrelude import Data.Aeson -import qualified Data.Aeson as Aeson +import qualified Data.Aeson as Aeson import Data.Aeson.Lens -import qualified Data.Attoparsec.Text as AT -import qualified Data.ByteString.Lazy as BS -import qualified Data.Either.Strict as S -import qualified Data.FileCache as Cache -import qualified Data.List as List -import Data.String (fromString) -import qualified Data.Text as Text -import qualified Data.Vector as Vector -import qualified Data.Yaml as Yaml -import qualified System.Directory as Directory -import qualified System.FilePath as FilePath -import System.FilePath.Lens (directory) +import qualified Data.Attoparsec.Text as AT +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BS8 +import qualified Data.Either.Strict as S +import qualified Data.FileCache as Cache +import qualified Data.List as List +import Data.String (fromString) +import qualified Data.Text as Text +import qualified Data.Vector as Vector +import qualified Data.Yaml as Yaml +import qualified System.Directory as Directory +import qualified System.FilePath as FilePath +import System.FilePath.Lens (directory) +import Text.Megaparsec (parse, sepBy1, Parsec, satisfy) +import Text.Megaparsec.Char (char) import Puppet.Language @@ -60,10 +66,10 @@ _ -> Nothing -- | The type of the Hiera API function associated to given hierarchy. -type HieraQueryFunc m = Container Text -- ^ Scope: all variables that Hiera can interpolate (the top level ones are prefixed with '::') +type HieraQueryFunc m = Container PValue -- ^ Scope: all variables that Hiera can interpolate (the top level ones are prefixed with '::') -> Text -- ^ The query -> HieraQueryType - -> m (S.Either PrettyError (Maybe PValue)) + -> ExceptT PrettyError m (Maybe PValue) data Backend = YamlBackend FilePath @@ -84,11 +90,23 @@ { getInterpolableHieraString :: [HieraStringPart] } deriving (Show) -resolveString :: Container Text -> InterpolableHieraString -> Maybe Text +varSplitter :: Text -> [Text] +varSplitter v = + case parse (vpart `sepBy1` char '.' :: Parsec Void Text [Text]) "dummy" v of + Left _ -> [v] + Right lst -> lst + where + vpart = squotev <|> dquotev <|> rawv + rawv = Text.pack <$> some (satisfy (/= '.')) + -- TODO, escapes + squotev = Text.pack <$> (char '\'' *> some (satisfy (/= '\'')) <* char '\'') + dquotev = Text.pack <$> (char '"' *> some (satisfy (/= '"')) <* char '"') + +resolveString :: Container PValue -> InterpolableHieraString -> Maybe Text resolveString vars = fmap Text.concat . mapM resolve . getInterpolableHieraString where resolve (HPString x) = Just x - resolve (HPVariable v) = vars ^? ix v + resolve (HPVariable v) = vars ^? ix v . _PString instance FromJSON InterpolableHieraString where parseJSON (String s) = case parseInterpolableString s of @@ -101,7 +119,7 @@ interpolableString = AT.many1 (fmap HPString rawPart <|> fmap HPVariable interpPart) where rawPart = AT.takeWhile1 (/= '%') - interpPart = AT.string "%{" *> AT.takeWhile1 (/= '}') <* AT.char '}' + interpPart = AT.string "%{" *> AT.takeWhile (/= '}') <* AT.char '}' parseInterpolableString :: Text -> Either String [HieraStringPart] parseInterpolableString = AT.parseOnly interpolableString @@ -113,7 +131,7 @@ } deriving (Show) data QRead = QRead - { _qvars :: Container Text + { _qvars :: Container PValue , _qtype :: HieraQueryType , _qhier :: [Value] } @@ -179,13 +197,14 @@ Left ex -> panic (show ex) Right cfg@HieraConfigFile{..} -> do logInfoStr ("Detect a hiera " <> layer <> " configuration format in " <> fp <> " at version " <> show _version) - cache <- Cache.newFileCache - pure (query cfg fp cache) + query cfg fp <$> Cache.newFileCache -- | A dummy hiera function that will be used when hiera is not detected. dummyHiera :: Monad m => HieraQueryFunc m -dummyHiera _ _ _ = return $ S.Right Nothing +dummyHiera _ _ _ = pure Nothing +exceptt :: Applicative m => Except r a -> ExceptT r m a +exceptt = ExceptT . pure . runExcept query :: HieraConfigFile -> FilePath -> Cache -> HieraQueryFunc IO query HieraConfigFile {_version, _backends, _hierarchy} fp cache vars hquery qt = do @@ -194,14 +213,14 @@ mhierarchy <- resolveString vars <$> _hierarchy Just h <- [mhierarchy] backend <- _backends - let decodeInfo :: (FilePath -> IO (S.Either String Value), String, String) + let decodeInfo :: (FilePath -> IO (Either String Value), String, String) decodeInfo = case backend of - JsonBackend dir -> (fmap (strictifyEither . Aeson.eitherDecode') . BS.readFile , dir, ".json") - YamlBackend dir -> (fmap (strictifyEither . (_Left %~ show)) . Yaml.decodeFileEither, dir, ".yaml") + JsonBackend dir -> (fmap Aeson.eitherDecode' . BS.readFile , dir, ".json") + YamlBackend dir -> (fmap (_Left %~ show) . Yaml.decodeFileEither, dir, ".yaml") pure (decodeInfo, toS h) -- step 2, read all the files, returning a raw data structure - mvals <- forM searchin $ \((decodefunction, datadir, extension), h) -> do + mvals <- liftIO $ forM searchin $ \((decodefunction, datadir, extension), h) -> do let extension' = if snd (FilePath.splitExtension h) == ".yaml" then "" else extension @@ -210,45 +229,68 @@ '/' : _ -> mempty _ -> fp ^. directory <> "/" querycache = do - efilecontent <- Cache.query cache filename (decodefunction filename) + efilecontent <- Cache.query cache filename (strictifyEither <$> decodefunction filename) case efilecontent of S.Left r -> do logWarningStr $ "Hiera: error when reading file " <> filename <> ": "<> r pure Nothing - S.Right val -> do - pure (Just val) + S.Right val -> pure (Just val) ifM (Directory.doesFileExist filename) querycache (pure Nothing) let vals = catMaybes mvals -- step 3, query through all the results - logDebugStr ("Looking up '" <> toS hquery <> "' with backends " <> List.unwords (fmap show _backends )) - return (strictifyEither $ runReader (runExceptT (recursiveQuery hquery [])) (QRead vars qt vals)) + liftIO $ logDebugStr ("Looking up '" <> toS hquery <> "' with backends " <> List.unwords (fmap show _backends )) + exceptt $ runReaderT (recursiveQuery hquery []) (QRead vars qt vals) -type QM a = ExceptT PrettyError (Reader QRead) a +type QM a = ReaderT QRead (Except PrettyError) a checkLoop :: Text -> [Text] -> QM () checkLoop x xs = when (x `elem` xs) (throwError ("Loop in hiera: " <> fromString (Text.unpack (Text.intercalate ", " (x:xs))))) +-- a helper function that removes prefix and suffix +textBetween :: Text -- ^ prefix + -> Text -- ^ suffix + -> Text + -> Maybe Text +textBetween pr su = Text.stripPrefix pr >=> Text.stripSuffix su + recursiveQuery :: Text -> [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 + let (varname:allkeys) = varSplitter curquery + checkLoop varname prevqueries + rawlookups <- mapMaybe (preview (key varname)) <$> view qhier + let lookupKeys keys v = + case keys of + [] -> pure v + k:ks -> + case v of + Object hs -> + case hs ^? ix k of + Nothing -> Nothing + Just v' -> lookupKeys ks v' + _ -> Nothing + rlookups <- mapM (resolveValue (varname : prevqueries)) rawlookups + let lookups = mapMaybe (lookupKeys allkeys) rlookups + case traverse Aeson.fromJSON lookups of + Aeson.Error rr -> throwError ("Something horrible happened in recursiveQuery: " <> fromString rr) + Aeson.Success [] -> + if null rlookups + then return Nothing + else throwError ("Could not lookup " <> fromString (Text.unpack curquery) <> " in " <> PrettyError (list (map (fromString . BS8.unpack . encode) rlookups)) ) + Aeson.Success (x:xs) -> do qt <- view qtype - let evalue = foldM (mergeWith qt) x xs - case Aeson.fromJSON <$> evalue of - Left _ -> return Nothing - Right (Aeson.Success o) -> return o - Right (Aeson.Error rr) -> throwError ("Something horrible happened in recursiveQuery: " <> fromString rr) + Just <$> foldM (mergeWith qt) x xs resolveValue :: [Text] -> Value -> QM Value resolveValue prevqueries value = case value of + String t | Just alias <- Text.stripPrefix "%{alias('" t >>= Text.stripSuffix "')}" -> do + mr <- recursiveQuery alias (("alias:" <> alias) : prevqueries) + case mr of + Nothing -> throwError ("Could not alias " <> fromString (Text.unpack alias)) + Just r -> pure (toJSON r) String t -> String <$> resolveText prevqueries t Array arr -> Array <$> mapM (resolveValue prevqueries) arr Object hh -> Object <$> mapM (resolveValue prevqueries) hh @@ -264,29 +306,42 @@ resolveStringPart prevqueries sp = case sp of HPString s -> return s + HPVariable "" -> return "" HPVariable varname -> do - let varsolve = fmap PString . preview (ix varname) <$> view qvars - r <- case Text.stripPrefix "lookup('" varname >>= Text.stripSuffix "')" of + let rc vars val = + case vars of + [] -> pure val + v:vs -> case val of + PHash m -> m ^? ix v >>= rc vs + _ -> Nothing + extractFunction txt = textBetween (txt <> "('") "')" varname + <|> textBetween (txt <> "(\"") "\")" varname + r <- case extractFunction "lookup" <|> extractFunction "hiera" <|> extractFunction "alias" of Just lk -> recursiveQuery lk prevqueries - Nothing -> varsolve + Nothing -> do + vmap <- view qvars + let mvar:svars = varSplitter varname + pure (vmap ^? ix mvar >>= rc svars) case r of Just (PString v) -> return v - _ -> return mempty + Just (PNumber s) -> pure (scientific2text s) + Just pvalue -> throwError (PrettyError ("Variable lookup for " <> fromString (Text.unpack varname) <> " did not return a string, but " <> pretty pvalue)) + _ -> throwError ("Could not lookup variable " <> fromString (Text.unpack varname)) -mergeWith :: HieraQueryType -> Value -> Value -> Either PrettyError Value +mergeWith :: MonadError PrettyError m => HieraQueryType -> PValue -> PValue -> m PValue mergeWith qt cur new = case qt of QFirst -> return cur QUnique -> let getArray x = case x of - Array array -> Vector.toList array + PArray array -> Vector.toList array _ -> [x] curarray = getArray cur newarray = getArray new in case new of - Object _ -> throwError "Tried to merge a hash" - _ -> return (Array (Vector.fromList (List.nub (curarray ++ newarray)))) + PHash _ -> throwError "Tried to merge a hash" + _ -> return (PArray (Vector.fromList (List.nub (curarray ++ newarray)))) QHash -> case (cur, new) of - (Object curh, Object newh) -> return (Object (curh <> newh)) + (PHash curh, PHash newh) -> return (PHash (curh <> newh)) _ -> throwError (PrettyError ("Tried to merge things that are not hashes: " <> ppline (show cur) <+> ppline (show new))) QDeep{} -> throwError "deep queries not supported" diff --git a/src/Puppet/Interpreter/Helpers.hs b/src/Puppet/Interpreter/Helpers.hs --- a/src/Puppet/Interpreter/Helpers.hs +++ b/src/Puppet/Interpreter/Helpers.hs @@ -152,6 +152,12 @@ isExternal = singleton . IsExternalModule . List.head . Text.splitOn "::" -- Logging -- +error :: MonadWriter InterpreterWriter m => Doc -> m () +error d = tell [Log.ERROR :!: d] + +critical :: MonadWriter InterpreterWriter m => Doc -> m () +critical d = tell [Log.CRITICAL :!: d] + warn :: MonadWriter InterpreterWriter m => Doc -> m () warn d = tell [Log.WARNING :!: d] diff --git a/src/Puppet/Interpreter/IO.hs b/src/Puppet/Interpreter/IO.hs --- a/src/Puppet/Interpreter/IO.hs +++ b/src/Puppet/Interpreter/IO.hs @@ -69,7 +69,8 @@ GetNativeTypes -> runInstr (r ^. readerNativeTypes) ErrorThrow d -> return (Left d, s, mempty) GetNodeName -> runInstr (r ^. readerNodename) - HieraQuery scps q t -> canFail (queryHiera (r ^. readerHieraQuery) scps q t) + HieraQuery scps q t -> + runExceptT (queryHiera (r ^. readerHieraQuery) scps q t) >>= either thpe runInstr PDBInformation -> pdbInformation pdb >>= runInstr PDBReplaceCatalog w -> canFailX (replaceCatalog pdb w) PDBReplaceFacts fcts -> canFailX (replaceFacts pdb fcts) @@ -91,25 +92,24 @@ Left rr -> interpretMonad r s (ahandle rr >>= k) Right x -> logStuff w (interpretMonad r s' (k x)) - -- query all hiera layers -queryHiera :: Monad m => HieraQueryLayers m -> Container Text -> Text -> HieraQueryType -> m (S.Either PrettyError (Maybe PValue)) +queryHiera :: Monad m + => HieraQueryLayers m + -> Container PValue + -> Text + -> HieraQueryType + -> ExceptT PrettyError m (Maybe PValue) queryHiera layers scps q t = do - val0 <- (layers^.globalLayer) scps q t - case val0 of - S.Right Nothing -> do - val1 <- (layers ^.environmentLayer) scps q t - case val1 of - S.Right Nothing -> query_modlayer - _ -> pure val1 - _ -> pure val0 - where - query_modlayer = do - let - modname = - case Text.splitOn "::" (Text.dropWhile (==':') q) of - [] -> Nothing - [_] -> Nothing - (m:_) -> Just m - layer = modname >>= (\n -> layers ^.moduleLayer.at n) - maybe (pure $ S.Right Nothing) (\hq -> hq scps q t) layer + eglobal <- (layers^.globalLayer) scps q t + eenvironment <- (layers ^.environmentLayer) scps q t + let modname = + case Text.splitOn "::" (Text.dropWhile (==':') q) of + [] -> Nothing + [_] -> Nothing + (m:_) -> Just m + layer = modname >>= (\n -> layers ^.moduleLayer.at n) + emodle <- maybe (pure Nothing) (\hq -> hq scps q t) layer + case catMaybes [eglobal, eenvironment, emodle] of + [] -> pure Nothing + x:xs -> Just <$> foldM (mergeWith t) x xs + diff --git a/src/Puppet/Interpreter/Resolve.hs b/src/Puppet/Interpreter/Resolve.hs --- a/src/Puppet/Interpreter/Resolve.hs +++ b/src/Puppet/Interpreter/Resolve.hs @@ -93,12 +93,17 @@ runHiera q t = do -- We need to merge the current scope with the top level scope scps <- use scopes - ctx <- getScopeName - let getV scp = mapMaybe toStr $ HM.toList $ fmap (view (_1 . _1)) (scps ^. ix scp . scopeVariables) - toStr (k,v) = fmap (k,) (preview _PString v) - toplevels = map (_1 %~ ("::" <>)) $ getV "::" - locals = getV ctx - vars = HM.fromList (toplevels <> locals) + curscopes <- use curScope + let getV scp = HM.toList $ fmap (view (_1 . _1)) (scps ^. ix scp . scopeVariables) + vars = HM.unions $ do + curscp <- curscopes + let sname = scopeName curscp + curv = getV sname + prefixVarname vname = + case curscp of + ContRoot -> "::" <> vname + _ -> sname <> "::" <> vname + [HM.fromList curv, HM.fromList (map (_1 %~ prefixVarname) curv)] Operational.singleton (HieraQuery vars q t) -- | The implementation of all lookup functions @@ -108,7 +113,7 @@ qs <- resolvePValueString q runHiera qs qt >>= \case Just p -> case dt of - Just dt' | not (datatypeMatch dt' p) -> throwPosError "Datatype mismatched" + Just dt' | not (datatypeMatch dt' p) -> throwPosError ("Datatype mismatched :" <+> pretty dt' <+> "/" <+> pretty p) _ -> pure p Nothing -> case df of Just d -> pure d @@ -331,10 +336,8 @@ case (ra, rb) of (PArray ha, v) -> pure (PArray (V.snoc ha v)) _ -> integerOperation a b (\x -> shiftL x . fromIntegral) -resolveExpression a@(FunctionApplication e (Terminal (UHOLambdaCall hol))) = do - unless (null (hol ^. hoLambdaExpr)) - (throwPosError ("You can't combine chains of higher order functions (with .) and giving them parameters, in:" <+> pretty a)) - resolveValue (UHOLambdaCall (hol & hoLambdaExpr .~ V.singleton e)) +resolveExpression (FunctionApplication e (Terminal (UHOLambdaCall hol))) = + resolveValue (UHOLambdaCall (hol & hoLambdaExpr <>~ V.singleton e)) resolveExpression (FunctionApplication _ x) = throwPosError ("Expected function application here, not" <+> pretty x) resolveExpression (Negate x) = PNumber . negate <$> resolveExpressionNumber x @@ -566,7 +569,7 @@ resolveFunction' "hiera_hash" [q,d,o] = hieraCall QHash q (Just d) Nothing (Just o) resolveFunction' "lookup" [q] = hieraCall QFirst q Nothing Nothing Nothing resolveFunction' "lookup" [q, PType dt] = hieraCall QFirst q Nothing (Just dt) Nothing -resolveFunction' "lookup" [q, PType dt, PString qt, def] = do +resolveFunction' "lookup" [q, PType dt, PString qt, def] = case readQueryType qt of Nothing -> throwPosError ("Unknown merge strategy " <> ppline qt) Just qt' -> hieraCall qt' q (Just def) (Just dt) Nothing @@ -797,6 +800,30 @@ PArray ar -> pure $ PArray $ V.map fst $ V.filter snd $ V.zip ar (V.fromList res) PHash hh -> pure $ PHash $ HM.fromList $ map fst $ filter snd $ zip (HM.toList hh) res x -> throwPosError ("Can't iterate on this data type:" <+> pretty x) + LambdaFunc "reduce" -> + case hol ^.. hoLambdaExpr . folded of + [zero', foldable'] -> do + zero'' <- resolveExpression zero' + foldable'' <- resolveExpression foldable' + (accname, curname) <- case hol ^.. hoLambdaParams . folded of + [an, cn] -> pure (an, cn) + _ -> throwPosError ("Reduce requires two parameters in its block expression, in" <+> pretty hol) + let runStep acc cur = do + accName <- mCheckType acc accname + curName <- mCheckType cur curname + runblock [(accName, acc), (curName, cur)] + mCheckType vl (LambdaParam mt nm) = do + forM_ mt $ \ut -> do + t <- resolveDataType ut + checkMatch t vl + pure nm + case foldable'' of + PArray ar -> foldM runStep zero'' ar + PHash hs -> foldM runStep zero'' $ do + (k,v) <- HM.toList hs + return (PArray (V.fromList [PString k, v])) + x -> throwPosError ("Can't iterate on this data type:" <+> pretty x) + _ -> throwPosError ("Reduce requires two arguments and a lambda block, in" <+> pretty hol) x -> throwPosError ("This type of lambda function is not supported yet by language-puppet!" <+> pretty x) -- | Checks that a value matches a puppet datatype diff --git a/src/Puppet/Interpreter/Types.hs b/src/Puppet/Interpreter/Types.hs --- a/src/Puppet/Interpreter/Types.hs +++ b/src/Puppet/Interpreter/Types.hs @@ -238,7 +238,7 @@ ExternalFunction :: Text -> [PValue] -> InterpreterInstr PValue Facts :: InterpreterInstr (Container PValue) GetNodeName :: InterpreterInstr Text - HieraQuery :: Container Text -> Text -> HieraQueryType -> InterpreterInstr (Maybe PValue) + HieraQuery :: Container PValue -> Text -> HieraQueryType -> InterpreterInstr (Maybe PValue) GetCurrentCallStack :: InterpreterInstr [String] IsIgnoredModule :: Text -> InterpreterInstr Bool IsExternalModule :: Text -> InterpreterInstr Bool diff --git a/src/Puppet/Runner/Erb.hs b/src/Puppet/Runner/Erb.hs --- a/src/Puppet/Runner/Erb.hs +++ b/src/Puppet/Runner/Erb.hs @@ -128,7 +128,7 @@ Left err -> do let !msg = "At " <> showPPos'(intpstate^.curPos) <> " the evaluation of template '" <> template_src <> "' failed. " <> show err -- if the haskell evaluation fails the ruby one will fallback. It is likely that the reason for the failure is a real template issue. - logCriticalStr msg + logErrorStr msg measure mstats ("ruby efail - " <> toS template_src) $ mkSafe $ computeTemplateWRuby srcinfo curcontext variables intpstate intpreader traceEventIO ("STOP template " <> template_src) pure o @@ -136,7 +136,7 @@ getRubyScriptPath :: String -> IO String getRubyScriptPath rubybin = do let checkpath :: FilePath -> IO FilePath -> IO FilePath - checkpath fp nxt = do + checkpath fp nxt = ifM (fileExist fp) (pure fp) nxt @@ -200,7 +200,7 @@ contentinfo <- case fileinfo of Filename fname -> FR.toRuby (Text.pack fname) Inline _ -> FR.toRuby ("-" :: Text) - let withBinding f = do + let withBinding f = FR.safeMethodCall "ErbBinding" "new" [rscp,rvariables,rstt,rrdr,contentinfo] >>= \case Left x -> pure (Left x) Right v -> do diff --git a/src/Puppet/Runner/Pure.hs b/src/Puppet/Runner/Pure.hs --- a/src/Puppet/Runner/Pure.hs +++ b/src/Puppet/Runner/Pure.hs @@ -78,8 +78,8 @@ mempty where pure_hiera :: HieraQueryFunc Identity - pure_hiera _ _ _ = pure (S.Right hiera) - hieradummy = HieraQueryLayers pure_hiera pure_hiera mempty + pure_hiera _ _ _ = pure hiera + hieradummy = HieraQueryLayers pure_hiera (\_ _ _ -> pure Nothing) mempty getstatementdummy tlt n = return $ case HM.lookup (tlt,n) sttmap of Just x -> S.Right x Nothing -> S.Left "Can't get statement" diff --git a/src/Puppet/Runner/Stdlib.hs b/src/Puppet/Runner/Stdlib.hs --- a/src/Puppet/Runner/Stdlib.hs +++ b/src/Puppet/Runner/Stdlib.hs @@ -22,6 +22,7 @@ import qualified System.FilePath as FilePath import Puppet.Interpreter +import Puppet.Interpreter.Helpers -- | Contains the implementation of the StdLib functions. stdlibFunctions :: Container ( [PValue] -> InterpreterMonad PValue ) @@ -241,7 +242,7 @@ "encode" -> return (B16.encode b) "decode" -> case B16.decode b of (x, "") -> return x - _ -> throwPosError ("base64(): could not decode" <+> pretty pb) + _ -> error ("base64(): could not decode" <+> pretty pb) *> pure mempty a -> throwPosError ("base64(): the first argument must be either 'encode' or 'decode', not" <+> ppline a) pure $ PString (decodeUtf8 r) base64 _ = throwPosError "base64(): Expects 2 arguments" diff --git a/src/PuppetDB/Remote.hs b/src/PuppetDB/Remote.hs --- a/src/PuppetDB/Remote.hs +++ b/src/PuppetDB/Remote.hs @@ -16,7 +16,6 @@ import Puppet.Language import PuppetDB.Core - type PDBAPIv3 = "nodes" :> QueryParam "query" (Query NodeField) :> Get '[JSON] [NodeInfo] :<|> "nodes" :> Capture "resourcename" Text :> "resources" :> QueryParam "query" (Query ResourceField) :> Get '[JSON] [Resource] :<|> "facts" :> QueryParam "query" (Query FactField) :> Get '[JSON] [FactInfo] @@ -32,6 +31,10 @@ mkClientEnv = ClientEnv #endif +#if !MIN_VERSION_servant_client(0,16,0) +#define ClientError ServantError +#endif + -- | Given an URL (ie. @http://localhost:8080@), will return an incomplete 'PuppetDBAPI'. pdbConnect :: Manager -> String -> IO (Either PrettyError (PuppetDBAPI IO)) pdbConnect mgr url = do @@ -54,5 +57,5 @@ sgetResources :: Maybe (Query ResourceField) -> ClientM [Resource] (sgetNodes :<|> sgetNodeResources :<|> sgetFacts :<|> sgetResources) = client api - prettyError :: IO (Either ServantError b) -> ExceptT PrettyError IO b + prettyError :: IO (Either ClientError b) -> ExceptT PrettyError IO b prettyError = ExceptT . fmap (_Left %~ PrettyError . pplines . show) diff --git a/src/XPrelude/Extra.hs b/src/XPrelude/Extra.hs --- a/src/XPrelude/Extra.hs +++ b/src/XPrelude/Extra.hs @@ -19,6 +19,7 @@ , logWarning , logWarningStr , logError + , logErrorStr , logCritical , logCriticalStr ) where @@ -121,6 +122,9 @@ logError :: Text -> IO () logError = Log.errorM "language-puppet" . toS + +logErrorStr :: String -> IO () +logErrorStr = Log.errorM "language-puppet" logCritical :: Text -> IO () logCritical = Log.criticalM "language-puppet" . toS diff --git a/tests/ErbSpec.hs b/tests/ErbSpec.hs --- a/tests/ErbSpec.hs +++ b/tests/ErbSpec.hs @@ -28,6 +28,9 @@ , ("<%= scope.lookupvar('::fqdn') %>", [ Puts (Value (Literal "")) , Puts (ScopeObject (Value (Literal "::fqdn"))) , Puts(Value (Literal ""))]) + , ("<%= scope.lookupvar(\"::fqdn\") %>", [ Puts (Value (Literal "")) + , Puts (ScopeObject (Value (Literal "::fqdn"))) + , Puts(Value (Literal ""))]) ] resolvetests :: [([RubyStatement], Text)] diff --git a/tests/HieraSpec.hs b/tests/HieraSpec.hs --- a/tests/HieraSpec.hs +++ b/tests/HieraSpec.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE QuasiQuotes #-} module HieraSpec(spec) where import XPrelude -import qualified Data.Either.Strict as S import qualified Data.HashMap.Strict as HM import qualified Data.Vector as Vector import qualified System.Log.Logger as Log @@ -12,69 +10,219 @@ import Hiera.Server import Puppet.Language -checkOutput v (S.Right x) = x `shouldBe` v -checkOutput _ (S.Left rr) = expectationFailure (show rr) +checkOutput :: (Eq a, Show rr, Show a) => a -> Either rr a -> Expectation +checkOutput v (Right x) = x `shouldBe` v +checkOutput _ (Left rr) = expectationFailure (show rr) +checkFail :: (Show a) => Either rr a -> Expectation +checkFail (Right v) = expectationFailure ("Should have failed, but returned: " ++ show v) +checkFail _ = return () + +fqdn :: Text fqdn = "node.com" + +config_v3 :: FilePath config_v3 = "./tests/hiera/hiera-v3.yaml" + +config_v5 :: FilePath config_v5 = "./tests/hiera/hiera-v5.yaml" +configInterpolate :: FilePath +configInterpolate = "./tests/hiera/interpolate/config/hiera.yaml" + +vars :: HM.HashMap Text PValue vars = HM.fromList [ ("::environment", "production") - , ("::fqdn" , fqdn) + , ("::fqdn" , PString fqdn) ] + +users :: HM.HashMap Text PValue users = HM.fromList [ ("pete", PHash (HM.singleton "uid" (PNumber 2000))) , ("tom" , PHash (HM.singleton "uid" (PNumber 2001))) ] + +pusers :: HM.HashMap Text PValue pusers = HM.fromList [ ("bob", PHash (HM.singleton "uid" (PNumber 100))) , ("tom" , PHash (HM.singleton "uid" (PNumber 12))) ] +hash :: [(Text, PValue)] -> PValue +hash = PHash . HM.fromList + +array :: [PValue] -> PValue +array = PArray . Vector.fromList + +spec :: Spec spec = do runIO $ Log.updateGlobalLogger loggerName (Log.setLevel Log.WARNING) - q3 <- runIO $ startHiera "test" config_v3 - q5 <- runIO $ startHiera "test" config_v5 + q3_ <- runIO $ startHiera "test" config_v3 + q5_ <- runIO $ startHiera "test" config_v5 + let q5 vrs var t = runExceptT (q5_ vrs var t) + q3 vrs var t = runExceptT (q3_ vrs var t) describe "Hiera" $ do - describe "v5 lookup hierarchy" $ do - it "should override some values" $ do - q5 vars "http_port" QFirst >>= checkOutput (Just (PNumber 9090)) - q5 vars "global" QFirst >>= checkOutput (Just "glob") - describe "v5 ~" $ do - it "should read '~' as a Null/Nothing value" $ do - q5 vars "optional_value" QFirst >>= checkOutput Nothing - describe "v3 lookup with no context variables" $ do - it "should return nothing when called with an empty string" $ - q3 mempty "" QFirst >>= checkOutput Nothing - it "should return nothing when called with a non existent key [First merge]" $ - q3 mempty "foo" QFirst >>= checkOutput Nothing - it "should return nothing when called with a non existent key [Unique merge]" $ - q3 mempty "foo" QUnique >>= checkOutput Nothing - it "should return nothing when called with a non existent key [Hash merge]" $ - q3 mempty "foo" QHash >>= checkOutput Nothing - it "should return common data" $ - q3 mempty "http_port" QFirst >>= checkOutput (Just (PNumber 8080)) - it "should return arrays" $ - q3 mempty "ntp_servers" QFirst >>= checkOutput (Just (PArray (Vector.fromList ["0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"]))) - it "should return hashes" $ - q3 mempty "users" QFirst >>= checkOutput (Just (PHash users)) - describe "v3 lookup hierarchy" $ do - it "should override value" $ - q3 vars "http_port" QFirst >>= checkOutput (Just (PNumber 9090)) - it "should find common value" $ - q3 vars "global" QFirst >>= checkOutput (Just "glob") - describe "v3 json backend" $ - it "resolves in json" $ - q3 vars "testjson" QFirst >>= checkOutput (Just "ok") - describe "v3 deep interpolation" $ do - it "resolves in strings" $ - q3 vars "interp1" QFirst >>= checkOutput (Just (PString ("**" <> fqdn <> "**"))) - it "resolves in objects" $ - q3 vars "testnode" QFirst >>= checkOutput (Just (PHash (HM.fromList [("1",PString ("**" <> fqdn <> "**")),("2",PString "nothing special")]))) - it "resolves in arrays" $ - q3 vars "arraytest" QFirst >>= checkOutput (Just (PArray (Vector.fromList [PString "a", PString fqdn, PString "c"]))) - describe "v3 other merge modes" $ do - it "catenates arrays" $ - q3 vars "ntp_servers" QUnique >>= checkOutput (Just (PArray (Vector.fromList ["2.ntp.puppetlabs.com","3.ntp.puppetlabs.com","0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"]))) - it "puts single values in arrays" $ - q3 vars "http_port" QUnique >>= checkOutput (Just (PArray (Vector.fromList [PNumber 9090, PNumber 8080]))) - it "merges hashes" $ - q3 vars "users" QHash >>= checkOutput (Just (PHash (pusers <> users))) + interpolationSpec + describe "v5 lookup hierarchy" $ + it "should override some values" $ do + q5 vars "http_port" QFirst >>= checkOutput (Just (PNumber 9090)) + q5 vars "global" QFirst >>= checkOutput (Just "glob") + describe "v5 ~" $ + it "should read '~' as a Null/Nothing value" $ + q5 vars "optional_value" QFirst >>= checkOutput (Just PUndef) + describe "v3 lookup with no context variables" $ do + it "should return nothing when called with an empty string" $ + q3 mempty "" QFirst >>= checkOutput Nothing + it "should return nothing when called with a non existent key [First merge]" $ + q3 mempty "foo" QFirst >>= checkOutput Nothing + it "should return nothing when called with a non existent key [Unique merge]" $ + q3 mempty "foo" QUnique >>= checkOutput Nothing + it "should return nothing when called with a non existent key [Hash merge]" $ + q3 mempty "foo" QHash >>= checkOutput Nothing + it "should return common data" $ + q3 mempty "http_port" QFirst >>= checkOutput (Just (PNumber 8080)) + it "should return arrays" $ + q3 mempty "ntp_servers" QFirst >>= checkOutput (Just (array ["0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])) + it "should return hashes" $ + q3 mempty "users" QFirst >>= checkOutput (Just (PHash users)) + describe "v3 lookup hierarchy" $ do + it "should override value" $ + q3 vars "http_port" QFirst >>= checkOutput (Just (PNumber 9090)) + it "should find common value" $ + q3 vars "global" QFirst >>= checkOutput (Just "glob") + describe "v3 json backend" $ + it "resolves in json" $ + q3 vars "testjson" QFirst >>= checkOutput (Just "ok") + describe "v3 deep interpolation" $ do + it "resolves in strings" $ + q3 vars "interp1" QFirst >>= checkOutput (Just (PString ("**" <> fqdn <> "**"))) + it "resolves in objects" $ + q3 vars "testnode" QFirst >>= checkOutput (Just (hash [("1",PString ("**" <> fqdn <> "**")),("2",PString "nothing special")])) + it "resolves in arrays" $ + q3 vars "arraytest" QFirst >>= checkOutput (Just (array [PString "a", PString fqdn, PString "c"])) + it "resolves aliases" $ + q3 vars "aliased" QFirst >>= checkOutput (Just (array [PString "a", PString "b"])) + it "resolves integers to strings" $ + q3 vars "server" QFirst >>= checkOutput (Just (PString "127.0.0.1:9090")) + it "resolves lookus" $ + q3 vars "aliased_lookup" QFirst >>= checkOutput (Just (PNumber 100)) + describe "v3 other merge modes" $ do + it "catenates arrays" $ + q3 vars "ntp_servers" QUnique >>= checkOutput (Just (array ["2.ntp.puppetlabs.com","3.ntp.puppetlabs.com","0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])) + it "puts single values in arrays" $ + q3 vars "http_port" QUnique >>= checkOutput (Just (array [PNumber 9090, PNumber 8080])) + it "merges hashes" $ + q3 vars "users" QHash >>= checkOutput (Just (PHash (pusers <> users))) + +interpolationSpec :: Spec +interpolationSpec = + describe "interpolation" $ do + q_ <- runIO $ startHiera "test" configInterpolate + let q vrs var t = runExceptT (q_ vrs var t) + describe "when doing interpolation" $ do + it "should prevent endless recursion" $ + q mempty "foo" QFirst >>= checkFail + it "produces a nested hash with arrays from nested aliases with hashes and arrays" $ + q mempty "root" QHash >>= checkOutput (Just (hash [("a", hash [("aa", hash [("b", hash [("bb", PArray (Vector.fromList ["text"]))])])])])) + it "allows keys with white space" $ + q mempty "ws_key" QFirst >>= checkOutput (Just "value for a ws key") + it "allows keys with non alphanumeric characters" $ + q mempty "angry" QFirst >>= checkOutput (Just "not happy") + + describe "when not finding value for interpolated key" $ + it "should resolve the interpolation to an empty string" $ + q mempty "niltest" QFirst >>= checkFail -- puppet behavior: checkOutput (Just "Missing key ##. Key with nil ##") + + describe "when there are empty interpolations %{} in data" $ do + it "should should produce an empty string for the interpolation" $ do + pendingWith "Support empty interpolation" + q mempty "empty_interpolation" QFirst >>= checkOutput (Just "clownshoe") + it "the empty interpolation can be escaped" $ do + pendingWith "Support empty interpolation" + q mempty "escaped_empty_interpolation" QFirst >>= checkOutput (Just "clown%{shoe}s") + it "the value can consist of only an empty escape" $ do + pendingWith "Support empty interpolation" + q mempty "only_empty_interpolation" QFirst >>= checkOutput (Just "") + it "the value can consist of an empty namespace %{::}" $ do + pendingWith "Support empty interpolation" + q mempty "empty_namespace" QFirst >>= checkOutput (Just "") + it "the value can consist of whitespace %{ :: }" $ do + pendingWith "Support empty interpolation" + q mempty "whitespace1" QFirst >>= checkOutput (Just "") + it "the value can consist of whitespace %{ }" $ do + pendingWith "Support empty interpolation" + q mempty "whitespace2" QFirst >>= checkOutput (Just "") + + describe "when there are quoted empty interpolations %{} in data" $ do + it "should should produce an empty string for the interpolation" $ do + pendingWith "Support empty interpolation" + q mempty "quoted_empty_interpolation" QFirst >>= checkOutput (Just "clownshoe") + it "the empty interpolation can be escaped" $ do + pendingWith "Support empty interpolation" + q mempty "quoted_escaped_empty_interpolation" QFirst >>= checkOutput (Just "clown%{shoe}s") + it "the value can consist of only an empty escape" $ do + pendingWith "Support empty interpolation" + q mempty "quoted_only_empty_interpolation" QFirst >>= checkOutput (Just "") + it "the value can consist of an empty namespace %{::}" $ do + pendingWith "Support empty interpolation" + q mempty "quoted_empty_namespace" QFirst >>= checkOutput (Just "") + it "the value can consist of whitespace %{ :: }" $ do + pendingWith "Support empty interpolation" + q mempty "quoted_whitespace1" QFirst >>= checkOutput (Just "") + it "the value can consist of whitespace %{ }" $ do + pendingWith "Support empty interpolation" + q mempty "quoted_whitespace2" QFirst >>= checkOutput (Just "") + + describe "varsplitter" $ do + it "no splitting" $ varSplitter "abcd" `shouldBe` ["abcd"] + it "split 2" $ varSplitter "ab.cd" `shouldBe` ["ab", "cd"] + it "split 3" $ varSplitter "ab.cd.ef" `shouldBe` ["ab", "cd", "ef"] + it "split dq" $ varSplitter "\"ab\"" `shouldBe` ["ab"] + it "split dq 2" $ varSplitter "\"ab.cd\"" `shouldBe` ["ab.cd"] + it "split dq 2 mixed" $ varSplitter "\"ab.cd\".ef" `shouldBe` ["ab.cd", "ef"] + it "split dq 2 mixed 4" $ varSplitter "\"ab.cd\".ef.\"lol.cat\".bar" `shouldBe` ["ab.cd", "ef", "lol.cat", "bar"] + it "split sq" $ varSplitter "'ab'" `shouldBe` ["ab"] + it "split sq 2" $ varSplitter "'ab.cd'" `shouldBe` ["ab.cd"] + it "split sq 2 mixed" $ varSplitter "'ab.cd'.ef" `shouldBe` ["ab.cd", "ef"] + it "split sq 2 mixed 4" $ varSplitter "'ab.cd'.ef.'lol.cat'.bar" `shouldBe` ["ab.cd", "ef", "lol.cat", "bar"] + it "split all mixed" $ varSplitter "'a.b'.\"c.d\".e.f" `shouldBe` ["a.b", "c.d", "e", "f"] + + describe "when using dotted keys" $ do + it "should find an entry using a quoted interpolation" $ + q (HM.fromList [("a.b", "(scope) a dot b")]) "\"a.c.scope\"" QFirst >>= checkOutput (Just "a dot c: (scope) a dot b") + it "should find an entry using a quoted interpolation with method hiera" $ + q (HM.fromList [("a.b", "(scope) a dot b")]) "\"a.c.hiera\"" QFirst >>= checkOutput (Just "a dot c: (hiera) a dot b") + it "should find an entry using a quoted interpolation with method alias" $ + q (HM.fromList [("a.b", "(scope) a dot b")]) "\"a.c.alias\"" QFirst >>= checkOutput (Just "(hiera) a dot b") + it "should use a dotted key to navigate into a structure when it is not quoted" $ + q (HM.fromList [("a", hash [("d", "(scope) a dot d is a hash entry")])]) "\"a.e.scope\"" QFirst >>= checkOutput (Just "a dot e: (scope) a dot d is a hash entry") + it "should use a dotted key to navigate into a structure when when it is not quoted with method hiera" $ + q (HM.fromList [("a", hash [("d", "(scope) a dot d is a hash entry")])]) "\"a.e.hiera\"" QFirst >>= checkOutput (Just "a dot e: (hiera) a dot d is a hash entry") + it "should use a mix of quoted and dotted keys to navigate into a structure containing dotted keys and quoted key is last" $ + q (HM.fromList [("a", hash [("d.x", "(scope) a dot d.x is a hash entry")])]) "\"a.ex.scope\"" QFirst >>= checkOutput (Just "a dot ex: (scope) a dot d.x is a hash entry") + it "should use a mix of quoted and dotted keys to navigate into a structure containing dotted keys and quoted key is last and method is hiera" $ + q (HM.fromList [("a", hash [("d.x", "(scope) a dot d.x is a hash entry")])]) "\"a.ex.hiera\"" QFirst >>= checkOutput (Just "a dot ex: (hiera) a dot d.x is a hash entry") + it "should use a mix of quoted and dotted keys to navigate into a structure containing dotted keys and quoted key is first" $ + q (HM.fromList [("a.x", hash [("d", "(scope) a.x dot d is a hash entry")])]) "\"a.xe.scope\"" QFirst >>= checkOutput (Just "a dot xe: (scope) a.x dot d is a hash entry") + it "should use a mix of quoted and dotted keys to navigate into a structure containing dotted keys and quoted key is first and method is hiera" $ + q (HM.fromList [("a.x", hash [("d", "(scope) a.x dot d is a hash entry")])]) "\"a.xe.hiera\"" QFirst >>= checkOutput (Just "a dot xe: (hiera) a.x dot d is a hash entry") + it "should use a mix of quoted and dotted keys to navigate into a structure containing dotted keys and quoted key is in the middle" $ + q (HM.fromList [("a", hash [("d.z", hash [("g", "(scope) a dot d.z dot g is a hash entry")])])]) "\"a.xm.scope\"" QFirst >>= checkOutput (Just "a dot xm: (scope) a dot d.z dot g is a hash entry") + it "should use a mix of quoted and dotted keys to navigate into a structure containing dotted keys and quoted key is in the middle and method is hiera" $ + q (HM.fromList [("a", hash [("d.z", hash [("g", "(scope) a dot d.z dot g is a hash entry")])])]) "\"a.xm.hiera\"" QFirst >>= checkOutput (Just "a dot xm: (hiera) a dot d.z dot g is a hash entry") + it "should use a mix of several quoted and dotted keys to navigate into a structure containing dotted keys and quoted key is in the middle" $ + q (HM.fromList [("a.x", hash [("d.z", hash [("g", "(scope) a.x dot d.z dot g is a hash entry")])])]) "\"a.xx.scope\"" QFirst >>= checkOutput (Just "a dot xx: (scope) a.x dot d.z dot g is a hash entry") + it "should use a mix of several quoted and dotted keys to navigate into a structure containing dotted keys and quoted key is in the middle and method is hiera" $ + q (HM.fromList [("a.x", hash [("d.z", hash [("g", "(scope) a.x dot d.z dot g is a hash entry")])])]) "\"a.xx.hiera\"" QFirst >>= checkOutput (Just "a dot xx: (hiera) a.x dot d.z dot g is a hash entry") + it "should find an entry using using a quoted interpolation on dotted key containing numbers" $ + q (HM.fromList [("x.1", "(scope) x dot 1")]) "\"x.2.scope\"" QFirst >>= checkOutput (Just "x dot 2: (scope) x dot 1") + it "should find an entry using using a quoted interpolation on dotted key containing numbers using method hiera" $ + q (HM.fromList [("x.1", "(scope) x dot 1")]) "\"x.2.hiera\"" QFirst >>= checkOutput (Just "x dot 2: (hiera) x dot 1") + it "will allow strange characters in the key" $ + q mempty "very_angry" QFirst >>= checkOutput (Just "not happy at all") + it "should not find a subkey when the dotted key is quoted" $ + q (HM.fromList [("a", hash [("f", "(scope) a dot f is a hash entry")])]) "\"a.f.scope\"" QFirst >>= checkFail -- real hiera : checkOutput (Just "a dot f: ") + it "should not find a subkey when the dotted key is quoted with method hiera" $ + q (HM.fromList [("a", hash [("f", "(scope) a dot f is a hash entry")])]) "\"a.f.hiera\"" QFirst >>= checkFail -- real hiera : checkOutput (Just "a dot f: ") + it "should not find a subkey that is matched within a string" $ + q mempty "ipl_key" QFirst >>= checkFail + it "should not find a subkey that is matched within a string" $ + q mempty "key.subkey" QFirst >>= checkFail + diff --git a/tests/Interpreter/Function/LookupSpec.hs b/tests/Interpreter/Function/LookupSpec.hs --- a/tests/Interpreter/Function/LookupSpec.hs +++ b/tests/Interpreter/Function/LookupSpec.hs @@ -5,11 +5,15 @@ main :: IO () main = hspec spec +fname :: Text fname = "lookup" +expectedErrMsg :: String expectedErrMsg = "Wrong set of arguments" -- See dummyFacts defined in Pure.hs +testkey :: Expression testkey = "foo" +expectedValue :: Text expectedValue = "dummy" checkSuccess :: [Expression] -> Text -> Expectation @@ -18,6 +22,7 @@ checkError :: [Expression] -> String -> Expectation checkError = checkExprsError fname +boolDatatype, stringDatatype :: Expression boolDatatype = Terminal (UDataType UDTBoolean) stringDatatype = Terminal (UDataType (UDTString Nothing Nothing)) diff --git a/tests/hiera/interpolate/config/hiera.yaml b/tests/hiera/interpolate/config/hiera.yaml new file mode 100644 --- /dev/null +++ b/tests/hiera/interpolate/config/hiera.yaml @@ -0,0 +1,14 @@ +:backends: + - yaml + +:hierarchy: + - recursive + - niltest + - complex + - empty_%{}inter%{::}polation + - dotted_keys + - weird_keys + - bad_interpolation + +:yaml: + :datadir: '../data' diff --git a/tests/hiera/interpolate/config/hiera_iplm_hiera.yaml b/tests/hiera/interpolate/config/hiera_iplm_hiera.yaml new file mode 100644 --- /dev/null +++ b/tests/hiera/interpolate/config/hiera_iplm_hiera.yaml @@ -0,0 +1,6 @@ +:backends: + - json + +:hierarchy: + - role + - "%{hiera('role')}" diff --git a/tests/hiera/interpolate/config/hiera_iplm_hiera_bad.yaml b/tests/hiera/interpolate/config/hiera_iplm_hiera_bad.yaml new file mode 100644 --- /dev/null +++ b/tests/hiera/interpolate/config/hiera_iplm_hiera_bad.yaml @@ -0,0 +1,5 @@ +:backends: + - yaml + +:hierarchy: + - "%{hiera('role')}" diff --git a/tests/hiera/interpolate/data/bad_interpolation.yaml b/tests/hiera/interpolate/data/bad_interpolation.yaml new file mode 100644 --- /dev/null +++ b/tests/hiera/interpolate/data/bad_interpolation.yaml @@ -0,0 +1,9 @@ +--- +quote_mismatch: 'Key delimited with singe quote on one side aand double qoute on the other: %{''the.key"}' +quote_mismatch_arg: 'Arg delimited with singe quote on one side and double qoute on the other: %{hiera(''the.key")}' +non_existing_method: 'The method flubber does not exist: %{flubber("hello")}' + +one_quote: 'Key with only one quote: %{the.''key}' +empty_segment: 'Key with only one quote: %{the..key}' +empty_quoted_segment: 'Key with only one quote: %{the.''''.key}' +partly_quoted_segment: 'Key with only one quote: %{the.''pa''key}' diff --git a/tests/hiera/interpolate/data/complex.yaml b/tests/hiera/interpolate/data/complex.yaml new file mode 100644 --- /dev/null +++ b/tests/hiera/interpolate/data/complex.yaml @@ -0,0 +1,12 @@ +--- +root: + a: + aa: "%{alias('aaa')}" + +aaa: + b: + bb: "%{alias('bbb')}" + +bbb: [ "%{alias('ccc')}" ] + +ccc: text diff --git a/tests/hiera/interpolate/data/dotted_keys.yaml b/tests/hiera/interpolate/data/dotted_keys.yaml new file mode 100644 --- /dev/null +++ b/tests/hiera/interpolate/data/dotted_keys.yaml @@ -0,0 +1,43 @@ +--- +a.b: '(hiera) a dot b' +a.c.scope: "a dot c: %{'a.b'}" +a.c.hiera: 'a dot c: %{hiera("''a.b''")}' +a.c.scope: "a dot c: %{'a.b'}" +a.c.hiera: 'a dot c: %{hiera("''a.b''")}' +a.c.alias: '%{alias("''a.b''")}' +a: + d: '(hiera) a dot d is a hash entry' + d.x: '(hiera) a dot d.x is a hash entry' + d.z: + g: '(hiera) a dot d.z dot g is a hash entry' + +a.x: + d: '(hiera) a.x dot d is a hash entry' + d.x: '(hiera) a.x dot d.x is a hash entry' + d.z: + g: '(hiera) a.x dot d.z dot g is a hash entry' + +a.e.scope: "a dot e: %{a.d}" +a.e.hiera: "a dot e: %{hiera('a.d')}" + +a.ex.scope: "a dot ex: %{a.'d.x'}" +a.ex.hiera: 'a dot ex: %{hiera("a.''d.x''")}' + +a.xe.scope: "a dot xe: %{'a.x'.d}" +a.xe.hiera: 'a dot xe: %{hiera("''a.x''.d")}' + +a.xm.scope: "a dot xm: %{a.'d.z'.g}" +a.xm.hiera: 'a dot xm: %{hiera("a.''d.z''.g")}' + +a.xx.scope: "a dot xx: %{'a.x'.'d.z'.g}" +a.xx.hiera: 'a dot xx: %{hiera("''a.x''.''d.z''.g")}' + +a.f.scope: "a dot f: %{'a.d'}" +a.f.hiera: 'a dot f: %{hiera("''a.d''")}' + +x.1: '(hiera) x dot 1' +x.2.scope: "x dot 2: %{'x.1'}" +x.2.hiera: 'x dot 2: %{hiera("''x.1''")}' + +key: subkey +ipl_key: '- %{hiera("key.subkey")} -' diff --git a/tests/hiera/interpolate/data/empty_interpolation.yaml b/tests/hiera/interpolate/data/empty_interpolation.yaml new file mode 100644 --- /dev/null +++ b/tests/hiera/interpolate/data/empty_interpolation.yaml @@ -0,0 +1,13 @@ +empty_interpolation: 'clown%{}shoe' +escaped_empty_interpolation: 'clown%%{}{shoe}s' +only_empty_interpolation: '%{}' +empty_namespace: '%{::}' +whitespace1: '%{ :: }' +whitespace2: '%{ }' + +quoted_empty_interpolation: 'clown%{""}shoe' +quoted_escaped_empty_interpolation: 'clown%%{""}{shoe}s' +quoted_only_empty_interpolation: '%{""}' +quoted_empty_namespace: '%{"::"}' +quoted_whitespace1: '%{ "::" }' +quoted_whitespace2: '%{ "" }' diff --git a/tests/hiera/interpolate/data/niltest.yaml b/tests/hiera/interpolate/data/niltest.yaml new file mode 100644 --- /dev/null +++ b/tests/hiera/interpolate/data/niltest.yaml @@ -0,0 +1,2 @@ +niltest: 'Missing key #%{hiera("knotfound")}#. Key with nil #%{hiera("knil")}#' +knil: null diff --git a/tests/hiera/interpolate/data/recursive.yaml b/tests/hiera/interpolate/data/recursive.yaml new file mode 100644 --- /dev/null +++ b/tests/hiera/interpolate/data/recursive.yaml @@ -0,0 +1,3 @@ +foo: '%{hiera("bar")}' + +bar: '%{hiera("foo")}' diff --git a/tests/hiera/interpolate/data/weird_keys.yaml b/tests/hiera/interpolate/data/weird_keys.yaml new file mode 100644 --- /dev/null +++ b/tests/hiera/interpolate/data/weird_keys.yaml @@ -0,0 +1,12 @@ +--- + +'a key with whitespace': 'value for a ws key' +ws_key: '%{alias("a key with whitespace")}' + +'#@!&%|§': 'not happy' +angry: '%{alias("#@!&%|§")}' + +'!$\%!': + '#@!&%|§': 'not happy at all' + +very_angry: '%{alias("!$\%!.#@!&%|§")}' diff --git a/tests/hiera/production.yaml b/tests/hiera/production.yaml --- a/tests/hiera/production.yaml +++ b/tests/hiera/production.yaml @@ -7,3 +7,9 @@ uid: 100 tom: uid: 12 +original: + - a + - b +aliased: "%{alias('original')}" +server: "127.0.0.1:%{lookup('http_port')}" +aliased_lookup: "%{alias('users.bob.uid')}"